This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add tests for documented behaviour of Tie::Hash::NamedCapture::TIEHASH.
[perl5.git] / ext / Tie-Hash-NamedCapture / NamedCapture.xs
CommitLineData
8cf6f931
NC
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
8dcfe2e9
NC
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
8cf6f931
NC
18MODULE = Tie::Hash::NamedCapture PACKAGE = Tie::Hash::NamedCapture
19PROTOTYPES: DISABLE
20
21void
8dcfe2e9
NC
22FETCH(...)
23 ALIAS:
24 Tie::Hash::NamedCapture::FETCH = FETCH_ALIAS
25 Tie::Hash::NamedCapture::STORE = STORE_ALIAS
26 Tie::Hash::NamedCapture::DELETE = DELETE_ALIAS
27 Tie::Hash::NamedCapture::CLEAR = CLEAR_ALIAS
28 Tie::Hash::NamedCapture::EXISTS = EXISTS_ALIAS
29 Tie::Hash::NamedCapture::SCALAR = SCALAR_ALIAS
30 PREINIT:
31 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
32 U32 flags;
33 SV *ret;
34 const U32 action = ix & ACTION_MASK;
35 const int expect = ix >> EXPECT_SHIFT;
36 PPCODE:
37 if (items != expect)
38 croak_xs_usage(cv, expect == 2 ? "$key"
39 : (expect == 3 ? "$key, $value"
40 : ""));
41
42 if (!rx || !SvROK(ST(0))) {
43 if (ix & UNDEF_FATAL)
44 Perl_croak_no_modify(aTHX);
45 else
46 XSRETURN_UNDEF;
47 }
48
49 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
50
51 PUTBACK;
52 ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
53 expect >= 3 ? ST(2) : NULL, flags | action);
54 SPAGAIN;
55
56 if (ix & DISCARD) {
57 /* Called with G_DISCARD, so our return stack state is thrown away.
58 Hence if we were returned anything, free it immediately. */
59 SvREFCNT_dec(ret);
60 } else {
61 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
62 }
63
64void
610f2345
NC
65FIRSTKEY(...)
66 ALIAS:
67 Tie::Hash::NamedCapture::NEXTKEY = 1
68 PREINIT:
69 REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
70 U32 flags;
71 SV *ret;
72 const int expect = ix ? 2 : 1;
73 const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
74 PPCODE:
75 if (items != expect)
76 croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
77
78 if (!rx || !SvROK(ST(0)))
79 XSRETURN_UNDEF;
80
81 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
82
83 PUTBACK;
84 ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
85 expect >= 2 ? ST(1) : NULL,
86 flags | action);
87 SPAGAIN;
88
89 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
90
91void
8cf6f931
NC
92flags(...)
93 PPCODE:
94 EXTEND(SP, 2);
95 mPUSHu(RXapif_ONE);
96 mPUSHu(RXapif_ALL);
97