In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8dcfe2e99a72fe7951b4d15325e1541232823204?hp=939767c9d84f9288c260508432b50879f71e1d3b>
- Log ----------------------------------------------------------------- commit 8dcfe2e99a72fe7951b4d15325e1541232823204 Author: Nicholas Clark <[email protected]> Date: Thu Oct 14 15:34:03 2010 +0100 Move remaining Tie::Hash::NamedCapture XS code to NamedCapture.xs Now all the support code for %+ and %- is contained in the module in ext/ M ext/Tie-Hash-NamedCapture/NamedCapture.xs M universal.c commit 610f23459d57294735f494ba0a95e50f62231358 Author: Nicholas Clark <[email protected]> Date: Thu Oct 14 14:09:15 2010 +0100 Move Tie::Hash::NamedCapture::{FIRST,NEXT}KEY to NamedCapture.xs M ext/Tie-Hash-NamedCapture/NamedCapture.xs M universal.c commit 8cf6f931c54936a38eedd3d17d5fa1d5af1b9009 Author: Nicholas Clark <[email protected]> Date: Thu Oct 14 13:29:22 2010 +0100 Convert lib/Tie/Hash/NamedCapture.pm to an XS module in ext/ Initially move only Tie::Hash::NamedCapture::flags from universal.c to it. M MANIFEST M Makefile.SH M Porting/Maintainers.pl A ext/Tie-Hash-NamedCapture/NamedCapture.pm A ext/Tie-Hash-NamedCapture/NamedCapture.xs D lib/Tie/Hash/NamedCapture.pm M universal.c M win32/Makefile M win32/makefile.mk commit 17b8ae88c658cb5fe05998ab824e6c02cfba7dcd Author: Nicholas Clark <[email protected]> Date: Thu Oct 14 11:41:50 2010 +0100 Merge XS_Tie_Hash_NamedCapture_{FIRSTK,NEXTK} into S_named_capture_iter_common. M universal.c commit 451eed4a967ae47c4702ea000f3a547dc3d7267b Author: Nicholas Clark <[email protected]> Date: Thu Oct 14 11:17:35 2010 +0100 Merge XS_Tie_Hash_NamedCapture_STORE into S_named_capture_common. M universal.c commit 7f35162bf94f4c6c0cf4778e9f03e480f68a9da2 Author: Nicholas Clark <[email protected]> Date: Thu Oct 14 11:04:51 2010 +0100 Merge XS_Tie_Hash_NamedCapture_CLEAR into S_named_capture_common. M universal.c commit 1ee8edd0f0d0f301e1084aca5f8a9a83c483d072 Author: Nicholas Clark <[email protected]> Date: Thu Oct 14 10:44:15 2010 +0100 Merge XS_Tie_Hash_NamedCapture_DELETE into S_named_capture_common. M universal.c commit 015db559459b868f19c1cf27c13a231443eab9b7 Author: Nicholas Clark <[email protected]> Date: Thu Oct 14 10:24:45 2010 +0100 Merge XS_Tie_Hash_NamedCapture_SCALAR into S_named_capture_common. M universal.c commit 606c5d14753b06846c2cc98166e8bc2dc8cb27fd Author: Nicholas Clark <[email protected]> Date: Thu Oct 14 10:08:08 2010 +0100 Merge XS_Tie_Hash_NamedCapture_{FETCH,EXISTS} into S_named_capture_common. M universal.c commit 0bbbe6948c4d46b5eafef01c918d2aea8e16681a Author: Nicholas Clark <[email protected]> Date: Thu Oct 14 09:47:57 2010 +0100 Expand CALLREG_NAMED_BUFF* macros in XS_Tie_Hash_NamedCapture_* This reveals even more similarity between the routines' bodies. M universal.c ----------------------------------------------------------------------- Summary of changes: MANIFEST | 3 +- Makefile.SH | 2 +- Porting/Maintainers.pl | 1 + .../Tie-Hash-NamedCapture}/NamedCapture.pm | 8 +- ext/Tie-Hash-NamedCapture/NamedCapture.xs | 97 ++++++++ universal.c | 245 -------------------- win32/Makefile | 1 + win32/makefile.mk | 1 + 8 files changed, 107 insertions(+), 251 deletions(-) rename {lib/Tie/Hash => ext/Tie-Hash-NamedCapture}/NamedCapture.pm (88%) create mode 100644 ext/Tie-Hash-NamedCapture/NamedCapture.xs diff --git a/MANIFEST b/MANIFEST index 3dda418..58c85ca 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3342,6 +3342,8 @@ ext/Socket/t/Socket.t See if Socket works 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-Memoize/lib/Tie/Memoize.pm Base class for memoized tied hashes ext/Tie-Memoize/t/Tie-Memoize.t Test for Tie::Memoize ext/Time-Local/lib/Time/Local.pm Reverse translation of localtime, gmtime @@ -3744,7 +3746,6 @@ lib/Tie/ExtraHash.t Test for Tie::ExtraHash (in Tie/Hash.pm) lib/Tie/Handle.pm Base class for tied handles lib/Tie/Handle/stdhandle_from_handle.t Test for Tie::StdHandle/Handle backwards compat lib/Tie/Handle/stdhandle.t Test for Tie::StdHandle -lib/Tie/Hash/NamedCapture.pm Implements %- and %+ behaviour lib/Tie/Hash.pm Base class for tied hashes lib/Tie/Hash.t See if Tie::Hash works lib/Tie/Scalar.pm Base class for tied scalars diff --git a/Makefile.SH b/Makefile.SH index 6559583..998a6ee 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -1315,7 +1315,7 @@ _cleaner2: -rmdir lib/Package lib/Params -rmdir lib/Pod/Perldoc lib/Pod/Simple lib/Pod/Text -rmdir lib/Sys lib/Scalar/Util lib/Scalar - -rmdir lib/Term/UI lib/Thread + -rmdir lib/Term/UI lib/Thread lib/Tie/Hash -rmdir lib/Test/Builder/Tester lib/Test/Builder lib/Test -rmdir lib/Unicode/Collate -rmdir lib/XS/APItest lib/XS diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 9fe49e5..5d87de2 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1676,6 +1676,7 @@ use File::Glob qw(:case); ext/SDBM_File/ ext/Socket/ ext/Sys-Hostname/ + ext/Tie-Hash-NamedCapture/ ext/Tie-Memoize/ ext/XS-APItest/ ext/XS-Typemap/ diff --git a/lib/Tie/Hash/NamedCapture.pm b/ext/Tie-Hash-NamedCapture/NamedCapture.pm similarity index 88% rename from lib/Tie/Hash/NamedCapture.pm rename to ext/Tie-Hash-NamedCapture/NamedCapture.pm index 58ae743..065d68d 100644 --- a/lib/Tie/Hash/NamedCapture.pm +++ b/ext/Tie-Hash-NamedCapture/NamedCapture.pm @@ -1,10 +1,10 @@ +use strict; package Tie::Hash::NamedCapture; -our $VERSION = "0.06"; +our $VERSION = "0.07"; -# The real meat implemented in XS in universal.c in the core, but this -# method was left behind because gv.c expects a Purl-Perl method in -# this package when it loads the tie magic for %+ and %- +require XSLoader; +XSLoader::load(__PACKAGE__); my ($one, $all) = Tie::Hash::NamedCapture::flags(); diff --git a/ext/Tie-Hash-NamedCapture/NamedCapture.xs b/ext/Tie-Hash-NamedCapture/NamedCapture.xs new file mode 100644 index 0000000..cd96c82 --- /dev/null +++ b/ext/Tie-Hash-NamedCapture/NamedCapture.xs @@ -0,0 +1,97 @@ +#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 +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); + diff --git a/universal.c b/universal.c index 52d701c..73910ea 100644 --- a/universal.c +++ b/universal.c @@ -1254,242 +1254,6 @@ XS(XS_re_regexp_pattern) /* NOT-REACHED */ } -XS(XS_Tie_Hash_NamedCapture_FETCH) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV * ret; - - if (items != 2) - croak_xs_usage(cv, "$key"); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) - XSRETURN_UNDEF; - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags); - - SPAGAIN; - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - XSRETURN(1); -} - -XS(XS_Tie_Hash_NamedCapture_STORE) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV *ret; - - if (items != 3) - croak_xs_usage(cv, "$key, $value"); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) { - Perl_croak_no_modify(aTHX); - } - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags); - - - /* Perl_magic_setpack calls us with G_DISCARD, so our return stack state - is thrown away. */ - - /* If we were returned anything, free it immediately. */ - SvREFCNT_dec(ret); - XSRETURN_EMPTY; -} - -XS(XS_Tie_Hash_NamedCapture_DELETE) -{ - dVAR; - dXSARGS; - REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - U32 flags; - SV *ret; - - if (items != 2) - croak_xs_usage(cv, "$key"); - - if (!rx || !SvROK(ST(0))) - Perl_croak_no_modify(aTHX); - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags); - - SPAGAIN; - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - XSRETURN(1); -} - -XS(XS_Tie_Hash_NamedCapture_CLEAR) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV *ret; - - if (items != 1) - croak_xs_usage(cv, ""); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) - Perl_croak_no_modify(aTHX); - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = CALLREG_NAMED_BUFF_CLEAR(rx, flags); - - /* Perl_magic_wipepack calls us with G_DISCARD, so our return stack state - is thrown away. */ - - /* If we were returned anything, free it immediately. */ - SvREFCNT_dec(ret); - XSRETURN_EMPTY; -} - -XS(XS_Tie_Hash_NamedCapture_EXISTS) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV * ret; - - if (items != 2) - croak_xs_usage(cv, "$key"); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) - XSRETURN_UNDEF; - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags); - - SPAGAIN; - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - XSRETURN(1); -} - -XS(XS_Tie_Hash_NamedCapture_FIRSTK) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV * ret; - - if (items != 1) - croak_xs_usage(cv, ""); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) - XSRETURN_UNDEF; - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags); - - SPAGAIN; - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - XSRETURN(1); -} - -XS(XS_Tie_Hash_NamedCapture_NEXTK) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV * ret; - - if (items != 2) - croak_xs_usage(cv, "$lastkey"); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) - XSRETURN_UNDEF; - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags); - - SPAGAIN; - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - XSRETURN(1); -} - -XS(XS_Tie_Hash_NamedCapture_SCALAR) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV * ret; - - if (items != 1) - croak_xs_usage(cv, ""); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) - XSRETURN_UNDEF; - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags); - - SPAGAIN; - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - XSRETURN(1); -} - -XS(XS_Tie_Hash_NamedCapture_flags) -{ - dVAR; - dXSARGS; - - if (items != 0) - croak_xs_usage(cv, ""); - - mXPUSHu(RXapif_ONE); - mXPUSHu(RXapif_ALL); - PUTBACK; - return; -} - struct xsub_details { const char *name; XSUBADDR_t xsub; @@ -1540,15 +1304,6 @@ struct xsub_details details[] = { {"re::regnames", XS_re_regnames, ";$"}, {"re::regnames_count", XS_re_regnames_count, ""}, {"re::regexp_pattern", XS_re_regexp_pattern, "$"}, - {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL}, - {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL}, - {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL}, - {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL}, - {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL}, - {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL}, - {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL}, - {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL}, - {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL} }; void diff --git a/win32/Makefile b/win32/Makefile index 9816d56..9e8f630 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -1180,6 +1180,7 @@ distclean: realclean -if exist $(LIBDIR)\Test rmdir /s /q $(LIBDIR)\Test -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread -if exist $(LIBDIR)\threads rmdir /s /q $(LIBDIR)\threads + -if exist $(LIBDIR)\Tie\Hash rmdir /s /q $(LIBDIR)\Tie\Hash -if exist $(LIBDIR)\Unicode\Collate rmdir /s /q $(LIBDIR)\Unicode\Collate -if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS -if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API diff --git a/win32/makefile.mk b/win32/makefile.mk index bbba91e..d8a188d 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -1544,6 +1544,7 @@ distclean: realclean -if exist $(LIBDIR)\Test rmdir /s /q $(LIBDIR)\Test -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread -if exist $(LIBDIR)\threads rmdir /s /q $(LIBDIR)\threads + -if exist $(LIBDIR)\Tie\Hash rmdir /s /q $(LIBDIR)\Tie\Hash -if exist $(LIBDIR)\Unicode\Collate rmdir /s /q $(LIBDIR)\Unicode\Collate -if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS -if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API -- Perl5 Master Repository
