ext/Tie-Hash-NamedCapture/NamedCapture.xs

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