ext/attrs/attrs.xs

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