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