In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/da2480689f7c62990cb3d865f1124dc5c8233570?hp=e1c60bf347fcb74764d4f3baf79980d3252ccf0a>
- Log ----------------------------------------------------------------- commit da2480689f7c62990cb3d865f1124dc5c8233570 Merge: e1c60bf fba4246 Author: Nicholas Clark <[email protected]> Date: Mon Sep 2 16:04:18 2013 +0200 Merge the changes to the internals of match variables. commit fba42467ad6404c8bb7cdd0b87b79b06bbecb992 Author: Nicholas Clark <[email protected]> Date: Thu Aug 29 13:12:00 2013 +0200 Add a perldelta entry for the changes to the internals of match variables. M pod/perldelta.pod commit a6d0b1b5649bdf84d12254d7a26b63f017ff0243 Author: Nicholas Clark <[email protected]> Date: Thu Aug 29 12:56:27 2013 +0200 Simplify some code in Perl_magic_get() and Perl_magic_set(). Remove the checks that avoided confusing $^P, ${^PREMATCH} and ${^POSTMATCH} now that the latter two do not take that code path. Remove a similar check for $^S added by commit 4ffa73a366885f68 (Feb 2003). (This commit did not add any other variable starting with a control-S.) This eliminates all uses of the variable remaining. Move the goto target do_numbuf_fetch inside the checks for PL_curpm, as both its comefroms have already made the same check. M mg.c commit c6e60aa38c276fbef88f69f2933902fcd2d21ebd Author: Nicholas Clark <[email protected]> Date: Thu Aug 29 12:33:46 2013 +0200 Remove now unused $` $' ${^MATCH} ${^PREMATCH} ${^POSTMATCH} code. The previous commit's changes to Perl_gv_fetchpvn_flags() rendered this code in Perl_magic_get() and Perl_magic_set() unreachable. M mg.c commit 960b831ff120c543264734d4a83b1eef6da166a7 Author: Nicholas Clark <[email protected]> Date: Thu Aug 29 12:16:11 2013 +0200 Store all other match vars in mg_len instead of mg_ptr/mg_len. Perl_gv_fetchpvn_flags() now stores the appropriate RX_BUFF_IDX_* constant in mg_len for $` $' ${^MATCH} ${^PREMATCH} and ${^POSTMATCH} This makes some code in mg.c unreachable and hence unnecessary; the next commit will remove it. M gv.c M mg.c commit e91d825996027800803ecf00fccacdcb821d3295 Author: Nicholas Clark <[email protected]> Date: Wed Aug 28 22:00:54 2013 +0200 Store the match vars in mg_len instead of calling atoi() on mg_ptr. The match variables $1, $2 etc, along with many other special scalars, have magic type PERL_MAGIC_sv, with the variable's name stored in mg_ptr. The look up in mg.c involved calling atoi() on the string in mg_ptr to get the capture buffer as an integer, which is passed to the regex API. To avoid this repeated use of atoi() at runtime, change the storage in the MAGIC structure for $1, $2 etc and $&. Set mg_ptr to NULL, and store the capture buffer in mg_len. Other code which manipulates magic ignores mg_len if mg_ptr is NULL, so this representation does not require changes outside of the routines which set up, read and write these variables. (Perl_gv_fetchpvn_flags(), Perl_magic_get() and Perl_magic_set()) M gv.c M mg.c ----------------------------------------------------------------------- Summary of changes: gv.c | 53 +++++++++++++++++++++++--------- mg.c | 92 ++++++++++++++----------------------------------------- pod/perldelta.pod | 6 +++- 3 files changed, 66 insertions(+), 85 deletions(-) diff --git a/gv.c b/gv.c index d6edbfd..5456b25 100644 --- a/gv.c +++ b/gv.c @@ -1419,6 +1419,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; U32 faking_it; + SSize_t paren; PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; @@ -1827,16 +1828,24 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, goto ro_magicalize; break; case '\015': /* $^MATCH */ - if (strEQ(name2, "ATCH")) - goto magicalize; + if (strEQ(name2, "ATCH")) { + paren = RX_BUFF_IDX_CARET_FULLMATCH; + goto storeparen; + } break; case '\017': /* $^OPEN */ if (strEQ(name2, "PEN")) goto magicalize; break; case '\020': /* $^PREMATCH $^POSTMATCH */ - if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) - goto magicalize; + if (strEQ(name2, "REMATCH")) { + paren = RX_BUFF_IDX_CARET_PREMATCH; + goto storeparen; + } + if (strEQ(name2, "OSTMATCH")) { + paren = RX_BUFF_IDX_CARET_POSTMATCH; + goto storeparen; + } break; case '\024': /* ${^TAINT} */ if (strEQ(name2, "AINT")) @@ -1871,7 +1880,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, while (--end > name) { if (!isDIGIT(*end)) goto add_magical_gv; } - goto magicalize; + paren = strtoul(name, NULL, 10); + goto storeparen; } } } @@ -1880,8 +1890,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, be case '\0' in this switch statement (ie a default case) */ switch (*name) { case '&': /* $& */ + paren = RX_BUFF_IDX_FULLMATCH; + goto sawampersand; case '`': /* $` */ + paren = RX_BUFF_IDX_PREMATCH; + goto sawampersand; case '\'': /* $' */ + paren = RX_BUFF_IDX_POSTMATCH; + sawampersand: #ifdef PERL_SAWAMPERSAND if (!( sv_type == SVt_PVAV || @@ -1897,7 +1913,23 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, : SAWAMPERSAND_RIGHT; } #endif - goto magicalize; + goto storeparen; + case '1': /* $1 */ + case '2': /* $2 */ + case '3': /* $3 */ + case '4': /* $4 */ + case '5': /* $5 */ + case '6': /* $6 */ + case '7': /* $7 */ + case '8': /* $8 */ + case '9': /* $9 */ + paren = *name - '0'; + + storeparen: + /* Flag the capture variables with a NULL mg_ptr + Use mg_len for the array index to lookup. */ + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren); + break; case ':': /* $: */ sv_setpv(GvSVn(gv),PL_chopset); @@ -1973,15 +2005,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, SvREADONLY_on(GvSVn(gv)); /* FALL THROUGH */ case '0': /* $0 */ - case '1': /* $1 */ - case '2': /* $2 */ - case '3': /* $3 */ - case '4': /* $4 */ - case '5': /* $5 */ - case '6': /* $6 */ - case '7': /* $7 */ - case '8': /* $8 */ - case '9': /* $9 */ case '^': /* $^ */ case '~': /* $~ */ case '=': /* $= */ diff --git a/mg.c b/mg.c index f70a5e9..d0fbd47 100644 --- a/mg.c +++ b/mg.c @@ -752,10 +752,22 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) const char *s = NULL; REGEXP *rx; const char * const remaining = mg->mg_ptr + 1; - const char nextchar = *remaining; + char nextchar; PERL_ARGS_ASSERT_MAGIC_GET; + if (!mg->mg_ptr) { + paren = mg->mg_len; + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + do_numbuf_fetch: + CALLREG_NUMBUF_FETCH(rx,paren,sv); + } else { + sv_setsv(sv,&PL_sv_undef); + } + return 0; + } + + nextchar = *remaining; switch (*mg->mg_ptr) { case '\001': /* ^A */ if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); @@ -864,19 +876,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '\020': - if (nextchar == '\0') { /* ^P */ - sv_setiv(sv, (IV)PL_perldb); - } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */ - - paren = RX_BUFF_IDX_CARET_PREMATCH; - goto do_numbuf_fetch; - } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */ - paren = RX_BUFF_IDX_CARET_POSTMATCH; - goto do_numbuf_fetch; - } + sv_setiv(sv, (IV)PL_perldb); break; case '\023': /* ^S */ - if (nextchar == '\0') { + { if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING) SvOK_off(sv); else if (PL_in_eval) @@ -933,26 +936,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } } break; - case '\015': /* $^MATCH */ - if (strEQ(remaining, "ATCH")) { - paren = RX_BUFF_IDX_CARET_FULLMATCH; - goto do_numbuf_fetch; - } - - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': case '&': - /* - * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj)); - * XXX Does the new way break anything? - */ - paren = atoi(mg->mg_ptr); /* $& is in [0] */ - do_numbuf_fetch: - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - CALLREG_NUMBUF_FETCH(rx,paren,sv); - break; - } - sv_setsv(sv,&PL_sv_undef); - break; case '+': if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { paren = RX_LASTPAREN(rx); @@ -969,12 +952,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } sv_setsv(sv,&PL_sv_undef); break; - case '`': - paren = RX_BUFF_IDX_PREMATCH; - goto do_numbuf_fetch; - case '\'': - paren = RX_BUFF_IDX_POSTMATCH; - goto do_numbuf_fetch; case '.': if (GvIO(PL_last_in_gv)) { sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); @@ -2489,46 +2466,30 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) const char *s; I32 paren; const REGEXP * rx; - const char * const remaining = mg->mg_ptr + 1; I32 i; STRLEN len; MAGIC *tmg; PERL_ARGS_ASSERT_MAGIC_SET; - switch (*mg->mg_ptr) { - case '\015': /* $^MATCH */ - if (strEQ(remaining, "ATCH")) - goto do_match; - case '`': /* ${^PREMATCH} caught below */ - do_prematch: - paren = RX_BUFF_IDX_PREMATCH; - goto setparen; - case '\'': /* ${^POSTMATCH} caught below */ - do_postmatch: - paren = RX_BUFF_IDX_POSTMATCH; - goto setparen; - case '&': - do_match: - paren = RX_BUFF_IDX_FULLMATCH; - goto setparen; - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - paren = atoi(mg->mg_ptr); - setparen: + if (!mg->mg_ptr) { + paren = mg->mg_len; if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - setparen_got_rx: + setparen_got_rx: CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv); } else { /* Croak with a READONLY error when a numbered match var is * set without a previous pattern match. Unless it's C<local $1> */ - croakparen: + croakparen: if (!PL_localizing) { Perl_croak_no_modify(); } } - break; + return 0; + } + + switch (*mg->mg_ptr) { case '\001': /* ^A */ if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); else SvOK_off(PL_bodytarget); @@ -2637,16 +2598,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } break; case '\020': /* ^P */ - if (*remaining == '\0') { /* ^P */ PL_perldb = SvIV(sv); if (PL_perldb && !PL_DBsingle) init_debugger(); - break; - } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */ - goto do_prematch; - } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */ - goto do_postmatch; - } break; case '\024': /* ^T */ #ifdef BIG_TIME diff --git a/pod/perldelta.pod b/pod/perldelta.pod index da73a1d..76a9456 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -564,7 +564,11 @@ well. =item * -XXX +The internal representation has changed for the match variables C<$1>, C<$2> +I<etc.>, C<$`>, C<$&>, C<$'>, C<${^PREMATCH}>, C<${^MATCH}> and +C<${^POSTMATCH>. It uses slightly less memory, avoids string comparisons +and numeric conversions during lookup, and uses 23 fewer lines of C. This +change should not affect any external code. =back -- Perl5 Master Repository
