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 if (strnEQ(attr, "lvalue", 6))
  14         return CVf_LVALUE;
  15     else
  16         return 0;
  17 }
  18
  19 MODULE = attrs          PACKAGE = attrs
  20
  21 void
  22 import(Class, ...)
  23 char *  Class
  24     ALIAS:
  25         unimport = 1
  26     PREINIT:
  27         int i;
  28         CV *cv;
  29     PPCODE:
  30         if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
  31             croak("can't set attributes outside a subroutine scope");
  32         for (i = 1; i < items; i++) {
  33             STRLEN n_a;
  34             char *attr = SvPV(ST(i), n_a);
  35             cv_flags_t flag = get_flag(attr);
  36             if (!flag)
  37                 croak("invalid attribute name %s", attr);
  38             if (ix)
  39                 CvFLAGS(cv) &= ~flag;
  40             else
  41                 CvFLAGS(cv) |= flag;
  42         }
  43
  44 void
  45 get(sub)
  46 SV *    sub
  47     PPCODE:
  48         if (SvROK(sub)) {
  49             sub = SvRV(sub);
  50             if (SvTYPE(sub) != SVt_PVCV)
  51                 sub = Nullsv;
  52         }
  53         else {
  54             STRLEN n_a;
  55             char *name = SvPV(sub, n_a);
  56             sub = (SV*)perl_get_cv(name, FALSE);
  57         }
  58         if (!sub)
  59             croak("invalid subroutine reference or name");
  60         if (CvFLAGS(sub) & CVf_METHOD)
  61             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
  62         if (CvFLAGS(sub) & CVf_LOCKED)
  63             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
  64