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(const 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     PPCODE:
  26        if (items < 1)
  27            Perl_croak(aTHX_ "Usage: %s(Class, ...)", GvNAME(CvGV(cv)));
  28         if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
  29             croak("can't set attributes outside a subroutine scope");
  30         if (ckWARN(WARN_DEPRECATED))
  31             Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
  32                         "pragma \"attrs\" is deprecated, "
  33                         "use \"sub NAME : ATTRS\" instead");
  34         for (i = 1; i < items; i++) {
  35             const char * const attr = SvPV_nolen(ST(i));
  36             const cv_flags_t flag = get_flag(attr);
  37             if (!flag)
  38                 croak("invalid attribute name %s", attr);
  39             if (ix)
  40                 CvFLAGS(cv) &= ~flag;
  41             else
  42                 CvFLAGS(cv) |= flag;
  43         }
  44
  45 void
  46 get(sub)
  47 SV *    sub
  48     PPCODE:
  49         if (SvROK(sub)) {
  50             sub = SvRV(sub);
  51             if (SvTYPE(sub) != SVt_PVCV)
  52                 sub = Nullsv;
  53         }
  54         else {
  55             const char * const name = SvPV_nolen(sub);
  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