/* pp_hot.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, 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.
/* Hot code. */
-#ifdef USE_THREADS
-static void unset_cvowner(pTHXo_ void *cvarg);
-#endif /* USE_THREADS */
+#ifdef USE_5005THREADS
+static void unset_cvowner(pTHX_ void *cvarg);
+#endif /* USE_5005THREADS */
PP(pp_const)
{
PP(pp_stringify)
{
dSP; dTARGET;
- STRLEN len;
- char *s;
- s = SvPV(TOPs,len);
- sv_setpvn(TARG,s,len);
- if (SvUTF8(TOPs))
- SvUTF8_on(TARG);
- else
- SvUTF8_off(TARG);
+ sv_copypv(TARG,TOPs);
SETTARG;
RETURN;
}
dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
{
dPOPTOPssrl;
- SV* rcopy = Nullsv;
-
- if (SvGMAGICAL(left))
- mg_get(left);
- if (TARG == right && SvGMAGICAL(right))
- mg_get(right);
-
- if (TARG == right && left != right)
- /* Clone since otherwise we cannot prepend. */
- rcopy = sv_2mortal(newSVsv(right));
-
- if (TARG != left)
- sv_setsv(TARG, left);
-
- if (TARG == right) {
- if (left == right) {
- /* $right = $right . $right; */
- STRLEN rlen;
- char *rpv = SvPV(right, rlen);
-
- sv_catpvn(TARG, rpv, rlen);
- }
- else /* $right = $left . $right; */
- sv_catsv(TARG, rcopy);
+ STRLEN llen;
+ char* lpv;
+ bool lbyte;
+ STRLEN rlen;
+ char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
+ bool rbyte = !SvUTF8(right);
+
+ if (TARG == right && right != left) {
+ right = sv_2mortal(newSVpvn(rpv, rlen));
+ rpv = SvPV(right, rlen); /* no point setting UTF8 here */
+ }
+
+ if (TARG != left) {
+ lpv = SvPV(left, llen); /* mg_get(left) may happen here */
+ lbyte = !SvUTF8(left);
+ sv_setpvn(TARG, lpv, llen);
+ if (!lbyte)
+ SvUTF8_on(TARG);
+ else
+ SvUTF8_off(TARG);
}
- else {
- if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
- sv_setpv(TARG, "");
- /* $other = $left . $right; */
- /* $left = $left . $right; */
- sv_catsv(TARG, right);
+ else { /* TARG == left */
+ if (SvGMAGICAL(left))
+ mg_get(left); /* or mg_get(left) may happen here */
+ if (!SvOK(TARG))
+ sv_setpv(left, "");
+ lpv = SvPV_nomg(left, llen);
+ lbyte = !SvUTF8(left);
}
#if defined(PERL_Y2KWARN)
- if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
- STRLEN n;
- char *s = SvPV(TARG,n);
- if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
- && (n == 2 || !isDIGIT(s[n-3])))
+ if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
+ if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
+ && (llen == 2 || !isDIGIT(lpv[llen - 3])))
{
- Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
+ Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
"about to append an integer to '19'");
}
}
#endif
+ if (lbyte != rbyte) {
+ if (lbyte)
+ sv_utf8_upgrade_nomg(TARG);
+ else {
+ sv_utf8_upgrade_nomg(right);
+ rpv = SvPV(right, rlen);
+ }
+ }
+ sv_catpvn_nomg(TARG, rpv, rlen);
+
SETTARG;
RETURN;
}
PP(pp_eq)
{
dSP; tryAMAGICbinSET(eq,0);
+#ifndef NV_PRESERVES_UV
+ if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ SP--;
+ SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
+ RETURN;
+ }
+#endif
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
- /* Unless the left argument is integer in range we are going to have to
- use NV maths. Hence only attempt to coerce the right argument if
- we know the left is integer. */
+ /* Unless the left argument is integer in range we are going
+ to have to use NV maths. Hence only attempt to coerce the
+ right argument if we know the left is integer. */
SvIV_please(TOPm1s);
if (SvIOK(TOPm1s)) {
bool auvok = SvUOK(TOPm1s);
bool buvok = SvUOK(TOPs);
- if (!auvok && !buvok) { /* ## IV == IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
-
- SP--;
- SETs(boolSV(aiv == biv));
- RETURN;
- }
- if (auvok && buvok) { /* ## UV == UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
+ if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
+ /* Casting IV to UV before comparison isn't going to matter
+ on 2s complement. On 1s complement or sign&magnitude
+ (if we have any of them) it could to make negative zero
+ differ from normal zero. As I understand it. (Need to
+ check - is negative zero implementation defined behaviour
+ anyway?). NWC */
+ UV buv = SvUVX(POPs);
+ UV auv = SvUVX(TOPs);
- SP--;
SETs(boolSV(auv == buv));
RETURN;
}
{ /* ## Mixed IV,UV ## */
+ SV *ivp, *uvp;
IV iv;
- UV uv;
- /* == is commutative so swap if needed (save code) */
+ /* == is commutative so doesn't matter which is left or right */
if (auvok) {
- /* swap. top of stack (b) is the iv */
- iv = SvIVX(TOPs);
- SP--;
- if (iv < 0) {
- /* As (a) is a UV, it's >0, so it cannot be == */
- SETs(&PL_sv_no);
- RETURN;
- }
- uv = SvUVX(TOPs);
- } else {
- iv = SvIVX(TOPm1s);
- SP--;
- if (iv < 0) {
- /* As (b) is a UV, it's >0, so it cannot be == */
- SETs(&PL_sv_no);
- RETURN;
- }
- uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
- }
+ /* top of stack (b) is the iv */
+ ivp = *SP;
+ uvp = *--SP;
+ } else {
+ uvp = *SP;
+ ivp = *--SP;
+ }
+ iv = SvIVX(ivp);
+ if (iv < 0) {
+ /* As uv is a UV, it's >0, so it cannot be == */
+ SETs(&PL_sv_no);
+ RETURN;
+ }
/* we know iv is >= 0 */
- if (uv > (UV) IV_MAX) {
- SETs(&PL_sv_no);
- RETURN;
- }
- SETs(boolSV((UV)iv == uv));
+ SETs(boolSV((UV)iv == SvUVX(uvp)));
RETURN;
}
}
PP(pp_preinc)
{
dSP;
- if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) > SVt_PVLV)
DIE(aTHX_ PL_no_modify);
- if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
- SvIVX(TOPs) != IV_MAX)
+ if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ && SvIVX(TOPs) != IV_MAX)
{
++SvIVX(TOPs);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
- register UV auv;
- bool auvok;
+ register UV auv = 0;
+ bool auvok = FALSE;
bool a_valid = 0;
if (!useleft) {
buv = (UV)-biv;
}
/* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
- else "IV" now, independant of how it came in.
+ else "IV" now, independent of how it came in.
if a, b represents positive, A, B negative, a maps to -A etc
a + b => (a + b)
A + b => -(a - b)
gv = (GV*)*++MARK;
else
gv = PL_defoutgv;
- if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
+
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
had_magic:
if (MARK == ORIGMARK) {
/* If using default handle then we need to make space to
++SP;
}
PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj((SV*)gv, mg);
+ *MARK = SvTIED_obj((SV*)io, mg);
PUTBACK;
ENTER;
call_method("PRINT", G_SCALAR);
RETURN;
}
if (!(io = GvIO(gv))) {
- if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
+ if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
(SvTYPE(SvRV(*relem)) == SVt_PVAV ||
SvTYPE(SvRV(*relem)) == SVt_PVHV))
{
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Reference found where even-sized list expected");
}
else
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Odd number of elements in hash assignment");
}
if (SvTYPE(hash) == SVt_PVAV) {
register PMOP *pm = cPMOP;
SV *rv = sv_newmortal();
SV *sv = newSVrv(rv, "Regexp");
- sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
+ if (pm->op_pmdynflags & PMdf_TAINTED)
+ SvTAINTED_on(rv);
+ sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
RETURNX(PUSHs(rv));
}
{
dSP; dTARG;
register PMOP *pm = cPMOP;
+ PMOP *dynpm = pm;
register char *t;
register char *s;
char *strend;
I32 global;
I32 r_flags = REXEC_CHECKED;
char *truebase; /* Start of string */
- register REGEXP *rx = pm->op_pmregexp;
+ register REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
I32 gimme = GIMME;
STRLEN len;
TARG = DEFSV;
EXTEND(SP,1);
}
- PL_reg_sv = TARG;
+
PUTBACK; /* EVAL blocks need stack_sp. */
s = SvPV(TARG, len);
strend = s + len;
(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
+ PL_reg_match_utf8 = DO_UTF8(TARG);
+
+ /* PMdf_USED is set after a ?? matches once */
if (pm->op_pmdynflags & PMdf_USED) {
failure:
if (gimme == G_ARRAY)
RETPUSHNO;
}
+ /* empty pattern special-cased to use last successful pattern if possible */
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
- rx = pm->op_pmregexp;
+ rx = PM_GETRE(pm);
}
- if (rx->minlen > len) goto failure;
+
+ if (rx->minlen > len)
+ goto failure;
truebase = t = s;
/* XXXX What part of this is needed with true \G-support? */
- if ((global = pm->op_pmflags & PMf_GLOBAL)) {
+ if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
rx->startp[0] = -1;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
- MAGIC* mg = mg_find(TARG, 'g');
+ MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
if (!(rx->reganch & ROPT_GPOS_SEEN))
rx->endp[0] = rx->startp[0] = mg->mg_len;
}
if (rx->reganch & RE_USE_INTUIT &&
DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
+ PL_bostr = truebase;
s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
if (!s)
if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
{
PL_curpm = pm;
- if (pm->op_pmflags & PMf_ONCE)
- pm->op_pmdynflags |= PMdf_USED;
+ if (dynpm->op_pmflags & PMf_ONCE)
+ dynpm->op_pmdynflags |= PMdf_USED;
goto gotcha;
}
else
/*SUPPRESS 560*/
if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
len = rx->endp[i] - rx->startp[i];
+ if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
+ len < 0 || len > strend - s)
+ DIE(aTHX_ "panic: pp_match start/end pointers");
s = rx->startp[i] + truebase;
sv_setpvn(*SP, s, len);
- if (DO_UTF8(TARG))
+ if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
SvUTF8_on(*SP);
}
}
if (global) {
+ if (dynpm->op_pmflags & PMf_CONTINUE) {
+ MAGIC* mg = 0;
+ if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
+ mg = mg_find(TARG, PERL_MAGIC_regex_global);
+ if (!mg) {
+ sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
+ mg = mg_find(TARG, PERL_MAGIC_regex_global);
+ }
+ if (rx->startp[0] != -1) {
+ mg->mg_len = rx->endp[0];
+ if (rx->startp[0] == rx->endp[0])
+ mg->mg_flags |= MGf_MINMATCH;
+ else
+ mg->mg_flags &= ~MGf_MINMATCH;
+ }
+ }
had_zerolen = (rx->startp[0] != -1
&& rx->startp[0] == rx->endp[0]);
PUTBACK; /* EVAL blocks may use stack */
if (global) {
MAGIC* mg = 0;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
- mg = mg_find(TARG, 'g');
+ mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (!mg) {
- sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
- mg = mg_find(TARG, 'g');
+ sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
+ mg = mg_find(TARG, PERL_MAGIC_regex_global);
}
if (rx->startp[0] != -1) {
mg->mg_len = rx->endp[0];
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
PL_curpm = pm;
- if (pm->op_pmflags & PMf_ONCE)
- pm->op_pmdynflags |= PMdf_USED;
+ if (dynpm->op_pmflags & PMf_ONCE)
+ dynpm->op_pmdynflags |= PMdf_USED;
if (RX_MATCH_COPIED(rx))
Safefree(rx->subbeg);
RX_MATCH_COPIED_off(rx);
if (global) {
rx->subbeg = truebase;
rx->startp[0] = s - truebase;
- if (DO_UTF8(PL_reg_sv)) {
+ if (PL_reg_match_utf8) {
char *t = (char*)utf8_hop((U8*)s, rx->minlen);
rx->endp[0] = t - truebase;
}
nope:
ret_no:
- if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
+ if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
- MAGIC* mg = mg_find(TARG, 'g');
+ MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg)
mg->mg_len = -1;
}
I32 gimme = GIMME_V;
MAGIC *mg;
- if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
+ if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
+ XPUSHs(SvTIED_obj((SV*)io, mg));
PUTBACK;
ENTER;
call_method("READLINE", gimme);
if (ckWARN2(WARN_GLOB, WARN_CLOSED)
&& (!io || !(IoFLAGS(io) & IOf_START))) {
if (type == OP_GLOB)
- Perl_warner(aTHX_ WARN_GLOB,
+ Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (can't start child: %s)",
Strerror(errno));
else
}
else if (type == OP_GLOB) {
if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
- Perl_warner(aTHX_ WARN_GLOB,
+ Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (child exited with status %d%s)",
(int)(STATUS_CURRENT >> 8),
(STATUS_CURRENT & 0x80) ? ", core dumped" : "");
U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
- I32 preeminent;
+ I32 preeminent = 0;
if (SvTYPE(hv) == SVt_PVHV) {
if (PL_op->op_private & OPpLVAL_INTRO)
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
- sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
+ sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
SvREFCNT_dec(key2); /* sv_magic() increments refcount */
LvTARG(lv) = SvREFCNT_inc(hv);
LvTARGLEN(lv) = 1;
SP = newsp;
else if (gimme == G_SCALAR) {
MARK = newsp + 1;
- if (MARK <= SP)
+ if (MARK <= SP) {
if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
*MARK = TOPs;
else
*MARK = sv_mortalcopy(TOPs);
- else {
+ } else {
MEXTEND(mark,0);
*MARK = &PL_sv_undef;
}
STRLEN maxlen;
char *max = SvPV((SV*)av, maxlen);
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
-#ifndef USE_THREADS /* don't risk potential race */
+#ifndef USE_5005THREADS /* don't risk potential race */
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
sv_setsv(*itersvp, cur);
if (cx->blk_loop.iterix > cx->blk_loop.itermax)
RETPUSHNO;
-#ifndef USE_THREADS /* don't risk potential race */
+#ifndef USE_5005THREADS /* don't risk potential race */
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
sv_setiv(*itersvp, cx->blk_loop.iterix++);
SvREFCNT_dec(*itersvp);
- if ((sv = SvMAGICAL(av)
- ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
- : AvARRAY(av)[++cx->blk_loop.iterix]))
+ if (SvMAGICAL(av) || AvREIFY(av)) {
+ SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
+ if (svp)
+ sv = *svp;
+ else
+ sv = Nullsv;
+ }
+ else {
+ sv = AvARRAY(av)[++cx->blk_loop.iterix];
+ }
+ if (sv)
SvTEMP_off(sv);
else
sv = &PL_sv_undef;
- if (av != PL_curstack && SvIMMORTAL(sv)) {
+ if (av != PL_curstack && sv == &PL_sv_undef) {
SV *lv = cx->blk_loop.iterlval;
if (lv && SvREFCNT(lv) > 1) {
SvREFCNT_dec(lv);
lv = cx->blk_loop.iterlval = NEWSV(26, 0);
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
- sv_magic(lv, Nullsv, 'y', Nullch, 0);
+ sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
}
LvTARG(lv) = SvREFCNT_inc(av);
LvTARGOFF(lv) = cx->blk_loop.iterix;
bool rxtainted;
char *orig;
I32 r_flags;
- register REGEXP *rx = pm->op_pmregexp;
+ register REGEXP *rx = PM_GETRE(pm);
STRLEN len;
int force_on_match = 0;
I32 oldsave = PL_savestack_ix;
- bool do_utf8;
STRLEN slen;
+ bool doutf8 = FALSE;
/* known replacement string? */
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
TARG = DEFSV;
EXTEND(SP,1);
}
- PL_reg_sv = TARG;
- do_utf8 = DO_UTF8(PL_reg_sv);
+
if (SvFAKE(TARG) && SvREADONLY(TARG))
sv_force_normal(TARG);
if (SvREADONLY(TARG)
rxtainted |= 2;
TAINT_NOT;
+ PL_reg_match_utf8 = DO_UTF8(TARG);
+
force_it:
if (!pm || !s)
DIE(aTHX_ "panic: pp_subst");
strend = s + len;
- slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
+ slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
maxiters = 2 * slen + 10; /* We can match twice at each
position, once with zero-length,
second time with non-zero. */
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
- rx = pm->op_pmregexp;
+ rx = PM_GETRE(pm);
}
r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
? REXEC_COPY_STR : 0;
}
orig = m = s;
if (rx->reganch & RE_USE_INTUIT) {
+ PL_bostr = orig;
s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
if (!s)
once = !(rpm->op_pmflags & PMf_GLOBAL);
/* known replacement string? */
- c = dstr ? SvPV(dstr, clen) : Nullch;
-
+ if (dstr) {
+ c = SvPV(dstr, clen);
+ doutf8 = DO_UTF8(dstr);
+ }
+ else {
+ c = Nullch;
+ doutf8 = FALSE;
+ }
+
/* can do inplace substitution? */
if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
r_flags | REXEC_CHECKED))
{
- bool isutf8;
-
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
SvPVX(TARG) = SvPVX(dstr);
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
- isutf8 = DO_UTF8(dstr);
+ doutf8 |= DO_UTF8(dstr);
SvPVX(dstr) = 0;
sv_free(dstr);
PUSHs(sv_2mortal(newSViv((I32)iters)));
(void)SvPOK_only(TARG);
- if (isutf8)
+ if (doutf8)
SvUTF8_on(TARG);
TAINT_IF(rxtainted);
SvSETMAGIC(TARG);
else if (gimme == G_ARRAY) {
EXTEND_MORTAL(SP - newsp);
for (mark = newsp + 1; mark <= SP; mark++) {
- if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+ if (*mark != &PL_sv_undef
+ && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
/* Might be flattened array after $#array = */
PUTBACK;
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVE;
LEAVESUB(sv);
- DIE(aTHX_ "Can't return %s from lvalue subroutine",
- (*mark != &PL_sv_undef)
- ? (SvREADONLY(TOPs)
- ? "a readonly value" : "a temporary")
- : "an uninitialized value");
+ DIE(aTHX_ "Can't return a %s from lvalue subroutine",
+ SvREADONLY(TOPs) ? "readonly value" : "temporary");
}
else {
/* Can be a localized value subject to deletion. */
}
if (SvGMAGICAL(sv)) {
mg_get(sv);
+ if (SvROK(sv))
+ goto got_rv;
sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
}
else
cv = get_cv(sym, TRUE);
break;
}
+ got_rv:
{
SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
tryAMAGICunDEREF(to_cv);
DIE(aTHX_ "No DBsub routine");
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
/*
* First we need to check if the sub or method requires locking.
* If so, we gain a lock on the CV, the first argument or the
COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
MgOWNER(mg) = thr;
DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
- thr, sv);)
+ thr, sv));
MUTEX_UNLOCK(MgMUTEXP(mg));
SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
}
}
DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
- CvDEPTH(cv)););
+ CvDEPTH(cv)));
SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
}
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
if (CvXSUB(cv)) {
#ifdef PERL_XSUB_OLDSTYLE
* back. This would allow popping @_ in XSUB, e.g.. XXXX */
AV* av;
I32 items;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
av = (AV*)PL_curpad[0];
#else
av = GvAV(PL_defgv);
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
items = AvFILLp(av) + 1; /* @_ is not tieable */
if (items) {
PL_curcopdb = NULL;
}
/* Do we need to open block here? XXXX */
- (void)(*CvXSUB(cv))(aTHXo_ cv);
+ (void)(*CvXSUB(cv))(aTHX_ cv);
/* Enforce some sanity in scalar context. */
if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
svp = AvARRAY(padlist);
}
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
if (!hasargs) {
AV* av = (AV*)PL_curpad[0];
PUTBACK ;
}
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
SAVEVPTR(PL_curpad);
PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
-#ifndef USE_THREADS
+#ifndef USE_5005THREADS
if (hasargs)
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
{
AV* av;
SV** ary;
AvREAL_off(av);
AvREIFY_on(av);
}
-#ifndef USE_THREADS
+#ifndef USE_5005THREADS
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
cx->blk_sub.oldcurpad = PL_curpad;
cx->blk_sub.argarray = av;
++MARK;
Perl_sub_crush_depth(pTHX_ CV *cv)
{
if (CvANON(cv))
- Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
+ Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
SV* tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
- Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
+ Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
SvPVX(tmpstr));
}
}
SV *sv;
if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
if (elem > 0)
elem -= PL_curcop->cop_arybase;
if (SvTYPE(av) != SVt_PVAV)
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
- sv_magic(lv, Nullsv, 'y', Nullch, 0);
+ sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
LvTARG(lv) = SvREFCNT_inc(av);
LvTARGOFF(lv) = elem;
LvTARGLEN(lv) = 1;
HV* stash;
char* name;
STRLEN namelen;
- char* packname;
+ char* packname = 0;
STRLEN packlen;
name = SvPV(meth, namelen);
Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
if (SvGMAGICAL(sv))
- mg_get(sv);
+ mg_get(sv);
if (SvROK(sv))
ob = (SV*)SvRV(sv);
else {
GV* iogv;
+ /* this isn't a reference */
packname = Nullch;
if (!SvOK(sv) ||
!(packname = SvPV(sv, packlen)) ||
!(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
+ /* this isn't the name of a filehandle either */
if (!packname ||
((UTF8_IS_START(*packname) && DO_UTF8(sv))
? !isIDFIRST_utf8((U8*)packname)
SvOK(sv) ? "without a package or object reference"
: "on an undefined value");
}
- stash = gv_stashpvn(packname, packlen, TRUE);
+ /* assume it's a package name */
+ stash = gv_stashpvn(packname, packlen, FALSE);
goto fetch;
}
+ /* it _is_ a filehandle name -- replace with a reference */
*(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
}
+ /* if we got here, ob should be a reference or a glob */
if (!ob || !(SvOBJECT(ob)
|| (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
&& SvOBJECT(ob))))
stash = SvSTASH(ob);
fetch:
+ /* NOTE: stash may be null, hope hv_fetch_ent and
+ gv_fetchmethod can cope (it seems they can) */
+
/* shortcut for simple names */
if (hashp) {
HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
}
gv = gv_fetchmethod(stash, name);
+
if (!gv) {
+ /* This code tries to figure out just what went wrong with
+ gv_fetchmethod. It therefore needs to duplicate a lot of
+ the internals of that function. We can't move it inside
+ Perl_gv_fetchmethod_autoload(), however, since that would
+ cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
+ don't want that.
+ */
char* leaf = name;
char* sep = Nullch;
char* p;
- GV* gv;
for (p = name; *p; p++) {
if (*p == '\'')
sep = p, leaf = p + 2;
}
if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
- packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
+ /* the method name is unqualified or starts with SUPER:: */
+ packname = sep ? CopSTASHPV(PL_curcop) :
+ stash ? HvNAME(stash) : packname;
packlen = strlen(packname);
}
else {
+ /* the method name is qualified */
packname = name;
packlen = sep - name;
}
- gv = gv_fetchpv(packname, 0, SVt_PVHV);
- if (gv && isGV(gv)) {
+
+ /* we're relying on gv_fetchmethod not autovivifying the stash */
+ if (gv_stashpvn(packname, packlen, FALSE)) {
Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%s\"",
- leaf, packname);
+ "Can't locate object method \"%s\" via package \"%.*s\"",
+ leaf, (int)packlen, packname);
}
else {
Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%s\""
- " (perhaps you forgot to load \"%s\"?)",
- leaf, packname, packname);
+ "Can't locate object method \"%s\" via package \"%.*s\""
+ " (perhaps you forgot to load \"%.*s\"?)",
+ leaf, (int)packlen, packname, (int)packlen, packname);
}
}
return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
static void
-unset_cvowner(pTHXo_ void *cvarg)
+unset_cvowner(pTHX_ void *cvarg)
{
register CV* cv = (CV *) cvarg;
MUTEX_LOCK(CvMUTEXP(cv));
DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
- CvDEPTH(cv)););
+ CvDEPTH(cv)));
assert(thr == CvOWNER(cv));
CvOWNER(cv) = 0;
MUTEX_UNLOCK(CvMUTEXP(cv));
SvREFCNT_dec(cv);
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
https://perl5.git.perl.org / perl5.git / blobdiff