X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=c4fc190185f107669e7ce31b8d427fb8d55e9447;hb=196ac2fcd2dad2d042479c51fe09289545232c66;hp=961776716542300c7b7880e890164e390f0d9ca7;hpb=08aeb9f701fa786d490e79e99ac2f9f9de229da3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index 9617767..c4fc190 100644 --- a/mg.c +++ b/mg.c @@ -582,45 +582,53 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) dVAR; register I32 paren; register I32 i; - register const REGEXP *rx; - I32 s1, t1; + register const REGEXP * rx; + const char * const remaining = mg->mg_ptr + 1; switch (*mg->mg_ptr) { + case '\020': + if (*remaining == '\0') { /* ^P */ + break; + } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */ + goto do_prematch; + } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */ + goto do_postmatch; + } + break; + case '\015': /* $^MATCH */ + if (strEQ(remaining, "ATCH")) { + goto do_match; + } else { + break; + } + case '`': + do_prematch: + paren = RX_BUFF_IDX_PREMATCH; + goto maybegetparen; + case '\'': + do_postmatch: + paren = RX_BUFF_IDX_POSTMATCH; + goto maybegetparen; + case '&': + do_match: + paren = RX_BUFF_IDX_FULLMATCH; + goto maybegetparen; case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': case '&': + case '5': case '6': case '7': case '8': case '9': + paren = atoi(mg->mg_ptr); + maybegetparen: if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + getparen: + i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren); - paren = atoi(mg->mg_ptr); /* $& is in [0] */ - getparen: - if (paren <= (I32)rx->nparens && - (s1 = rx->offs[paren].start) != -1 && - (t1 = rx->offs[paren].end) != -1) - { - i = t1 - s1; - getlen: - if (i > 0 && RX_MATCH_UTF8(rx)) { - const char * const s = rx->subbeg + s1; - const U8 *ep; - STRLEN el; - - i = t1 - s1; - if (is_utf8_string_loclen((U8*)s, i, &ep, &el)) - i = el; - } if (i < 0) Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i); return i; - } - else { + } else { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); - } - } - else { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); + return 0; } - return 0; case '+': if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { paren = rx->lastparen; @@ -635,30 +643,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) goto getparen; } return 0; - case '`': - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - if (rx->offs[0].start != -1) { - i = rx->offs[0].start; - if (i > 0) { - s1 = 0; - t1 = i; - goto getlen; - } - } - } - return 0; - case '\'': - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - if (rx->offs[0].end != -1) { - i = rx->sublen - rx->offs[0].end; - if (i > 0) { - s1 = rx->offs[0].end; - t1 = rx->sublen; - goto getlen; - } - } - } - return 0; } magic_get(sv,mg); if (!SvPOK(sv) && SvNIOK(sv)) { @@ -823,7 +807,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '\023': /* ^S */ if (nextchar == '\0') { - if (PL_lex_state != LEX_NOTPARSING) + if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING) SvOK_off(sv); else if (PL_in_eval) sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); @@ -896,7 +880,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) * XXX Does the new way break anything? */ paren = atoi(mg->mg_ptr); /* $& is in [0] */ - CALLREG_NUMBUF(rx,paren,sv); + CALLREG_NUMBUF_FETCH(rx,paren,sv); break; } sv_setsv(sv,&PL_sv_undef); @@ -905,7 +889,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '+': if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { if (rx->lastparen) { - CALLREG_NUMBUF(rx,rx->lastparen,sv); + CALLREG_NUMBUF_FETCH(rx,rx->lastparen,sv); break; } } @@ -914,7 +898,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\016': /* ^N */ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { if (rx->lastcloseparen) { - CALLREG_NUMBUF(rx,rx->lastcloseparen,sv); + CALLREG_NUMBUF_FETCH(rx,rx->lastcloseparen,sv); break; } @@ -924,7 +908,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '`': do_prematch_fetch: if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - CALLREG_NUMBUF(rx,-2,sv); + CALLREG_NUMBUF_FETCH(rx,-2,sv); break; } sv_setsv(sv,&PL_sv_undef); @@ -932,7 +916,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\'': do_postmatch_fetch: if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - CALLREG_NUMBUF(rx,-1,sv); + CALLREG_NUMBUF_FETCH(rx,-1,sv); break; } sv_setsv(sv,&PL_sv_undef); @@ -1333,6 +1317,9 @@ Perl_csighandler(int sig) #else dTHX; #endif +#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) + va_list args; +#endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS (void) rsignal(sig, PL_csighandlerp); if (PL_sig_ignoring[sig]) return; @@ -1345,6 +1332,9 @@ Perl_csighandler(int sig) exit(1); #endif #endif +#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) + va_start(args, sig); +#endif if ( #ifdef SIGILL sig == SIGILL || @@ -1361,6 +1351,9 @@ Perl_csighandler(int sig) (*PL_sighandlerp)(sig); else S_raise_signal(aTHX_ sig); +#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) + va_end(args); +#endif } #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) @@ -1535,6 +1528,15 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) /* Bail out if destruction is going on */ if(PL_dirty) return 0; + /* Skip _isaelem because _isa will handle it shortly */ + if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem) + return 0; + + /* XXX Once it's possible, we need to + detect that our @ISA is aliased in + other stashes, and act on the stashes + of all of the aliases */ + /* The first case occurs via setisa, the second via setisa_elem, which calls this same magic */ @@ -1544,10 +1546,7 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) : (GV*)SvMAGIC(mg->mg_obj)->mg_obj ); - if(PL_delaymagic) - PL_delayedisa = stash; - else - mro_isa_changed_in(stash); + mro_isa_changed_in(stash); return 0; } @@ -2234,9 +2233,43 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { dVAR; register const char *s; + register I32 paren; + register const REGEXP * rx; + const char * const remaining = mg->mg_ptr + 1; I32 i; STRLEN len; + 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 (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv); + break; + } else { + /* Croak with a READONLY error when a numbered match var is + * set without a previous pattern match. Unless it's C + */ + if (!PL_localizing) { + Perl_croak(aTHX_ PL_no_modify); + } + } case '\001': /* ^A */ sv_setsv(PL_bodytarget, sv); break; @@ -2335,10 +2368,16 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } break; case '\020': /* ^P */ - PL_perldb = SvIV(sv); - if (PL_perldb && !PL_DBsingle) - init_debugger(); - break; + 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; + } case '\024': /* ^T */ #ifdef BIG_TIME PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));