contrib/perl5/ext/attrs/attrs.xs

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