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 static void
  20 tie_it(pTHX_ const char name, UV flag, HV *const stash)
  21 {
  22     GV *const gv = gv_fetchpvn(&name, 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PVHV);
  23     HV *const hv = GvHV(gv);
  24     SV *rv = newSV_type(SVt_RV);
  25
  26     SvRV_set(rv, newSVuv(flag));
  27     SvROK_on(rv);
  28     sv_bless(rv, stash);
  29
  30     sv_unmagic((SV *)hv, PERL_MAGIC_tied);
  31     sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
  32     SvREFCNT_dec(rv); /* As sv_magic increased it by one.  */
  33 }
  34
  35 MODULE = Tie::Hash::NamedCapture        PACKAGE = Tie::Hash::NamedCapture
  36 PROTOTYPES: DISABLE
  37
  38 BOOT:
  39         {
  40             HV *const stash = GvSTASH(CvGV(cv));
  41             tie_it(aTHX_ '-', RXapif_ALL, stash);
  42             tie_it(aTHX_ '+', RXapif_ONE, stash);
  43         }
  44
  45 SV *
  46 TIEHASH(package, ...)
  47         const char *package;
  48     PREINIT:
  49         UV flag = RXapif_ONE;
  50     CODE:
  51         mark += 2;
  52         while(mark < sp) {
  53             STRLEN len;
  54             const char *p = SvPV_const(*mark, len);
  55             if(memEQs(p, len, "all"))
  56                 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
  57             mark += 2;
  58         }
  59         RETVAL = newSV_type(SVt_RV);
  60         sv_setuv(newSVrv(RETVAL, package), flag);
  61     OUTPUT:
  62         RETVAL
  63
  64 void
  65 FETCH(...)
  66     ALIAS:
  67         Tie::Hash::NamedCapture::FETCH  = FETCH_ALIAS
  68         Tie::Hash::NamedCapture::STORE  = STORE_ALIAS
  69         Tie::Hash::NamedCapture::DELETE = DELETE_ALIAS
  70         Tie::Hash::NamedCapture::CLEAR  = CLEAR_ALIAS
  71         Tie::Hash::NamedCapture::EXISTS = EXISTS_ALIAS
  72         Tie::Hash::NamedCapture::SCALAR = SCALAR_ALIAS
  73     PREINIT:
  74         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
  75         U32 flags;
  76         SV *ret;
  77         const U32 action = ix & ACTION_MASK;
  78         const int expect = ix >> EXPECT_SHIFT;
  79     PPCODE:
  80         if (items != expect)
  81             croak_xs_usage(cv, expect == 2 ? "$key"
  82                                            : (expect == 3 ? "$key, $value"
  83                                                           : ""));
  84
  85         if (!rx || !SvROK(ST(0))) {
  86             if (ix & UNDEF_FATAL)
  87                 Perl_croak_no_modify(aTHX);
  88             else
  89                 XSRETURN_UNDEF;
  90         }
  91
  92         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
  93
  94         PUTBACK;
  95         ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
  96                                     expect >= 3 ? ST(2) : NULL, flags | action);
  97         SPAGAIN;
  98
  99         if (ix & DISCARD) {
 100             /* Called with G_DISCARD, so our return stack state is thrown away.
 101                Hence if we were returned anything, free it immediately.  */
 102             SvREFCNT_dec(ret);
 103         } else {
 104             PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 105         }
 106
 107 void
 108 FIRSTKEY(...)
 109     ALIAS:
 110         Tie::Hash::NamedCapture::NEXTKEY = 1
 111     PREINIT:
 112         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 113         U32 flags;
 114         SV *ret;
 115         const int expect = ix ? 2 : 1;
 116         const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
 117     PPCODE:
 118         if (items != expect)
 119             croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
 120
 121         if (!rx || !SvROK(ST(0)))
 122             XSRETURN_UNDEF;
 123
 124         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
 125
 126         PUTBACK;
 127         ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
 128                                              expect >= 2 ? ST(1) : NULL,
 129                                              flags | action);
 130         SPAGAIN;
 131
 132         PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 133
 134 void
 135 flags(...)
 136     PPCODE:
 137         EXTEND(SP, 2);
 138         mPUSHu(RXapif_ONE);
 139         mPUSHu(RXapif_ALL);