/* pp_hot.c
*
- * Copyright (c) 1991-1997, Larry Wall
+ * Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#ifdef I_UNISTD
#include <unistd.h>
#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
+#define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off))
/* Hot code. */
dTHR;
#endif /* DEBUGGING */
- DEBUG_L((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
+ DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
thr, cv, SvPEEK((SV*)cv))));
MUTEX_LOCK(CvMUTEXP(cv));
- DEBUG_L(if (CvDEPTH(cv) != 0)
+ DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
CvDEPTH(cv)););
assert(thr == CvOWNER(cv));
PP(pp_readline)
{
+ tryAMAGICunTARGET(iter, 0);
PL_last_in_gv = (GV*)(*PL_stack_sp--);
+ if (PL_op->op_flags & OPf_SPECIAL) { /* Are called as <$var> */
+ if (SvROK(PL_last_in_gv)) {
+ if (SvTYPE(SvRV(PL_last_in_gv)) != SVt_PVGV)
+ goto hard_way;
+ PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
+ } else if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
+ hard_way: {
+ dSP;
+ XPUSHs((SV*)PL_last_in_gv);
+ PUTBACK;
+ pp_rv2gv(ARGS);
+ PL_last_in_gv = (GV*)(*PL_stack_sp--);
+ }
+ }
+ }
return do_readline();
}
{
djSP;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(no_modify);
+ croak(PL_no_modify);
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MAX)
{
Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
XPUSHs(sv);
#else
- XPUSHs((SV*)op);
+ XPUSHs((SV*)PL_op);
#endif
RETURN;
}
IO *io;
register PerlIO *fp;
MAGIC *mg;
+ STRLEN n_a;
if (PL_op->op_flags & OPf_STACKED)
gv = (GV*)*++MARK;
else
gv = PL_defoutgv;
- if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+ if (mg = SvTIED_mg((SV*)gv, 'q')) {
if (MARK == ORIGMARK) {
/* If using default handle then we need to make space to
* pass object as 1st arg, so move other args up ...
++SP;
}
PUSHMARK(MARK - 1);
- *MARK = mg->mg_obj;
+ *MARK = SvTIED_obj((SV*)gv, mg);
PUTBACK;
ENTER;
perl_call_method("PRINT", G_SCALAR);
RETURN;
}
if (!(io = GvIO(gv))) {
- if (PL_dowarn) {
+ if (ckWARN(WARN_UNOPENED)) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
- warn("Filehandle %s never opened", SvPV(sv,PL_na));
+ warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
- if (PL_dowarn) {
+ if (ckWARN2(WARN_CLOSED, WARN_IO)) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
- warn("Filehandle %s opened only for input", SvPV(sv,PL_na));
- else
- warn("print on closed filehandle %s", SvPV(sv,PL_na));
+ warner(WARN_IO, "Filehandle %s opened only for input",
+ SvPV(sv,n_a));
+ else if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "print on closed filehandle %s",
+ SvPV(sv,n_a));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
PP(pp_rv2av)
{
- djSP; dPOPss;
+ djSP; dTOPss;
AV *av;
if (SvROK(sv)) {
wasref:
+ tryAMAGICunDEREF(to_av);
+
av = (AV*)SvRV(sv);
if (SvTYPE(av) != SVt_PVAV)
DIE("Not an ARRAY reference");
if (PL_op->op_flags & OPf_REF) {
- PUSHs((SV*)av);
+ SETs((SV*)av);
RETURN;
}
}
if (SvTYPE(sv) == SVt_PVAV) {
av = (AV*)sv;
if (PL_op->op_flags & OPf_REF) {
- PUSHs((SV*)av);
+ SETs((SV*)av);
RETURN;
}
}
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
+ STRLEN n_a;
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_usym, "an ARRAY");
- if (PL_dowarn)
- warn(warn_uninit);
- if (GIMME == G_ARRAY)
+ DIE(PL_no_usym, "an ARRAY");
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ if (GIMME == G_ARRAY) {
+ (void)POPs;
RETURN;
- RETPUSHUNDEF;
+ }
+ RETSETUNDEF;
}
- sym = SvPV(sv,PL_na);
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "an ARRAY");
- gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
- } else {
+ sym = SvPV(sv,n_a);
+ if ((PL_op->op_flags & OPf_SPECIAL) &&
+ !(PL_op->op_flags & OPf_MOD))
+ {
+ gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
+ if (!gv)
+ RETSETUNDEF;
+ }
+ else {
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(PL_no_symref, sym, "an ARRAY");
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
+ }
+ }
+ else {
gv = (GV*)sv;
}
av = GvAVn(gv);
if (PL_op->op_private & OPpLVAL_INTRO)
av = save_ary(gv);
if (PL_op->op_flags & OPf_REF) {
- PUSHs((SV*)av);
+ SETs((SV*)av);
RETURN;
}
}
if (GIMME == G_ARRAY) {
I32 maxarg = AvFILL(av) + 1;
+ (void)POPs; /* XXXX May be optimized away? */
EXTEND(SP, maxarg);
if (SvRMAGICAL(av)) {
U32 i;
else {
dTARGET;
I32 maxarg = AvFILL(av) + 1;
- PUSHi(maxarg);
+ SETi(maxarg);
}
RETURN;
}
if (SvROK(sv)) {
wasref:
+ tryAMAGICunDEREF(to_hv);
+
hv = (HV*)SvRV(sv);
if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
DIE("Not a HASH reference");
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
+ STRLEN n_a;
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_usym, "a HASH");
- if (PL_dowarn)
- warn(warn_uninit);
+ DIE(PL_no_usym, "a HASH");
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
if (GIMME == G_ARRAY) {
SP--;
RETURN;
}
RETSETUNDEF;
}
- sym = SvPV(sv,PL_na);
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "a HASH");
- gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
- } else {
+ sym = SvPV(sv,n_a);
+ if ((PL_op->op_flags & OPf_SPECIAL) &&
+ !(PL_op->op_flags & OPf_MOD))
+ {
+ gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
+ if (!gv)
+ RETSETUNDEF;
+ }
+ else {
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(PL_no_symref, sym, "a HASH");
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
+ }
+ }
+ else {
gv = (GV*)sv;
}
hv = GvHVn(gv);
* clobber a value on the right that's used later in the list.
*/
if (PL_op->op_private & OPpASSIGN_COMMON) {
+ EXTEND_MORTAL(lastrelem - firstrelem + 1);
for (relem = firstrelem; relem <= lastrelem; relem++) {
/*SUPPRESS 560*/
if (sv = *relem) {
if (SvSMAGICAL(sv))
mg_set(sv);
if (!didstore)
- SvREFCNT_dec(sv);
+ sv_2mortal(sv);
}
TAINT_NOT;
}
if (SvSMAGICAL(tmpstr))
mg_set(tmpstr);
if (!didstore)
- SvREFCNT_dec(tmpstr);
+ sv_2mortal(tmpstr);
}
TAINT_NOT;
}
if (relem == lastrelem) {
if (*relem) {
HE *didstore;
- if (PL_dowarn) {
+ if (ckWARN(WARN_UNSAFE)) {
if (relem == firstrelem &&
SvROK(*relem) &&
( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
- warn("Reference found where even-sized list expected");
+ warner(WARN_UNSAFE, "Reference found where even-sized list expected");
else
- warn("Odd number of elements in hash assignment");
+ warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
}
tmpstr = NEWSV(29,0);
didstore = hv_store_ent(hash,*relem,tmpstr,0);
if (SvSMAGICAL(tmpstr))
mg_set(tmpstr);
if (!didstore)
- SvREFCNT_dec(tmpstr);
+ sv_2mortal(tmpstr);
}
TAINT_NOT;
}
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv) && PL_curcop != &PL_compiling) {
if (!SvIMMORTAL(sv))
- DIE(no_modify);
+ DIE(PL_no_modify);
if (relem <= lastrelem)
relem++;
break;
register char *s;
char *strend;
I32 global;
- I32 safebase;
+ I32 r_flags = 0;
char *truebase;
register REGEXP *rx = pm->op_pmregexp;
bool rxtainted;
I32 minmatch = 0;
I32 oldsave = PL_savestack_ix;
I32 update_minmatch = 1;
- SV *screamer;
+ I32 had_zerolen = 0;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
}
if (rx->minlen > len) goto failure;
- screamer = ( (SvSCREAM(TARG) && rx->check_substr
- && SvTYPE(rx->check_substr) == SVt_PVBM
- && SvVALID(rx->check_substr))
- ? TARG : Nullsv);
truebase = t = s;
+
+ /* XXXX What part of this is needed with true \G-support? */
if (global = pm->op_pmflags & PMf_GLOBAL) {
rx->startp[0] = 0;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* mg = mg_find(TARG, 'g');
if (mg && mg->mg_len >= 0) {
- rx->endp[0] = rx->startp[0] = s + mg->mg_len;
+ if (!(rx->reganch & ROPT_GPOS_SEEN))
+ rx->endp[0] = rx->startp[0] = s + mg->mg_len;
+ else if (rx->reganch & ROPT_ANCH_GPOS) {
+ r_flags |= REXEC_IGNOREPOS;
+ rx->endp[0] = rx->startp[0] = s + mg->mg_len;
+ }
minmatch = (mg->mg_flags & MGf_MINMATCH);
update_minmatch = 0;
}
}
}
- safebase = (((gimme == G_ARRAY) || global || !rx->nparens)
- && !PL_sawampersand);
- safebase = safebase ? 0 : REXEC_COPY_STR ;
+ if ((gimme != G_ARRAY && !global && rx->nparens)
+ || SvTEMP(TARG) || PL_sawampersand)
+ r_flags |= REXEC_COPY_STR;
+ if (SvSCREAM(TARG) && rx->check_substr
+ && SvTYPE(rx->check_substr) == SVt_PVBM
+ && SvVALID(rx->check_substr))
+ r_flags |= REXEC_SCREAM;
+
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(PL_multiline);
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
if ((s + rx->minlen) > strend)
goto nope;
if (update_minmatch++)
- minmatch = (s == rx->startp[0]);
+ minmatch = had_zerolen;
}
if (rx->check_substr) {
if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */
- if ( screamer ) {
+ if (r_flags & REXEC_SCREAM) {
I32 p = -1;
+ char *b;
if (PL_screamfirst[BmRARE(rx->check_substr)] < 0)
goto nope;
- else if (!(s = screaminstr(TARG, rx->check_substr,
- rx->check_offset_min, 0, &p, 0)))
+
+ b = (char*)HOP((U8*)s, rx->check_offset_min);
+ if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0)))
goto nope;
- else if ((rx->reganch & ROPT_CHECK_ALL)
+
+ if ((rx->reganch & ROPT_CHECK_ALL)
&& !PL_sawampersand && !SvTAIL(rx->check_substr))
goto yup;
}
- else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min,
+ else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min),
(unsigned char*)strend,
rx->check_substr, 0)))
goto nope;
goto yup;
if (s && rx->check_offset_max < s - t) {
++BmUSEFUL(rx->check_substr);
- s -= rx->check_offset_max;
+ s = (char*)HOP((U8*)s, -rx->check_offset_max);
}
else
s = t;
beginning of match, and the match is anchored at s. */
else if (!PL_multiline) { /* Anchored near beginning of string. */
I32 slen;
- if (*SvPVX(rx->check_substr) != s[rx->check_offset_min]
+ char *b = (char*)HOP((U8*)s, rx->check_offset_min);
+ if (*SvPVX(rx->check_substr) != *b
|| ((slen = SvCUR(rx->check_substr)) > 1
- && memNE(SvPVX(rx->check_substr),
- s + rx->check_offset_min, slen)))
+ && memNE(SvPVX(rx->check_substr), b, slen)))
goto nope;
}
- if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0
+ if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0
&& rx->check_substr == rx->float_substr) {
SvREFCNT_dec(rx->check_substr);
rx->check_substr = Nullsv; /* opt is being useless */
rx->float_substr = Nullsv;
}
}
- if (CALLREGEXEC(rx, s, strend, truebase, minmatch,
- screamer, NULL, safebase))
+ if (CALLREGEXEC(rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
{
PL_curpm = pm;
if (pm->op_pmflags & PMf_ONCE)
if (global) {
truebase = rx->subbeg;
strend = rx->subend;
- if (rx->startp[0] && rx->startp[0] == rx->endp[0])
- ++rx->endp[0];
+ had_zerolen = (rx->startp[0] && rx->startp[0] == rx->endp[0]);
PUTBACK; /* EVAL blocks may use stack */
+ r_flags |= REXEC_IGNOREPOS;
goto play_it_again;
}
else if (!iters)
- XPUSHs(&sv_yes);
+ XPUSHs(&PL_sv_yes);
LEAVE_SCOPE(oldsave);
RETURN;
}
I32 gimme = GIMME_V;
MAGIC *mg;
- if (SvRMAGICAL(PL_last_in_gv) && (mg = mg_find((SV*)PL_last_in_gv, 'q'))) {
+ if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) {
PUSHMARK(SP);
- XPUSHs(mg->mg_obj);
+ XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
PUTBACK;
ENTER;
perl_call_method("READLINE", gimme);
IoFLAGS(io) &= ~IOf_START;
IoLINES(io) = 0;
if (av_len(GvAVn(PL_last_in_gv)) < 0) {
- do_open(PL_last_in_gv,"-",1,FALSE,0,0,Nullfp);
+ do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
SvSETMAGIC(GvSV(PL_last_in_gv));
fp = IoIFP(io);
#endif /* !CSH */
#endif /* !DOSISH */
(void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
- FALSE, 0, 0, Nullfp);
+ FALSE, O_RDONLY, 0, Nullfp);
fp = IoIFP(io);
#endif /* !VMS */
LEAVE;
SP--;
}
if (!fp) {
- if (PL_dowarn && io && !(IoFLAGS(io) & IOf_START))
- warn("Read on closed filehandle <%s>", GvENAME(PL_last_in_gv));
+ if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START))
+ warner(WARN_CLOSED,
+ "Read on closed filehandle <%s>", GvENAME(PL_last_in_gv));
if (gimme == G_SCALAR) {
(void)SvOK_off(TARG);
PUSHTARG;
sv = sv_2mortal(NEWSV(57, 80));
offset = 0;
}
+
+/* flip-flop EOF state for a snarfed empty file */
+#define SNARF_EOF(gimme,rs,io,sv) \
+ ((gimme != G_SCALAR || SvCUR(sv) \
+ || (IoFLAGS(io) & IOf_NOLINE) || IoLINES(io) || !RsSNARF(rs)) \
+ ? ((IoFLAGS(io) &= ~IOf_NOLINE), TRUE) \
+ : ((IoFLAGS(io) |= IOf_NOLINE), FALSE))
+
for (;;) {
- if (!sv_gets(sv, fp, offset)) {
+ if (!sv_gets(sv, fp, offset)
+ && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
+ {
PerlIO_clearerr(fp);
if (IoFLAGS(io) & IOf_ARGV) {
fp = nextargv(PL_last_in_gv);
IoFLAGS(io) |= IOf_START;
}
else if (type == OP_GLOB) {
- if (do_close(PL_last_in_gv, FALSE) & ~0xFF)
- warn("internal error: glob failed");
+ if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) {
+ warner(WARN_CLOSED,
+ "glob failed (child exited with status %d%s)",
+ STATUS_CURRENT >> 8,
+ (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
+ }
}
if (gimme == G_SCALAR) {
(void)SvOK_off(TARG);
svp = he ? &HeVAL(he) : 0;
}
else if (SvTYPE(hv) == SVt_PVAV) {
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ DIE("Can't localize pseudo-hash element");
svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
}
else {
if (!svp || *svp == &PL_sv_undef) {
SV* lv;
SV* key2;
- if (!defer)
- DIE(no_helem, SvPV(keysv, PL_na));
+ if (!defer) {
+ STRLEN n_a;
+ DIE(PL_no_helem, SvPV(keysv, n_a));
+ }
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
- if (cx->cx_type != CXt_LOOP)
+ if (CxTYPE(cx) != CXt_LOOP)
DIE("panic: pp_iter");
av = cx->blk_loop.iterary;
char *max = SvPV((SV*)av, maxlen);
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
#ifndef USE_THREADS /* don't risk potential race */
- if (SvREFCNT(*cx->blk_loop.itervar) == 1) {
+ if (SvREFCNT(*cx->blk_loop.itervar) == 1
+ && !SvMAGICAL(*cx->blk_loop.itervar))
+ {
/* safe to reuse old SV */
sv_setsv(*cx->blk_loop.itervar, cur);
}
RETPUSHNO;
#ifndef USE_THREADS /* don't risk potential race */
- if (SvREFCNT(*cx->blk_loop.itervar) == 1) {
+ if (SvREFCNT(*cx->blk_loop.itervar) == 1
+ && !SvMAGICAL(*cx->blk_loop.itervar))
+ {
/* safe to reuse old SV */
sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++);
}
bool once;
bool rxtainted;
char *orig;
- I32 safebase;
+ I32 r_flags;
register REGEXP *rx = pm->op_pmregexp;
STRLEN len;
int force_on_match = 0;
I32 oldsave = PL_savestack_ix;
I32 update_minmatch = 1;
- SV *screamer;
/* known replacement string? */
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
if (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
- croak(no_modify);
+ croak(PL_no_modify);
PUTBACK;
s = SvPV(TARG, len);
pm = PL_curpm;
rx = pm->op_pmregexp;
}
- screamer = ( (SvSCREAM(TARG) && rx->check_substr
+ r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
+ ? REXEC_COPY_STR : 0;
+ if (SvSCREAM(TARG) && rx->check_substr
&& SvTYPE(rx->check_substr) == SVt_PVBM
- && SvVALID(rx->check_substr))
- ? TARG : Nullsv);
- safebase = (!rx->nparens && !PL_sawampersand) ? 0 : REXEC_COPY_STR;
+ && SvVALID(rx->check_substr))
+ r_flags |= REXEC_SCREAM;
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(PL_multiline);
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
orig = m = s;
if (rx->check_substr) {
if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */
- if (screamer) {
+ if (r_flags & REXEC_SCREAM) {
I32 p = -1;
+ char *b;
if (PL_screamfirst[BmRARE(rx->check_substr)] < 0)
goto nope;
- else if (!(s = screaminstr(TARG, rx->check_substr, rx->check_offset_min, 0, &p, 0)))
+
+ b = (char*)HOP((U8*)s, rx->check_offset_min);
+ if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0)))
goto nope;
}
- else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min,
+ else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min),
(unsigned char*)strend,
rx->check_substr, 0)))
goto nope;
if (s && rx->check_offset_max < s - m) {
++BmUSEFUL(rx->check_substr);
- s -= rx->check_offset_max;
+ s = (char*)HOP((U8*)s, -rx->check_offset_max);
}
else
s = m;
beginning of match, and the match is anchored at s. */
else if (!PL_multiline) { /* Anchored at beginning of string. */
I32 slen;
- if (*SvPVX(rx->check_substr) != s[rx->check_offset_min]
+ char *b = (char*)HOP((U8*)s, rx->check_offset_min);
+ if (*SvPVX(rx->check_substr) != *b
|| ((slen = SvCUR(rx->check_substr)) > 1
- && memNE(SvPVX(rx->check_substr),
- s + rx->check_offset_min, slen)))
+ && memNE(SvPVX(rx->check_substr), b, slen)))
goto nope;
}
- if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0
+ if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0
&& rx->check_substr == rx->float_substr) {
SvREFCNT_dec(rx->check_substr);
rx->check_substr = Nullsv; /* opt is being useless */
c = dstr ? SvPV(dstr, clen) : Nullch;
/* can do inplace substitution? */
- if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR))
+ if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
- if (!CALLREGEXEC(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+ if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
SPAGAIN;
PUSHs(&PL_sv_no);
LEAVE_SCOPE(oldsave);
RETURN;
}
- if (CALLREGEXEC(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+ if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
PUSHSUBST(cx);
RETURNOP(cPMOP->op_pmreplroot);
}
+ r_flags |= REXEC_IGNOREPOS;
do {
if (iters++ > maxiters)
DIE("Substitution loop");
sv_catpvn(dstr, c, clen);
if (once)
break;
- } while (CALLREGEXEC(rx, s, strend, orig, s == m, Nullsv, NULL, safebase));
+ } while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, r_flags));
sv_catpvn(dstr, s, strend - s);
(void)SvOOK_off(TARG);
default:
if (!SvROK(sv)) {
char *sym;
+ STRLEN n_a;
if (sv == &PL_sv_yes) { /* unfound import, ignore */
if (hasargs)
sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
}
else
- sym = SvPV(sv, PL_na);
+ sym = SvPV(sv, n_a);
if (!sym)
- DIE(no_usym, "a subroutine");
+ DIE(PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "a subroutine");
+ DIE(PL_no_symref, sym, "a subroutine");
cv = perl_get_cv(sym, TRUE);
break;
}
+ {
+ SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
+ tryAMAGICunDEREF(to_cv);
+ }
cv = (CV*)SvRV(sv);
if (SvTYPE(cv) == SVt_PVCV)
break;
if (SP > PL_stack_base + TOPMARK)
sv = *(PL_stack_base + TOPMARK + 1);
else {
- MUTEX_UNLOCK(CvMUTEXP(cv));
- croak("no argument for locked method call");
+ AV *av = (AV*)PL_curpad[0];
+ if (hasargs || !av || AvFILLp(av) < 0
+ || !(sv = AvARRAY(av)[0]))
+ {
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ croak("no argument for locked method call");
+ }
}
if (SvROK(sv))
sv = SvRV(sv);
while (MgOWNER(mg))
COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
MgOWNER(mg) = thr;
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
thr, sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
- SvREFCNT_inc(sv); /* Keep alive until magic_mutexfree */
save_destructor(unlock_condpair, sv);
}
MUTEX_LOCK(CvMUTEXP(cv));
* (3) instead of (2) so we'd have to clone. Would the fact
* that we released the mutex more quickly make up for this?
*/
- if (PL_threadnum &&
- (svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
+ if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
{
/* We already have a clone to use */
MUTEX_UNLOCK(CvMUTEXP(cv));
cv = *(CV**)svp;
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"entersub: %p already has clone %p:%s\n",
thr, cv, SvPEEK((SV*)cv)));
CvOWNER(cv) = thr;
CvOWNER(cv) = thr;
SvREFCNT_inc(cv);
MUTEX_UNLOCK(CvMUTEXP(cv));
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"entersub: %p grabbing %p:%s in stash %s\n",
thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
HvNAME(CvSTASH(cv)) : "(none)"));
CV *clonecv;
SvREFCNT_inc(cv); /* don't let it vanish from under us */
MUTEX_UNLOCK(CvMUTEXP(cv));
- DEBUG_L((PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S((PerlIO_printf(PerlIO_stderr(),
"entersub: %p cloning %p:%s\n",
thr, cv, SvPEEK((SV*)cv))));
/*
cv = clonecv;
SvREFCNT_inc(cv);
}
- DEBUG_L(if (CvDEPTH(cv) != 0)
+ DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
CvDEPTH(cv)););
SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
CvDEPTH(cv)++;
+ /* XXX This would be a natural place to set C<PL_compcv = cv> so
+ * that eval'' ops within this sub know the correct lexical space.
+ * Owing the speed considerations, we choose to search for the cv
+ * in doeval() instead.
+ */
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
- if (CvDEPTH(cv) == 100 && PL_dowarn
- && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
- sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILLp(padlist)) {
AV *av;
AV *newpad = newAV();
SV** ary;
#if 0
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"%p entersub preparing @_\n", thr));
#endif
av = (AV*)PL_curpad[0];
MARK++;
}
}
+ /* warning must come *after* we fully set up the context
+ * stuff so that __WARN__ handlers can safely dounwind()
+ * if they want to
+ */
+ if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
+ && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
+ sub_crush_depth(cv);
#if 0
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"%p entersub returning %p\n", thr, CvSTART(cv)));
#endif
RETURNOP(CvSTART(cv));
sub_crush_depth(CV *cv)
{
if (CvANON(cv))
- warn("Deep recursion on anonymous subroutine");
+ warner(WARN_RECURSION, "Deep recursion on anonymous subroutine");
else {
SV* tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
- warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr));
+ warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
+ SvPVX(tmpstr));
}
}
if (!svp || *svp == &PL_sv_undef) {
SV* lv;
if (!defer)
- DIE(no_aelem, elem);
+ DIE(PL_no_aelem, elem);
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
mg_get(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
- croak(no_modify);
+ croak(PL_no_modify);
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
else if (SvTYPE(sv) >= SVt_PV) {
}
}
- name = SvPV(TOPs, PL_na);
+ name = SvPV(TOPs, packlen);
sv = *(PL_stack_base + TOPMARK + 1);
if (SvGMAGICAL(sv))
!(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
- if (!packname || !isIDFIRST(*packname))
+ if (!packname ||
+ ((*(U8*)packname >= 0xc0 && IN_UTF8)
+ ? !isIDFIRST_utf8((U8*)packname)
+ : !isIDFIRST(*packname)
+ ))
+ {
DIE("Can't call method \"%s\" %s", name,
SvOK(sv)? "without a package or object reference"
: "on an undefined value");
+ }
stash = gv_stashpvn(packname, packlen, TRUE);
goto fetch;
}
https://perl5.git.perl.org / perl5.git / blobdiff