diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/Tie-Hash-NamedCapture/NamedCapture.pm | 8 | ||||
| -rw-r--r-- | ext/Tie-Hash-NamedCapture/NamedCapture.xs | 134 | ||||
| -rw-r--r-- | t/op/magic.t | 10 | ||||
| -rw-r--r-- | universal.c | 214 | ||||
| -rw-r--r-- | vxs.inc | 2 |
6 files changed, 200 insertions, 169 deletions
@@ -4363,7 +4363,6 @@ ext/Sys-Hostname/Hostname.pm Sys::Hostname extension Perl module ext/Sys-Hostname/Hostname.xs Sys::Hostname extension external subroutines ext/Sys-Hostname/t/Hostname.t See if Sys::Hostname works ext/Tie-Hash-NamedCapture/NamedCapture.pm Implements %- and %+ behaviour -ext/Tie-Hash-NamedCapture/NamedCapture.xs Implements %- and %+ behaviour ext/Tie-Hash-NamedCapture/t/tiehash.t Tests TIEHASH ext/Tie-Memoize/lib/Tie/Memoize.pm Base class for memoized tied hashes ext/Tie-Memoize/t/Tie-Memoize.t Test for Tie::Memoize diff --git a/ext/Tie-Hash-NamedCapture/NamedCapture.pm b/ext/Tie-Hash-NamedCapture/NamedCapture.pm index fb505f70a9..95f355aa81 100644 --- a/ext/Tie-Hash-NamedCapture/NamedCapture.pm +++ b/ext/Tie-Hash-NamedCapture/NamedCapture.pm @@ -1,10 +1,7 @@ use strict; package Tie::Hash::NamedCapture; -our $VERSION = "0.11"; - -require XSLoader; -XSLoader::load(); # This returns true, which makes require happy. +our $VERSION = "0.13"; __END__ @@ -41,6 +38,9 @@ The keys of C<%->-like hashes correspond to all buffer names found in the regular expression; the keys of C<%+>-like hashes list only the names of buffers that have captured (and that are thus associated to defined values). +This implementation has been moved into the core executable, but you +can still load this module for backward compatibility. + =head1 SEE ALSO L<perlreapi>, L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">, diff --git a/ext/Tie-Hash-NamedCapture/NamedCapture.xs b/ext/Tie-Hash-NamedCapture/NamedCapture.xs deleted file mode 100644 index a607c10090..0000000000 --- a/ext/Tie-Hash-NamedCapture/NamedCapture.xs +++ /dev/null @@ -1,134 +0,0 @@ -#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)) - -MODULE = Tie::Hash::NamedCapture PACKAGE = Tie::Hash::NamedCapture -PROTOTYPES: DISABLE - -void -_tie_it(SV *sv) - INIT: - GV * const gv = (GV *)sv; - HV * const hv = GvHVn(gv); - SV *rv = newSV_type(SVt_RV); - const char *gv_name = GvNAME(gv); - CODE: - SvRV_set(rv, newSVuv( - strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL") - ? RXapif_ALL : RXapif_ONE)); - SvROK_on(rv); - sv_bless(rv, GvSTASH(CvGV(cv))); - - 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. */ - -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(); - 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); diff --git a/t/op/magic.t b/t/op/magic.t index 2a7a627d86..e0dfcf93a1 100644 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; require './test.pl'; set_up_inc( '../lib' ); - plan (tests => 195); # some tests are run in BEGIN block + plan (tests => 192); # some tests are run in BEGIN block } # Test that defined() returns true for magic variables created on the fly, @@ -483,8 +483,7 @@ SKIP: { } # Check that we don't auto-load packages -foreach (['powie::!', 'Errno'], - ['powie::+', 'Tie::Hash::NamedCapture']) { +foreach (['powie::!', 'Errno']) { my ($symbol, $package) = @$_; SKIP: { (my $extension = $package) =~ s|::|/|g; @@ -613,10 +612,9 @@ SKIP: { } SKIP: { - skip_if_miniperl("No XS in miniperl", 2); + skip_if_miniperl("No XS in miniperl", 1); - for ( [qw( %- Tie::Hash::NamedCapture )], - [qw( %! Errno )] ) { + for ( [qw( %! Errno )] ) { my ($var, $mod) = @$_; my $modfile = $mod =~ s|::|/|gr . ".pm"; fresh_perl_is diff --git a/universal.c b/universal.c index 34a63e894e..3658b9b8a1 100644 --- a/universal.c +++ b/universal.c @@ -1019,6 +1019,161 @@ XS(XS_Internals_getcwd) #endif +XS(XS_NamedCapture_tie_it) +{ + dXSARGS; + + if (items != 1) + croak_xs_usage(cv, "sv"); + { + SV *sv = ST(0); + GV * const gv = (GV *)sv; + HV * const hv = GvHVn(gv); + SV *rv = newSV_type(SVt_IV); + const char *gv_name = GvNAME(gv); + + SvRV_set(rv, newSVuv( + strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL") + ? RXapif_ALL : RXapif_ONE)); + SvROK_on(rv); + sv_bless(rv, GvSTASH(CvGV(cv))); + + 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. */ + } + XSRETURN_EMPTY; +} + +XS(XS_NamedCapture_TIEHASH) +{ + dVAR; dXSARGS; + if (items < 1) + croak_xs_usage(cv, "package, ..."); + { + const char * package = (const char *)SvPV_nolen(ST(0)); + UV flag = RXapif_ONE; + 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; + } + ST(0) = sv_2mortal(newSV_type(SVt_IV)); + sv_setuv(newSVrv(ST(0), package), flag); + } + XSRETURN(1); +} + +/* 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)) + +XS(XS_NamedCapture_FETCH) +{ + dVAR; dXSARGS; + dXSI32; + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + 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; + 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(); + 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); + } + PUTBACK; + return; + } +} + + +XS(XS_NamedCapture_FIRSTKEY) +{ + dVAR; dXSARGS; + dXSI32; + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + 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; + 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); + PUTBACK; + return; + } +} + +/* is this still needed? */ +XS(XS_NamedCapture_flags) +{ + dVAR; dXSARGS; + PERL_UNUSED_VAR(cv); /* -W */ + PERL_UNUSED_VAR(ax); /* -Wall */ + SP -= items; + { + EXTEND(SP, 2); + mPUSHu(RXapif_ONE); + mPUSHu(RXapif_ALL); + PUTBACK; + return; + } +} + #include "vutil.h" #include "vxs.inc" @@ -1026,36 +1181,48 @@ struct xsub_details { const char *name; XSUBADDR_t xsub; const char *proto; + int ix; }; static const struct xsub_details these_details[] = { - {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL}, - {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL}, - {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL}, + {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 }, + {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 }, + {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL, 0 }, #define VXS_XSUB_DETAILS #include "vxs.inc" #undef VXS_XSUB_DETAILS - {"utf8::is_utf8", XS_utf8_is_utf8, NULL}, - {"utf8::valid", XS_utf8_valid, NULL}, - {"utf8::encode", XS_utf8_encode, NULL}, - {"utf8::decode", XS_utf8_decode, NULL}, - {"utf8::upgrade", XS_utf8_upgrade, NULL}, - {"utf8::downgrade", XS_utf8_downgrade, NULL}, - {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL}, - {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL}, - {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"}, - {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"}, - {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"}, - {"constant::_make_const", XS_constant__make_const, "\\[$@]"}, - {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"}, - {"re::is_regexp", XS_re_is_regexp, "$"}, - {"re::regname", XS_re_regname, ";$$"}, - {"re::regnames", XS_re_regnames, ";$"}, - {"re::regnames_count", XS_re_regnames_count, ""}, - {"re::regexp_pattern", XS_re_regexp_pattern, "$"}, + {"utf8::is_utf8", XS_utf8_is_utf8, NULL, 0 }, + {"utf8::valid", XS_utf8_valid, NULL, 0 }, + {"utf8::encode", XS_utf8_encode, NULL, 0 }, + {"utf8::decode", XS_utf8_decode, NULL, 0 }, + {"utf8::upgrade", XS_utf8_upgrade, NULL, 0 }, + {"utf8::downgrade", XS_utf8_downgrade, NULL, 0 }, + {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL, 0 }, + {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL, 0 }, + {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$", 0 }, + {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$", 0 }, + {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%", 0 }, + {"constant::_make_const", XS_constant__make_const, "\\[$@]", 0 }, + {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@", 0 }, + {"re::is_regexp", XS_re_is_regexp, "$", 0 }, + {"re::regname", XS_re_regname, ";$$", 0 }, + {"re::regnames", XS_re_regnames, ";$", 0 }, + {"re::regnames_count", XS_re_regnames_count, "", 0 }, + {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 }, #ifdef HAS_GETCWD - {"Internals::getcwd", XS_Internals_getcwd, ""}, + {"Internals::getcwd", XS_Internals_getcwd, "", 0 }, #endif + {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 }, + {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 }, + {"Tie::Hash::NamedCapture::FETCH", XS_NamedCapture_FETCH, NULL, FETCH_ALIAS }, + {"Tie::Hash::NamedCapture::STORE", XS_NamedCapture_FETCH, NULL, STORE_ALIAS }, + {"Tie::Hash::NamedCapture::DELETE", XS_NamedCapture_FETCH, NULL, DELETE_ALIAS }, + {"Tie::Hash::NamedCapture::CLEAR", XS_NamedCapture_FETCH, NULL, CLEAR_ALIAS }, + {"Tie::Hash::NamedCapture::EXISTS", XS_NamedCapture_FETCH, NULL, EXISTS_ALIAS }, + {"Tie::Hash::NamedCapture::SCALAR", XS_NamedCapture_FETCH, NULL, SCALAR_ALIAS }, + {"Tie::Hash::NamedCapture::FIRSTKEY", XS_NamedCapture_FIRSTKEY, NULL, 0 }, + {"Tie::Hash::NamedCapture::NEXTKEY", XS_NamedCapture_FIRSTKEY, NULL, 1 }, + {"Tie::Hash::NamedCapture::flags", XS_NamedCapture_flags, NULL, 0 }, }; STATIC OP* @@ -1115,7 +1282,8 @@ Perl_boot_core_UNIVERSAL(pTHX) const struct xsub_details *end = C_ARRAY_END(these_details); do { - newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0); + CV *cv = newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0); + XSANY.any_i32 = xsub->ix; } while (++xsub < end); #ifndef EBCDIC @@ -5,7 +5,7 @@ # define VXS_CLASS "version" # define VXSp(name) XS_##name /* VXSXSDP = XSUB Details Proto */ -# define VXSXSDP(x) x +# define VXSXSDP(x) x, 0 #else # define VXS_CLASS "version::vxs" # define VXSp(name) VXS_##name |