API tests for pad_findmy_*()

[perl5.git] / ext / Tie-Hash-NamedCapture / NamedCapture.xs

#define PERL_NO_GET_CONTEXT     /* we want efficiency */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* These are tightly coupled to the RXapif_* flags defined in regexp.h  */
#define UNDEF_FATAL  0x80000
#define DISCARD      0x40000
#define EXPECT_SHIFT 24
#define ACTION_MASK  0x000FF

#define FETCH_ALIAS  (RXapif_FETCH  | (2 << EXPECT_SHIFT))
#define STORE_ALIAS  (RXapif_STORE  | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
#define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
#define CLEAR_ALIAS  (RXapif_CLEAR  | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
#define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
#define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))

static void
tie_it(pTHX_ const char name, UV flag, HV *const stash)
{
    GV *const gv = gv_fetchpvn(&name, 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PVHV);
    HV *const hv = GvHV(gv);
    SV *rv = newSV_type(SVt_RV);

    SvRV_set(rv, newSVuv(flag));
    SvROK_on(rv);
    sv_bless(rv, stash);

    sv_unmagic((SV *)hv, PERL_MAGIC_tied);
    sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
    SvREFCNT_dec(rv); /* As sv_magic increased it by one.  */
}

MODULE = Tie::Hash::NamedCapture	PACKAGE = Tie::Hash::NamedCapture
PROTOTYPES: DISABLE

BOOT:
	{
	    HV *const stash = GvSTASH(CvGV(cv));
	    tie_it(aTHX_ '-', RXapif_ALL, stash);
	    tie_it(aTHX_ '+', RXapif_ONE, stash);
	}

SV *
TIEHASH(package, ...)
	const char *package;
    PREINIT:
	UV flag = RXapif_ONE;
    CODE:
	mark += 2;
	while(mark < sp) {
	    STRLEN len;
	    const char *p = SvPV_const(*mark, len);
	    if(memEQs(p, len, "all"))
		flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
	    mark += 2;
	}
	RETVAL = newSV_type(SVt_RV);
	sv_setuv(newSVrv(RETVAL, package), flag);
    OUTPUT:
	RETVAL

void
FETCH(...)
    ALIAS:
	Tie::Hash::NamedCapture::FETCH  = FETCH_ALIAS
	Tie::Hash::NamedCapture::STORE  = STORE_ALIAS
	Tie::Hash::NamedCapture::DELETE = DELETE_ALIAS
	Tie::Hash::NamedCapture::CLEAR  = CLEAR_ALIAS
	Tie::Hash::NamedCapture::EXISTS = EXISTS_ALIAS
	Tie::Hash::NamedCapture::SCALAR = SCALAR_ALIAS
    PREINIT:
	REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
	U32 flags;
	SV *ret;
	const U32 action = ix & ACTION_MASK;
	const int expect = ix >> EXPECT_SHIFT;
    PPCODE:
	if (items != expect)
	    croak_xs_usage(cv, expect == 2 ? "$key"
				           : (expect == 3 ? "$key, $value"
							  : ""));

	if (!rx || !SvROK(ST(0))) {
	    if (ix & UNDEF_FATAL)
		Perl_croak_no_modify(aTHX);
	    else
		XSRETURN_UNDEF;
	}

	flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));

	PUTBACK;
	ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
				    expect >= 3 ? ST(2) : NULL, flags | action);
	SPAGAIN;

	if (ix & DISCARD) {
	    /* Called with G_DISCARD, so our return stack state is thrown away.
	       Hence if we were returned anything, free it immediately.  */
	    SvREFCNT_dec(ret);
	} else {
	    PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
	}

void
FIRSTKEY(...)
    ALIAS:
	Tie::Hash::NamedCapture::NEXTKEY = 1
    PREINIT:
	REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
	U32 flags;
	SV *ret;
	const int expect = ix ? 2 : 1;
	const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
    PPCODE:
	if (items != expect)
	    croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");

	if (!rx || !SvROK(ST(0)))
	    XSRETURN_UNDEF;

	flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));

	PUTBACK;
	ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
					     expect >= 2 ? ST(1) : NULL,
					     flags | action);
	SPAGAIN;

	PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);

void
flags(...)
    PPCODE:
	EXTEND(SP, 2);
	mPUSHu(RXapif_ONE);
	mPUSHu(RXapif_ALL);