ext/attrs/attrs.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 static cv_flags_t
   6 get_flag(char *attr)
   7 {
   8     if (strnEQ(attr, "method", 6))
   9         return CVf_METHOD;
  10     else if (strnEQ(attr, "locked", 6))
  11         return CVf_LOCKED;
  12     else
  13         return 0;
  14 }
  15
  16 MODULE = attrs          PACKAGE = attrs
  17
  18 void
  19 import(Class, ...)
  20 char *  Class
  21     ALIAS:
  22         unimport = 1
  23     PREINIT:
  24         int i;
  25         CV *cv;
  26     PPCODE:
  27         if (!compcv || !(cv = CvOUTSIDE(compcv)))
  28             croak("can't set attributes outside a subroutine scope");
  29         for (i = 1; i < items; i++) {
  30             char *attr = SvPV(ST(i), na);
  31             cv_flags_t flag = get_flag(attr);
  32             if (!flag)
  33                 croak("invalid attribute name %s", attr);
  34             if (ix)
  35                 CvFLAGS(cv) &= ~flag;
  36             else
  37                 CvFLAGS(cv) |= flag;
  38         }
  39
  40 void
  41 get(sub)
  42 SV *    sub
  43     PPCODE:
  44         if (SvROK(sub)) {
  45             sub = SvRV(sub);
  46             if (SvTYPE(sub) != SVt_PVCV)
  47                 sub = Nullsv;
  48         }
  49         else {
  50             char *name = SvPV(sub, na);
  51             sub = (SV*)perl_get_cv(name, FALSE);
  52         }
  53         if (!sub)
  54             croak("invalid subroutine reference or name");
  55         if (CvFLAGS(sub) & CVf_METHOD)
  56             XPUSHs(sv_2mortal(newSVpv("method", 0)));
  57         if (CvFLAGS(sub) & CVf_LOCKED)
  58             XPUSHs(sv_2mortal(newSVpv("locked", 0)));
  59