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(...)
  21     ALIAS:
  22         unimport = 1
  23     PREINIT:
  24         int i;
  25         CV *cv;
  26     PPCODE:
  27        if (items < 1)
  28            Perl_croak(aTHX_ "Usage: %s(Class, ...)", GvNAME(CvGV(cv)));
  29         if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
  30             croak("can't set attributes outside a subroutine scope");
  31         if (ckWARN(WARN_DEPRECATED))
  32             Perl_warner(aTHX_ WARN_DEPRECATED,
  33                         "pragma \"attrs\" is deprecated, "
  34                         "use \"sub NAME : ATTRS\" instead");
  35         for (i = 1; i < items; i++) {
  36             STRLEN n_a;
  37             char *attr = SvPV(ST(i), n_a);
  38             cv_flags_t flag = get_flag(attr);
  39             if (!flag)
  40                 croak("invalid attribute name %s", attr);
  41             if (ix)
  42                 CvFLAGS(cv) &= ~flag;
  43             else
  44                 CvFLAGS(cv) |= flag;
  45         }
  46
  47 void
  48 get(sub)
  49 SV *    sub
  50     PPCODE:
  51         if (SvROK(sub)) {
  52             sub = SvRV(sub);
  53             if (SvTYPE(sub) != SVt_PVCV)
  54                 sub = Nullsv;
  55         }
  56         else {
  57             STRLEN n_a;
  58             char *name = SvPV(sub, n_a);
  59             sub = (SV*)perl_get_cv(name, FALSE);
  60         }
  61         if (!sub)
  62             croak("invalid subroutine reference or name");
  63         if (CvFLAGS(sub) & CVf_METHOD)
  64             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
  65         if (CvFLAGS(sub) & CVf_LOCKED)
  66             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
  67