}
}
+
+/* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
+
+STATIC bool
+S_is_container_magic(const MAGIC *mg)
+{
+ switch (mg->mg_type) {
+ case PERL_MAGIC_bm:
+ case PERL_MAGIC_fm:
+ case PERL_MAGIC_regex_global:
+ case PERL_MAGIC_nkeys:
+#ifdef USE_LOCALE_COLLATE
+ case PERL_MAGIC_collxfrm:
+#endif
+ case PERL_MAGIC_qr:
+ case PERL_MAGIC_taint:
+ case PERL_MAGIC_vec:
+ case PERL_MAGIC_vstring:
+ case PERL_MAGIC_utf8:
+ case PERL_MAGIC_substr:
+ case PERL_MAGIC_defelem:
+ case PERL_MAGIC_arylen:
+ case PERL_MAGIC_pos:
+ case PERL_MAGIC_backref:
+ case PERL_MAGIC_arylen_p:
+ case PERL_MAGIC_rhash:
+ case PERL_MAGIC_symtab:
+ return 0;
+ default:
+ return 1;
+ }
+}
+
/*
=for apidoc mg_get
mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
(SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
}
+ if (PL_localizing == 2 && !S_is_container_magic(mg))
+ continue;
if (vtbl && vtbl->svt_set)
CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
}
MAGIC *mg;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
- switch (mg->mg_type) {
- /* value magic types: don't copy */
- case PERL_MAGIC_bm:
- case PERL_MAGIC_fm:
- case PERL_MAGIC_regex_global:
- case PERL_MAGIC_nkeys:
-#ifdef USE_LOCALE_COLLATE
- case PERL_MAGIC_collxfrm:
-#endif
- case PERL_MAGIC_qr:
- case PERL_MAGIC_taint:
- case PERL_MAGIC_vec:
- case PERL_MAGIC_vstring:
- case PERL_MAGIC_utf8:
- case PERL_MAGIC_substr:
- case PERL_MAGIC_defelem:
- case PERL_MAGIC_arylen:
- case PERL_MAGIC_pos:
- case PERL_MAGIC_backref:
- case PERL_MAGIC_arylen_p:
- case PERL_MAGIC_rhash:
- case PERL_MAGIC_symtab:
+ if (!S_is_container_magic(mg))
continue;
- }
if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
(void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
/* return the last filled */
while ( paren >= 0
- && (rx->startp[paren] == -1 || rx->endp[paren] == -1) )
+ && (rx->offs[paren].start == -1
+ || rx->offs[paren].end == -1) )
paren--;
return (U32)paren;
}
if (paren < 0)
return 0;
if (paren <= (I32)rx->nparens &&
- (s = rx->startp[paren]) != -1 &&
- (t = rx->endp[paren]) != -1)
+ (s = rx->offs[paren].start) != -1 &&
+ (t = rx->offs[paren].end) != -1)
{
register I32 i;
if (mg->mg_obj) /* @+ */
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 = RXf_PREMATCH;
+ goto maybegetparen;
+ case '\'':
+ do_postmatch:
+ paren = RXf_POSTMATCH;
+ goto maybegetparen;
+ case '&':
+ do_match:
+ paren = RXf_MATCH;
+ 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->startp[paren]) != -1 &&
- (t1 = rx->endp[paren]) != -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;
goto getparen;
}
return 0;
- case '`':
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (rx->startp[0] != -1) {
- i = rx->startp[0];
- if (i > 0) {
- s1 = 0;
- t1 = i;
- goto getlen;
- }
- }
- }
- return 0;
- case '\'':
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (rx->endp[0] != -1) {
- i = rx->sublen - rx->endp[0];
- if (i > 0) {
- s1 = rx->endp[0];
- t1 = rx->sublen;
- goto getlen;
- }
- }
- }
- return 0;
}
magic_get(sv,mg);
if (!SvPOK(sv) && SvNIOK(sv)) {
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));
* 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);
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;
}
}
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;
}
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);
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);
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+ HV* stash;
PERL_UNUSED_ARG(sv);
- PERL_UNUSED_ARG(mg);
- PL_sub_generation++;
+
+ /* Bail out if destruction is going on */
+ if(PL_dirty) 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 */
+ stash = GvSTASH(
+ SvTYPE(mg->mg_obj) == SVt_PVGV
+ ? (GV*)mg->mg_obj
+ : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
+ );
+
+ if(PL_delaymagic)
+ PL_delayedisa = stash;
+ else
+ mro_isa_changed_in(stash);
+
return 0;
}
dVAR;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
- /* HV_badAMAGIC_on(Sv_STASH(sv)); */
PL_amagic_generation++;
return 0;
Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
{
dVAR; dSP;
- U32 retval = 0;
+ I32 retval = 0;
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
sv = *PL_stack_sp--;
- retval = (U32) SvIV(sv)-1;
+ retval = SvIV(sv)-1;
+ if (retval < -1)
+ Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
}
POPSTACK;
FREETMPS;
LEAVE;
- return retval;
+ return (U32) retval;
}
int
GV* gv;
PERL_UNUSED_ARG(mg);
+ Perl_croak(aTHX_ "Perl_magic_setglob is dead code?");
+
if (!SvOK(sv))
return 0;
if (isGV_with_GP(sv)) {
{
dVAR;
PERL_UNUSED_ARG(sv);
- /* update taint status unless we're restoring at scope exit */
- if (PL_localizing != 2) {
- if (PL_tainted)
- mg->mg_len |= 1;
- else
- mg->mg_len &= ~1;
- }
+ /* update taint status */
+ if (PL_tainted)
+ mg->mg_len |= 1;
+ else
+ mg->mg_len &= ~1;
return 0;
}
{
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 = RXf_PREMATCH;
+ goto setparen;
+ case '\'': /* ${^POSTMATCH} caught below */
+ do_postmatch:
+ paren = RXf_POSTMATCH;
+ goto setparen;
+ case '&':
+ do_match:
+ paren = RXf_MATCH;
+ 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<local $1>
+ */
+ if (!PL_localizing) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+ }
case '\001': /* ^A */
sv_setsv(PL_bodytarget, sv);
break;
}
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));
https://perl5.git.perl.org / perl5.git / blobdiff