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(attr)
   7 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 (!compcv || !(cv = CvOUTSIDE(compcv)))
  29             croak("can't set attributes outside a subroutine scope");
  30         for (i = 1; i < items; i++) {
  31             char *attr = SvPV(ST(i), na);
  32             cv_flags_t flag = get_flag(attr);
  33             if (!flag)
  34                 croak("invalid attribute name %s", attr);
  35             if (ix)
  36                 CvFLAGS(cv) &= ~flag;
  37             else
  38                 CvFLAGS(cv) |= flag;
  39         }
  40
  41 void
  42 get(sub)
  43 SV *    sub
  44     PPCODE:
  45         if (SvROK(sub)) {
  46             sub = SvRV(sub);
  47             if (SvTYPE(sub) != SVt_PVCV)
  48                 sub = Nullsv;
  49         }
  50         else {
  51             char *name = SvPV(sub, na);
  52             sub = (SV*)perl_get_cv(name, FALSE);
  53         }
  54         if (!sub)
  55             croak("invalid subroutine reference or name");
  56         if (CvFLAGS(sub) & CVf_METHOD)
  57             XPUSHs(sv_2mortal(newSVpv("method", 0)));
  58         if (CvFLAGS(sub) & CVf_LOCKED)
  59             XPUSHs(sv_2mortal(newSVpv("locked", 0)));
  60