home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / ext / attrs / attrs.xs < prev    next >
Text File  |  1999-10-01  |  1KB  |  67 lines
  1. #define PERL_NO_GET_CONTEXT
  2. #include "EXTERN.h"
  3. #include "perl.h"
  4. #include "XSUB.h"
  5.  
  6. static cv_flags_t
  7. get_flag(char *attr)
  8. {
  9.     if (strnEQ(attr, "method", 6))
  10.     return CVf_METHOD;
  11.     else if (strnEQ(attr, "locked", 6))
  12.     return CVf_LOCKED;
  13.     else
  14.     return 0;
  15. }
  16.  
  17. MODULE = attrs        PACKAGE = attrs
  18.  
  19. void
  20. import(Class, ...)
  21. char *    Class
  22.     ALIAS:
  23.     unimport = 1
  24.     PREINIT:
  25.     int i;
  26.     CV *cv;
  27.     PPCODE:
  28.     if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
  29.         croak("can't set attributes outside a subroutine scope");
  30.     if (ckWARN(WARN_DEPRECATED))
  31.         Perl_warner(aTHX_ WARN_DEPRECATED,
  32.             "pragma \"attrs\" is deprecated, "
  33.             "use \"sub NAME : ATTRS\" instead");
  34.     for (i = 1; i < items; i++) {
  35.         STRLEN n_a;
  36.         char *attr = SvPV(ST(i), n_a);
  37.         cv_flags_t flag = get_flag(attr);
  38.         if (!flag)
  39.         croak("invalid attribute name %s", attr);
  40.         if (ix)
  41.             CvFLAGS(cv) &= ~flag;
  42.         else
  43.         CvFLAGS(cv) |= flag;
  44.     }
  45.  
  46. void
  47. get(sub)
  48. SV *    sub
  49.     PPCODE:
  50.     if (SvROK(sub)) {
  51.         sub = SvRV(sub);
  52.         if (SvTYPE(sub) != SVt_PVCV)
  53.         sub = Nullsv;
  54.     }
  55.     else {
  56.         STRLEN n_a;
  57.         char *name = SvPV(sub, n_a);
  58.         sub = (SV*)perl_get_cv(name, FALSE);
  59.     }
  60.     if (!sub)
  61.         croak("invalid subroutine reference or name");
  62.     if (CvFLAGS(sub) & CVf_METHOD)
  63.         XPUSHs(sv_2mortal(newSVpvn("method", 6)));
  64.     if (CvFLAGS(sub) & CVf_LOCKED)
  65.         XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
  66.  
  67.