/* pp_hot.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, 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.
char *s;
s = SvPV(TOPs,len);
sv_setpvn(TARG,s,len);
- if (SvUTF8(TOPs) && !IN_BYTE)
+ if (SvUTF8(TOPs))
SvUTF8_on(TARG);
+ else
+ SvUTF8_off(TARG);
SETTARG;
RETURN;
}
djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
{
dPOPTOPssrl;
- STRLEN len;
- U8 *s;
- bool left_utf8;
- bool right_utf8;
+ SV* rcopy = Nullsv;
- if (TARG == right && SvGMAGICAL(right))
- mg_get(right);
if (SvGMAGICAL(left))
mg_get(left);
+ if (TARG == right && SvGMAGICAL(right))
+ mg_get(right);
- left_utf8 = DO_UTF8(left);
- right_utf8 = DO_UTF8(right);
-
- if (left_utf8 != right_utf8) {
- if (TARG == right && !right_utf8) {
- sv_utf8_upgrade(TARG); /* Now straight binary copy */
- SvUTF8_on(TARG);
- }
- else {
- /* Set TARG to PV(left), then add right */
- U8 *l, *c, *olds = NULL;
- STRLEN targlen;
- s = (U8*)SvPV(right,len);
- right_utf8 |= DO_UTF8(right);
- if (TARG == right) {
- /* Take a copy since we're about to overwrite TARG */
- olds = s = (U8*)savepvn((char*)s, len);
- }
- if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) {
- if (SvREADONLY(left))
- left = sv_2mortal(newSVsv(left));
- else
- sv_setpv(left, ""); /* Suppress warning. */
- }
- l = (U8*)SvPV(left, targlen);
- left_utf8 |= DO_UTF8(left);
- if (TARG != left)
- sv_setpvn(TARG, (char*)l, targlen);
- if (!left_utf8)
- sv_utf8_upgrade(TARG);
- /* Extend TARG to length of right (s) */
- targlen = SvCUR(TARG) + len;
- if (!right_utf8) {
- /* plus one for each hi-byte char if we have to upgrade */
- for (c = s; c < s + len; c++) {
- if (UTF8_IS_CONTINUED(*c))
- targlen++;
- }
- }
- SvGROW(TARG, targlen+1);
- /* And now copy, maybe upgrading right to UTF8 on the fly */
- if (right_utf8)
- Copy(s, SvEND(TARG), len, U8);
- else {
- for (c = (U8*)SvEND(TARG); len--; s++)
- c = uv_to_utf8(c, *s);
- }
- SvCUR_set(TARG, targlen);
- *SvEND(TARG) = '\0';
- SvUTF8_on(TARG);
- SETs(TARG);
- Safefree(olds);
- RETURN;
- }
- }
-
- if (TARG != left) {
- s = (U8*)SvPV(left,len);
- if (TARG == right) {
- sv_insert(TARG, 0, 0, (char*)s, len);
- SETs(TARG);
- RETURN;
+ 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);
}
- sv_setpvn(TARG, (char *)s, len);
+ else /* $right = $left . $right; */
+ sv_catsv(TARG, rcopy);
+ }
+ else {
+ if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
+ sv_setpv(TARG, "");
+ /* $other = $left . $right; */
+ /* $left = $left . $right; */
+ sv_catsv(TARG, right);
}
- else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG)
- sv_setpv(TARG, ""); /* Suppress warning. */
- s = (U8*)SvPV(right,len);
- if (SvOK(TARG)) {
+
#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])))
- {
- Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
- "about to append an integer to '19'");
- }
+ 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])))
+ {
+ Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
+ "about to append an integer to '19'");
}
-#endif
- sv_catpvn(TARG, (char *)s, len);
}
- else
- sv_setpvn(TARG, (char *)s, len); /* suppress warning */
- if (left_utf8)
- SvUTF8_on(TARG);
+#endif
+
SETTARG;
RETURN;
}
PP(pp_eq)
{
djSP; tryAMAGICbinSET(eq,0);
+#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. */
+ 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);
+
+ SP--;
+ SETs(boolSV(auv == buv));
+ RETURN;
+ }
+ { /* ## Mixed IV,UV ## */
+ IV iv;
+ UV uv;
+
+ /* == is commutative so swap if needed (save code) */
+ 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() ? */
+ }
+ /* we know iv is >= 0 */
+ if (uv > (UV) IV_MAX) {
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ SETs(boolSV((UV)iv == uv));
+ RETURN;
+ }
+ }
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn == value));
++SvIVX(TOPs);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
- else
+ else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
sv_inc(TOPs);
SvSETMAGIC(TOPs);
return NORMAL;
PP(pp_add)
{
- djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
+ useleft = USE_LEFT(TOPm1s);
+#ifdef PERL_PRESERVE_IVUV
+ /* We must see if we can perform the addition with integers if possible,
+ as the integer code detects overflow while the NV code doesn't.
+ If either argument hasn't had a numeric conversion yet attempt to get
+ the IV. It's important to do this now, rather than just assuming that
+ it's not IOK as a PV of "9223372036854775806" may not take well to NV
+ addition, and an SV which is NOK, NV=6.0 ought to be coerced to
+ integer in case the second argument is IV=9223372036854775806
+ We can (now) rely on sv_2iv to do the right thing, only setting the
+ public IOK flag if the value in the NV (or PV) slot is truly integer.
+
+ A side effect is that this also aggressively prefers integer maths over
+ fp maths for integer values.
+
+ How to detect overflow?
+
+ C 99 section 6.2.6.1 says
+
+ The range of nonnegative values of a signed integer type is a subrange
+ of the corresponding unsigned integer type, and the representation of
+ the same value in each type is the same. A computation involving
+ unsigned operands can never overflow, because a result that cannot be
+ represented by the resulting unsigned integer type is reduced modulo
+ the number that is one greater than the largest value that can be
+ represented by the resulting type.
+
+ (the 9th paragraph)
+
+ which I read as "unsigned ints wrap."
+
+ signed integer overflow seems to be classed as "exception condition"
+
+ If an exceptional condition occurs during the evaluation of an
+ expression (that is, if the result is not mathematically defined or not
+ in the range of representable values for its type), the behavior is
+ undefined.
+
+ (6.5, the 5th paragraph)
+
+ I had assumed that on 2s complement machines signed arithmetic would
+ wrap, hence coded pp_add and pp_subtract on the assumption that
+ everything perl builds on would be happy. After much wailing and
+ gnashing of teeth it would seem that irix64 knows its ANSI spec well,
+ knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
+ unsigned code below is actually shorter than the old code. :-)
+ */
+
+ 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. */
+ register UV auv;
+ bool auvok;
+ bool a_valid = 0;
+
+ if (!useleft) {
+ auv = 0;
+ a_valid = auvok = 1;
+ /* left operand is undef, treat as zero. + 0 is identity,
+ Could SETi or SETu right now, but space optimise by not adding
+ lots of code to speed up what is probably a rarish case. */
+ } else {
+ /* Left operand is defined, so is it IV? */
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ if ((auvok = SvUOK(TOPm1s)))
+ auv = SvUVX(TOPm1s);
+ else {
+ register IV aiv = SvIVX(TOPm1s);
+ if (aiv >= 0) {
+ auv = aiv;
+ auvok = 1; /* Now acting as a sign flag. */
+ } else { /* 2s complement assumption for IV_MIN */
+ auv = (UV)-aiv;
+ }
+ }
+ a_valid = 1;
+ }
+ }
+ if (a_valid) {
+ bool result_good = 0;
+ UV result;
+ register UV buv;
+ bool buvok = SvUOK(TOPs);
+
+ if (buvok)
+ buv = SvUVX(TOPs);
+ else {
+ register IV biv = SvIVX(TOPs);
+ if (biv >= 0) {
+ buv = biv;
+ buvok = 1;
+ } else
+ 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.
+ if a, b represents positive, A, B negative, a maps to -A etc
+ a + b => (a + b)
+ A + b => -(a - b)
+ a + B => (a - b)
+ A + B => -(a + b)
+ all UV maths. negate result if A negative.
+ add if signs same, subtract if signs differ. */
+
+ if (auvok ^ buvok) {
+ /* Signs differ. */
+ if (auv >= buv) {
+ result = auv - buv;
+ /* Must get smaller */
+ if (result <= auv)
+ result_good = 1;
+ } else {
+ result = buv - auv;
+ if (result <= buv) {
+ /* result really should be -(auv-buv). as its negation
+ of true value, need to swap our result flag */
+ auvok = !auvok;
+ result_good = 1;
+ }
+ }
+ } else {
+ /* Signs same */
+ result = auv + buv;
+ if (result >= auv)
+ result_good = 1;
+ }
+ if (result_good) {
+ SP--;
+ if (auvok)
+ SETu( result );
+ else {
+ /* Negate result */
+ if (result <= (UV)IV_MIN)
+ SETi( -(IV)result );
+ else {
+ /* result valid, but out of range for IV. */
+ SETn( -(NV)result );
+ }
+ }
+ RETURN;
+ } /* Overflow, drop through to NVs. */
+ }
+ }
+#endif
{
- dPOPTOPnnrl_ul;
- SETn( left + right );
- RETURN;
+ dPOPnv;
+ if (!useleft) {
+ /* left operand is undef, treat as zero. + 0.0 is identity. */
+ SETn(value);
+ RETURN;
+ }
+ SETn( value + TOPn );
+ RETURN;
}
}
IO *io;
register PerlIO *fp;
MAGIC *mg;
- STRLEN n_a;
if (PL_op->op_flags & OPf_STACKED)
gv = (GV*)*++MARK;
SETs((SV*)av);
RETURN;
}
+ else if (LVRET) {
+ if (GIMME == G_SCALAR)
+ Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
+ SETs((SV*)av);
+ RETURN;
+ }
}
else {
if (SvTYPE(sv) == SVt_PVAV) {
SETs((SV*)av);
RETURN;
}
+ else if (LVRET) {
+ if (GIMME == G_SCALAR)
+ Perl_croak(aTHX_ "Can't return array to lvalue"
+ " scalar context");
+ SETs((SV*)av);
+ RETURN;
+ }
}
else {
GV *gv;
SETs((SV*)av);
RETURN;
}
+ else if (LVRET) {
+ if (GIMME == G_SCALAR)
+ Perl_croak(aTHX_ "Can't return array to lvalue"
+ " scalar context");
+ SETs((SV*)av);
+ RETURN;
+ }
}
}
SETs((SV*)hv);
RETURN;
}
+ else if (LVRET) {
+ if (GIMME == G_SCALAR)
+ Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
+ SETs((SV*)hv);
+ RETURN;
+ }
}
else {
if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
SETs((SV*)hv);
RETURN;
}
+ else if (LVRET) {
+ if (GIMME == G_SCALAR)
+ Perl_croak(aTHX_ "Can't return hash to lvalue"
+ " scalar context");
+ SETs((SV*)hv);
+ RETURN;
+ }
}
else {
GV *gv;
SETs((SV*)hv);
RETURN;
}
+ else if (LVRET) {
+ if (GIMME == G_SCALAR)
+ Perl_croak(aTHX_ "Can't return hash to lvalue"
+ " scalar context");
+ SETs((SV*)hv);
+ RETURN;
+ }
}
}
TARG = DEFSV;
EXTEND(SP,1);
}
+ PL_reg_sv = TARG;
PUTBACK; /* EVAL blocks need stack_sp. */
s = SvPV(TARG, len);
strend = s + len;
if (!s)
- DIE(aTHX_ "panic: do_match");
+ DIE(aTHX_ "panic: pp_match");
rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
if (update_minmatch++)
minmatch = had_zerolen;
}
- if (rx->reganch & RE_USE_INTUIT) {
+ if (rx->reganch & RE_USE_INTUIT &&
+ DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
if (!s)
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
if (gimme == G_ARRAY) {
- I32 iters, i, len;
+ I32 nparens, i, len;
- iters = rx->nparens;
- if (global && !iters)
+ nparens = rx->nparens;
+ if (global && !nparens)
i = 1;
else
i = 0;
SPAGAIN; /* EVAL blocks could move the stack. */
- EXTEND(SP, iters + i);
- EXTEND_MORTAL(iters + i);
- for (i = !i; i <= iters; i++) {
+ EXTEND(SP, nparens + i);
+ EXTEND_MORTAL(nparens + i);
+ for (i = !i; i <= nparens; i++) {
PUSHs(sv_newmortal());
/*SUPPRESS 560*/
if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
len = rx->endp[i] - rx->startp[i];
s = rx->startp[i] + truebase;
sv_setpvn(*SP, s, len);
- if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) {
+ if (DO_UTF8(TARG))
SvUTF8_on(*SP);
- sv_utf8_downgrade(*SP, TRUE);
- }
}
}
if (global) {
r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
goto play_it_again;
}
- else if (!iters)
+ else if (!nparens)
XPUSHs(&PL_sv_yes);
LEAVE_SCOPE(oldsave);
RETURN;
if (global) {
rx->subbeg = truebase;
rx->startp[0] = s - truebase;
- rx->endp[0] = s - truebase + rx->minlen;
+ if (DO_UTF8(PL_reg_sv)) {
+ char *t = (char*)utf8_hop((U8*)s, rx->minlen);
+ rx->endp[0] = t - truebase;
+ }
+ else {
+ rx->endp[0] = s - truebase + rx->minlen;
+ }
rx->sublen = strend - truebase;
goto gotcha;
}
SV **svp;
SV *keysv = POPs;
HV *hv = (HV*)POPs;
- U32 lval = PL_op->op_flags & OPf_MOD;
+ U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
if (!preeminent) {
STRLEN keylen;
char *key = SvPV(keysv, keylen);
- save_delete(hv, key, keylen);
- } else
+ SAVEDELETE(hv, savepvn(key,keylen), keylen);
+ } else
save_helem(hv, keysv, svp);
}
}
STRLEN len;
int force_on_match = 0;
I32 oldsave = PL_savestack_ix;
+ bool do_utf8;
+ STRLEN slen;
/* 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)
force_it:
if (!pm || !s)
- DIE(aTHX_ "panic: do_subst");
+ DIE(aTHX_ "panic: pp_subst");
strend = s + len;
- maxiters = 2*(strend - s) + 10; /* We can match twice at each
- position, once with zero-length,
- second time with non-zero. */
+ slen = do_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;
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);
rxtainted |= RX_MATCH_TAINTED(rx);
dstr = NEWSV(25, len);
sv_setpvn(dstr, m, s-m);
+ if (DO_UTF8(TARG))
+ SvUTF8_on(dstr);
PL_curpm = pm;
if (!c) {
register PERL_CONTEXT *cx;
sv_catpvn(dstr, c, clen);
if (once)
break;
- } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags));
+ } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
+ TARG, NULL, r_flags));
sv_catpvn(dstr, s, strend - s);
(void)SvOOK_off(TARG);
SvPVX(TARG) = SvPVX(dstr);
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
+ isutf8 = DO_UTF8(dstr);
SvPVX(dstr) = 0;
sv_free(dstr);
PUSHs(sv_2mortal(newSViv((I32)iters)));
(void)SvPOK_only(TARG);
+ if (isutf8)
+ SvUTF8_on(TARG);
TAINT_IF(rxtainted);
SvSETMAGIC(TARG);
SvTAINT(TARG);
{
djSP;
SV** svp;
- IV elem = POPi;
+ SV* elemsv = POPs;
+ IV elem = SvIV(elemsv);
AV* av = (AV*)POPs;
- U32 lval = PL_op->op_flags & OPf_MOD;
+ U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
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));
if (elem > 0)
elem -= PL_curcop->cop_arybase;
if (SvTYPE(av) != SVt_PVAV)
!(ob=(SV*)GvIO(iogv)))
{
if (!packname ||
- ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
+ ((UTF8_IS_START(*packname) && DO_UTF8(sv))
? !isIDFIRST_utf8((U8*)packname)
: !isIDFIRST(*packname)
))
projects / p5sagit/p5-mst-13.2.git / blobdiff