ext/Tie-Hash-NamedCapture/NamedCapture.xs

   1 #define PERL_NO_GET_CONTEXT     /* we want efficiency */
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6 /* These are tightly coupled to the RXapif_* flags defined in regexp.h  */
   7 #define UNDEF_FATAL  0x80000
   8 #define DISCARD      0x40000
   9 #define EXPECT_SHIFT 24
  10 #define ACTION_MASK  0x000FF
  11
  12 #define FETCH_ALIAS  (RXapif_FETCH  | (2 << EXPECT_SHIFT))
  13 #define STORE_ALIAS  (RXapif_STORE  | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
  14 #define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
  15 #define CLEAR_ALIAS  (RXapif_CLEAR  | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
  16 #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
  17 #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
  18
  19 MODULE = Tie::Hash::NamedCapture        PACKAGE = Tie::Hash::NamedCapture
  20 PROTOTYPES: DISABLE
  21
  22 void
  23 _tie_it(SV *sv)
  24   INIT:
  25     GV * const gv = (GV *)sv;
  26     HV * const hv = GvHVn(gv);
  27     SV *rv = newSV_type(SVt_RV);
  28   CODE:
  29     SvRV_set(rv, newSVuv(*GvNAME(gv) == '-' ? RXapif_ALL : RXapif_ONE));
  30     SvROK_on(rv);
  31     sv_bless(rv, GvSTASH(CvGV(cv)));
  32
  33     sv_unmagic((SV *)hv, PERL_MAGIC_tied);
  34     sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
  35     SvREFCNT_dec(rv); /* As sv_magic increased it by one.  */
  36
  37 SV *
  38 TIEHASH(package, ...)
  39         const char *package;
  40     PREINIT:
  41         UV flag = RXapif_ONE;
  42     CODE:
  43         mark += 2;
  44         while(mark < sp) {
  45             STRLEN len;
  46             const char *p = SvPV_const(*mark, len);
  47             if(memEQs(p, len, "all"))
  48                 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
  49             mark += 2;
  50         }
  51         RETVAL = newSV_type(SVt_RV);
  52         sv_setuv(newSVrv(RETVAL, package), flag);
  53     OUTPUT:
  54         RETVAL
  55
  56 void
  57 FETCH(...)
  58     ALIAS:
  59         Tie::Hash::NamedCapture::FETCH  = FETCH_ALIAS
  60         Tie::Hash::NamedCapture::STORE  = STORE_ALIAS
  61         Tie::Hash::NamedCapture::DELETE = DELETE_ALIAS
  62         Tie::Hash::NamedCapture::CLEAR  = CLEAR_ALIAS
  63         Tie::Hash::NamedCapture::EXISTS = EXISTS_ALIAS
  64         Tie::Hash::NamedCapture::SCALAR = SCALAR_ALIAS
  65     PREINIT:
  66         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
  67         U32 flags;
  68         SV *ret;
  69         const U32 action = ix & ACTION_MASK;
  70         const int expect = ix >> EXPECT_SHIFT;
  71     PPCODE:
  72         if (items != expect)
  73             croak_xs_usage(cv, expect == 2 ? "$key"
  74                                            : (expect == 3 ? "$key, $value"
  75                                                           : ""));
  76
  77         if (!rx || !SvROK(ST(0))) {
  78             if (ix & UNDEF_FATAL)
  79                 Perl_croak_no_modify();
  80             else
  81                 XSRETURN_UNDEF;
  82         }
  83
  84         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
  85
  86         PUTBACK;
  87         ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
  88                                     expect >= 3 ? ST(2) : NULL, flags | action);
  89         SPAGAIN;
  90
  91         if (ix & DISCARD) {
  92             /* Called with G_DISCARD, so our return stack state is thrown away.
  93                Hence if we were returned anything, free it immediately.  */
  94             SvREFCNT_dec(ret);
  95         } else {
  96             PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
  97         }
  98
  99 void
 100 FIRSTKEY(...)
 101     ALIAS:
 102         Tie::Hash::NamedCapture::NEXTKEY = 1
 103     PREINIT:
 104         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 105         U32 flags;
 106         SV *ret;
 107         const int expect = ix ? 2 : 1;
 108         const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
 109     PPCODE:
 110         if (items != expect)
 111             croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
 112
 113         if (!rx || !SvROK(ST(0)))
 114             XSRETURN_UNDEF;
 115
 116         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
 117
 118         PUTBACK;
 119         ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
 120                                              expect >= 2 ? ST(1) : NULL,
 121                                              flags | action);
 122         SPAGAIN;
 123
 124         PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 125
 126 void
 127 flags(...)
 128     PPCODE:
 129         EXTEND(SP, 2);
 130         mPUSHu(RXapif_ONE);
 131         mPUSHu(RXapif_ALL);