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)
{
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);
+ sym = SvPV(sv,n_a);
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "an ARRAY");
+ DIE(PL_no_symref, sym, "an ARRAY");
gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
} else {
gv = (GV*)sv;
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);
+ sym = SvPV(sv,n_a);
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "a HASH");
+ DIE(PL_no_symref, sym, "a HASH");
gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
} else {
gv = (GV*)sv;
* 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 (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 (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;
char *truebase;
register REGEXP *rx = pm->op_pmregexp;
bool rxtainted;
I32 minmatch = 0;
I32 oldsave = PL_savestack_ix;
I32 update_minmatch = 1;
- SV *screamer;
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)) {
}
}
}
- safebase = (((gimme == G_ARRAY) || global || !rx->nparens)
- && !PL_sawampersand);
- safebase = safebase ? 0 : REXEC_COPY_STR ;
+ r_flags = ((gimme != G_ARRAY && !global && 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))
+ r_flags |= REXEC_SCREAM;
+
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(PL_multiline);
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
}
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;
- b = HOP((U8*)s, rx->check_offset_min);
+ b = (char*)HOP((U8*)s, rx->check_offset_min);
if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0)))
goto nope;
goto yup;
if (s && rx->check_offset_max < s - t) {
++BmUSEFUL(rx->check_substr);
- s = HOP((U8*)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;
- char *b = HOP((U8*)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), b, slen)))
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 (rx->startp[0] && rx->startp[0] == rx->endp[0])
++rx->endp[0];
PUTBACK; /* EVAL blocks may use stack */
+ r_flags |= REXEC_IGNOREPOS;
goto play_it_again;
}
else if (!iters)
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);
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;
IoFLAGS(io) |= IOf_START;
}
else if (type == OP_GLOB) {
- if (!do_close(PL_last_in_gv, FALSE))
- 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);
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;
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;
- b = HOP((U8*)s, rx->check_offset_min);
+ b = (char*)HOP((U8*)s, rx->check_offset_min);
if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0)))
goto nope;
}
goto nope;
if (s && rx->check_offset_max < s - m) {
++BmUSEFUL(rx->check_substr);
- s = HOP((U8*)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;
- char *b = HOP((U8*)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), b, slen)))
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;
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));
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();
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_S(PerlIO_printf(PerlIO_stderr(),
"%p entersub returning %p\n", thr, 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;
}