Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
++SP;
}
- return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
+ return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
mg,
(G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
| (PL_op->op_type == OP_SAY
dVAR; dSP; dTARG;
PMOP *pm = cPMOP;
PMOP *dynpm = pm;
- const char *t;
const char *s;
const char *strend;
+ I32 curpos = 0; /* initial pos() or current $+[0] */
I32 global;
- U8 r_flags = REXEC_CHECKED;
+ U8 r_flags = 0;
const char *truebase; /* Start of string */
REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
const I32 oldsave = PL_savestack_ix;
I32 update_minmatch = 1;
I32 had_zerolen = 0;
- U32 gpos = 0;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
PUTBACK; /* EVAL blocks need stack_sp. */
/* Skip get-magic if this is a qr// clone, because regcomp has
already done it. */
- s = ReANY(rx)->mother_re
+ truebase = ReANY(rx)->mother_re
? SvPV_nomg_const(TARG, len)
: SvPV_const(TARG, len);
- if (!s)
+ if (!truebase)
DIE(aTHX_ "panic: pp_match");
- strend = s + len;
+ strend = truebase + len;
rxtainted = (RX_ISTAINTED(rx) ||
(TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
goto nope;
}
- truebase = t = s;
-
/* XXXX What part of this is needed with true \G-support? */
if (global) {
- RX_OFFS(rx)[0].start = -1;
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
- MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
- if (mg && mg->mg_len >= 0) {
+ MAGIC * const mg = mg_find_mglob(TARG);
+ if (mg && mg->mg_len >= 0) {
if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
- RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
+ curpos = mg->mg_len;
else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
- r_flags |= REXEC_IGNOREPOS;
- RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
- } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
- gpos = mg->mg_len;
- else
- RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
+ curpos = mg->mg_len;
+ }
+ else if (!(RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT))
+ curpos = mg->mg_len;
minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
update_minmatch = 0;
- }
}
}
#ifdef PERL_SAWAMPERSAND
r_flags |= REXEC_COPY_SKIP_POST;
};
+ s = truebase;
+
play_it_again:
- if (global && RX_OFFS(rx)[0].start != -1) {
- t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
+ if (global) {
+ s = truebase + curpos - RX_GOFS(rx);
if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
goto nope;
if (update_minmatch++)
minmatch = had_zerolen;
}
- if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
- DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
- s = CALLREG_INTUIT_START(rx, TARG, truebase,
- (char *)s, (char *)strend, r_flags, NULL);
- if (!s)
- goto nope;
-#ifdef PERL_SAWAMPERSAND
- if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
- && !PL_sawampersand
- && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
- && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
- goto yup;
-#endif
- }
if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
- minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
- goto ret_no;
+ minmatch, TARG, NULL, r_flags))
+ goto nope;
PL_curpm = pm;
if (dynpm->op_pmflags & PMf_ONCE) {
#endif
}
- gotcha:
if (rxtainted)
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
- if (gimme == G_ARRAY) {
+
+ /* update pos */
+
+ if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
+ MAGIC *mg = mg_find_mglob(TARG);
+ if (!mg) {
+ mg = sv_magicext_mglob(TARG);
+ }
+ if (RX_OFFS(rx)[0].start != -1) {
+ mg->mg_len = RX_OFFS(rx)[0].end;
+ if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
+ mg->mg_flags |= MGf_MINMATCH;
+ else
+ mg->mg_flags &= ~MGf_MINMATCH;
+ }
+ }
+
+ if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
+ LEAVE_SCOPE(oldsave);
+ RETPUSHYES;
+ }
+
+ /* push captures on stack */
+
+ {
const I32 nparens = RX_NPARENS(rx);
I32 i = (global && !nparens) ? 1 : 0;
PUSHs(sv_newmortal());
if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
- s = RX_OFFS(rx)[i].start + truebase;
+ const char * const s = RX_OFFS(rx)[i].start + truebase;
if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
len < 0 || len > strend - s)
DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
}
}
if (global) {
- if (dynpm->op_pmflags & PMf_CONTINUE) {
- MAGIC* mg = NULL;
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
- mg = mg_find(TARG, PERL_MAGIC_regex_global);
- if (!mg) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(TARG))
- sv_force_normal_flags(TARG, 0);
-#endif
- mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
- &PL_vtbl_mglob, NULL, 0);
- }
- if (RX_OFFS(rx)[0].start != -1) {
- mg->mg_len = RX_OFFS(rx)[0].end;
- if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
- mg->mg_flags |= MGf_MINMATCH;
- else
- mg->mg_flags &= ~MGf_MINMATCH;
- }
- }
+ assert(RX_OFFS(rx)[0].start != -1);
+ curpos = (UV)RX_OFFS(rx)[0].end;
had_zerolen = (RX_OFFS(rx)[0].start != -1
&& (RX_OFFS(rx)[0].start + RX_GOFS(rx)
- == (UV)RX_OFFS(rx)[0].end));
+ == (UV)curpos));
PUTBACK; /* EVAL blocks may use stack */
r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
goto play_it_again;
}
- else if (!nparens)
- XPUSHs(&PL_sv_yes);
LEAVE_SCOPE(oldsave);
RETURN;
}
- else {
- if (global) {
- MAGIC* mg;
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
- mg = mg_find(TARG, PERL_MAGIC_regex_global);
- else
- mg = NULL;
- if (!mg) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(TARG))
- sv_force_normal_flags(TARG, 0);
-#endif
- mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
- &PL_vtbl_mglob, NULL, 0);
- }
- if (RX_OFFS(rx)[0].start != -1) {
- mg->mg_len = RX_OFFS(rx)[0].end;
- if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
- mg->mg_flags |= MGf_MINMATCH;
- else
- mg->mg_flags &= ~MGf_MINMATCH;
- }
- }
- LEAVE_SCOPE(oldsave);
- RETPUSHYES;
- }
-
-#ifdef PERL_SAWAMPERSAND
-yup: /* Confirmed by INTUIT */
-#endif
- if (rxtainted)
- RX_MATCH_TAINTED_on(rx);
- TAINT_IF(RX_MATCH_TAINTED(rx));
- PL_curpm = pm;
- if (dynpm->op_pmflags & PMf_ONCE) {
-#ifdef USE_ITHREADS
- SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
-#else
- dynpm->op_pmflags |= PMf_USED;
-#endif
- }
- if (RX_MATCH_COPIED(rx))
- Safefree(RX_SUBBEG(rx));
- RX_MATCH_COPIED_off(rx);
- RX_SUBBEG(rx) = NULL;
- if (global) {
- /* FIXME - should rx->subbeg be const char *? */
- RX_SUBBEG(rx) = (char *) truebase;
- RX_SUBOFFSET(rx) = 0;
- RX_SUBCOFFSET(rx) = 0;
- RX_OFFS(rx)[0].start = s - truebase;
- if (RX_MATCH_UTF8(rx)) {
- char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
- RX_OFFS(rx)[0].end = t - truebase;
- }
- else {
- RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
- }
- RX_SUBLEN(rx) = strend - truebase;
- goto gotcha;
- }
-#ifdef PERL_SAWAMPERSAND
- if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
-#endif
- {
- I32 off;
-#ifdef PERL_ANY_COW
- if (SvCANCOW(TARG)) {
- if (DEBUG_C_TEST) {
- PerlIO_printf(Perl_debug_log,
- "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
- (int) SvTYPE(TARG), (void*)truebase, (void*)t,
- (int)(t-truebase));
- }
- RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
- RX_SUBBEG(rx)
- = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
- assert (SvPOKp(RX_SAVED_COPY(rx)));
- } else
-#endif
- {
-
- RX_SUBBEG(rx) = savepvn(t, strend - t);
-#ifdef PERL_ANY_COW
- RX_SAVED_COPY(rx) = NULL;
-#endif
- }
- RX_SUBLEN(rx) = strend - t;
- RX_SUBOFFSET(rx) = 0;
- RX_SUBCOFFSET(rx) = 0;
- RX_MATCH_COPIED_on(rx);
- off = RX_OFFS(rx)[0].start = s - t;
- RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
- }
-#ifdef PERL_SAWAMPERSAND
- else { /* startp/endp are used by @- @+. */
- RX_OFFS(rx)[0].start = s - truebase;
- RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
- }
-#endif
- /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
- assert(!RX_NPARENS(rx));
- RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
- LEAVE_SCOPE(oldsave);
- RETPUSHYES;
+ /* NOTREACHED */
nope:
-ret_no:
if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
- MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
+ MAGIC* const mg = mg_find_mglob(TARG);
if (mg)
mg->mg_len = -1;
- }
}
LEAVE_SCOPE(oldsave);
if (gimme == G_ARRAY)
if (io) {
const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
+ Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
SPAGAIN;
SvSetSV_nosteal(TARG, TOPs);
*itersvp = NULL;
Perl_croak(aTHX_ "Use of freed value in iteration");
}
- SvTEMP_off(sv);
- SvREFCNT_inc_simple_void_NN(sv);
+ if (SvPADTMP(sv) && !IS_PADGV(sv))
+ sv = newSVsv(sv);
+ else {
+ SvTEMP_off(sv);
+ SvREFCNT_inc_simple_void_NN(sv);
+ }
}
else
sv = &PL_sv_undef;
#endif
orig = m = s;
- if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
- s = CALLREG_INTUIT_START(rx, TARG, orig, s, strend, r_flags, NULL);
-
- if (!s)
- goto ret_no;
- /* How to do it in subst? */
-/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
- && !PL_sawampersand
- && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
- goto yup;
-*/
- }
- if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
- r_flags | REXEC_CHECKED))
+ if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags))
{
- ret_no:
SPAGAIN;
PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
LEAVE_SCOPE(oldsave);
RETURN;
}
+ s = RX_OFFS(rx)[0].start + orig;
PL_curpm = pm;
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
+ if (SvPADTMP(src) && !IS_PADGV(src)) {
+ src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
+ PL_tmps_floor++;
+ }
SvTEMP_off(src);
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
}
ENTER;
- SAVETMPS;
retry:
if (CvCLONE(cv) && ! CvCLONED(cv))
Copy(MARK,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
+ MARK = AvARRAY(av);
while (items--) {
if (*MARK)
+ {
+ if (SvPADTMP(*MARK) && !IS_PADGV(*MARK))
+ *MARK = sv_mortalcopy(*MARK);
SvTEMP_off(*MARK);
+ }
MARK++;
}
}
+ SAVETMPS;
if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
!CvLVALUE(cv))
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
else {
I32 markix = TOPMARK;
+ SAVETMPS;
PUTBACK;
if (((PL_op->op_private
if (SvROK(sv))
ob = MUTABLE_SV(SvRV(sv));
else if (!SvOK(sv)) goto undefined;
+ else if (isGV_with_GP(sv)) {
+ if (!GvIO(sv))
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
+ "without a package or object reference",
+ SVfARG(meth));
+ ob = sv;
+ if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
+ assert(!LvTARGLEN(ob));
+ ob = LvTARG(ob);
+ assert(ob);
+ }
+ *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
+ }
else {
/* this isn't a reference */
GV* iogv;
/* if we got here, ob should be an object or a glob */
if (!ob || !(SvOBJECT(ob)
- || (SvTYPE(ob) == SVt_PVGV
- && isGV_with_GP(ob)
+ || (isGV_with_GP(ob)
&& (ob = MUTABLE_SV(GvIO((const GV *)ob)))
&& SvOBJECT(ob))))
{
https://perl5.git.perl.org / perl5.git / blobdiff