X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=e1c9d660f7af3ac87f011706daff53c6c4b90e75;hb=333f433b6bc052819c91a73e390fb65b29161409;hp=d30489149e054c6909138ef289640dbdf5a1e8ac;hpb=3280af22f58e7b37514ed104858e2c2fc55ceeeb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index d304891..e1c9d66 100644 --- a/pp.c +++ b/pp.c @@ -141,10 +141,10 @@ PP(pp_scalar) PP(pp_padav) { djSP; dTARGET; - if (op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(PL_curpad[op->op_targ]); + if (PL_op->op_private & OPpLVAL_INTRO) + SAVECLEARSV(PL_curpad[PL_op->op_targ]); EXTEND(SP, 1); - if (op->op_flags & OPf_REF) { + if (PL_op->op_flags & OPf_REF) { PUSHs(TARG); RETURN; } @@ -178,9 +178,9 @@ PP(pp_padhv) I32 gimme; XPUSHs(TARG); - if (op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(PL_curpad[op->op_targ]); - if (op->op_flags & OPf_REF) + if (PL_op->op_private & OPpLVAL_INTRO) + SAVECLEARSV(PL_curpad[PL_op->op_targ]); + if (PL_op->op_flags & OPf_REF) RETURN; gimme = GIMME_V; if (gimme == G_ARRAY) { @@ -231,21 +231,21 @@ PP(pp_rv2gv) goto wasref; } if (!SvOK(sv)) { - if (op->op_flags & OPf_REF || - op->op_private & HINT_STRICT_REFS) + if (PL_op->op_flags & OPf_REF || + PL_op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a symbol"); - if (PL_dowarn) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, warn_uninit); RETSETUNDEF; } sym = SvPV(sv, PL_na); - if (op->op_private & HINT_STRICT_REFS) + if (PL_op->op_private & HINT_STRICT_REFS) DIE(no_symref, sym, "a symbol"); sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); } } - if (op->op_private & OPpLVAL_INTRO) - save_gp((GV*)sv, !(op->op_flags & OPf_SPECIAL)); + if (PL_op->op_private & OPpLVAL_INTRO) + save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL)); SETs(sv); RETURN; } @@ -275,25 +275,25 @@ PP(pp_rv2sv) goto wasref; } if (!SvOK(sv)) { - if (op->op_flags & OPf_REF || - op->op_private & HINT_STRICT_REFS) + if (PL_op->op_flags & OPf_REF || + PL_op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a SCALAR"); - if (PL_dowarn) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, warn_uninit); RETSETUNDEF; } sym = SvPV(sv, PL_na); - if (op->op_private & HINT_STRICT_REFS) + if (PL_op->op_private & HINT_STRICT_REFS) DIE(no_symref, sym, "a SCALAR"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); } sv = GvSV(gv); } - if (op->op_flags & OPf_MOD) { - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_flags & OPf_MOD) { + if (PL_op->op_private & OPpLVAL_INTRO) sv = save_scalar((GV*)TOPs); - else if (op->op_private & OPpDEREF) - vivify_ref(sv, op->op_private & OPpDEREF); + else if (PL_op->op_private & OPpDEREF) + vivify_ref(sv, PL_op->op_private & OPpDEREF); } SETs(sv); RETURN; @@ -317,7 +317,7 @@ PP(pp_pos) { djSP; dTARGET; dPOPss; - if (op->op_flags & OPf_MOD) { + if (PL_op->op_flags & OPf_MOD) { if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, '.', Nullch, 0); @@ -338,7 +338,10 @@ PP(pp_pos) if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { mg = mg_find(sv, 'g'); if (mg && mg->mg_len >= 0) { - PUSHi(mg->mg_len + PL_curcop->cop_arybase); + I32 i = mg->mg_len; + if (IN_UTF8) + sv_pos_b2u(sv, &i); + PUSHi(i + PL_curcop->cop_arybase); RETURN; } } @@ -354,7 +357,7 @@ PP(pp_rv2cv) /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ /* (But not in defined().) */ - CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL)); + CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL)); if (cv) { if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); @@ -429,7 +432,7 @@ PP(pp_prototype) PP(pp_anoncode) { djSP; - CV* cv = (CV*)PL_curpad[op->op_targ]; + CV* cv = (CV*)PL_curpad[PL_op->op_targ]; if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); EXTEND(SP,1); @@ -517,8 +520,9 @@ PP(pp_bless) SV *ssv = POPs; STRLEN len; char *ptr = SvPV(ssv,len); - if (PL_dowarn && len == 0) - warn("Explicit blessing to '' (assuming package main)"); + if (ckWARN(WARN_UNSAFE) && len == 0) + warner(WARN_UNSAFE, + "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, TRUE); } @@ -658,14 +662,14 @@ PP(pp_trans) djSP; dTARG; SV *sv; - if (op->op_flags & OPf_STACKED) + if (PL_op->op_flags & OPf_STACKED) sv = POPs; else { sv = DEFSV; EXTEND(SP,1); } TARG = sv_newmortal(); - PUSHi(do_trans(sv, op)); + PUSHi(do_trans(sv)); RETURN; } @@ -741,7 +745,7 @@ PP(pp_undef) djSP; SV *sv; - if (!op->op_private) { + if (!PL_op->op_private) { EXTEND(SP, 1); RETPUSHUNDEF; } @@ -767,8 +771,8 @@ PP(pp_undef) hv_undef((HV*)sv); break; case SVt_PVCV: - if (PL_dowarn && cv_const_sv((CV*)sv)) - warn("Constant subroutine %s undefined", + if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv)) + warner(WARN_UNSAFE, "Constant subroutine %s undefined", CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); /* FALL THROUGH */ case SVt_PVFM: @@ -965,7 +969,7 @@ PP(pp_repeat) djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { register I32 count = POPi; - if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) { + if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; I32 items = SP - MARK; I32 max; @@ -1031,7 +1035,7 @@ PP(pp_left_shift) djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { IBW shift = POPi; - if (op->op_private & HINT_INTEGER) { + if (PL_op->op_private & HINT_INTEGER) { IBW i = TOPi; i = BWi(i) << shift; SETi(BWi(i)); @@ -1050,7 +1054,7 @@ PP(pp_right_shift) djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { IBW shift = POPi; - if (op->op_private & HINT_INTEGER) { + if (PL_op->op_private & HINT_INTEGER) { IBW i = TOPi; i = BWi(i) >> shift; SETi(BWi(i)); @@ -1141,7 +1145,7 @@ PP(pp_slt) djSP; tryAMAGICbinSET(slt,0); { dPOPTOPssrl; - int cmp = ((op->op_private & OPpLOCALE) + int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp < 0)); @@ -1154,7 +1158,7 @@ PP(pp_sgt) djSP; tryAMAGICbinSET(sgt,0); { dPOPTOPssrl; - int cmp = ((op->op_private & OPpLOCALE) + int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp > 0)); @@ -1167,7 +1171,7 @@ PP(pp_sle) djSP; tryAMAGICbinSET(sle,0); { dPOPTOPssrl; - int cmp = ((op->op_private & OPpLOCALE) + int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp <= 0)); @@ -1180,7 +1184,7 @@ PP(pp_sge) djSP; tryAMAGICbinSET(sge,0); { dPOPTOPssrl; - int cmp = ((op->op_private & OPpLOCALE) + int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp >= 0)); @@ -1213,7 +1217,7 @@ PP(pp_scmp) djSP; dTARGET; tryAMAGICbin(scmp,0); { dPOPTOPssrl; - int cmp = ((op->op_private & OPpLOCALE) + int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETi( cmp ); @@ -1227,7 +1231,7 @@ PP(pp_bit_and) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - if (op->op_private & HINT_INTEGER) { + if (PL_op->op_private & HINT_INTEGER) { IBW value = SvIV(left) & SvIV(right); SETi(BWi(value)); } @@ -1237,7 +1241,7 @@ PP(pp_bit_and) } } else { - do_vop(op->op_type, TARG, left, right); + do_vop(PL_op->op_type, TARG, left, right); SETTARG; } RETURN; @@ -1250,7 +1254,7 @@ PP(pp_bit_xor) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - if (op->op_private & HINT_INTEGER) { + if (PL_op->op_private & HINT_INTEGER) { IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); SETi(BWi(value)); } @@ -1260,7 +1264,7 @@ PP(pp_bit_xor) } } else { - do_vop(op->op_type, TARG, left, right); + do_vop(PL_op->op_type, TARG, left, right); SETTARG; } RETURN; @@ -1273,7 +1277,7 @@ PP(pp_bit_or) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { - if (op->op_private & HINT_INTEGER) { + if (PL_op->op_private & HINT_INTEGER) { IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); SETi(BWi(value)); } @@ -1283,7 +1287,7 @@ PP(pp_bit_or) } } else { - do_vop(op->op_type, TARG, left, right); + do_vop(PL_op->op_type, TARG, left, right); SETTARG; } RETURN; @@ -1337,7 +1341,7 @@ PP(pp_complement) { dTOPss; if (SvNIOKp(sv)) { - if (op->op_private & HINT_INTEGER) { + if (PL_op->op_private & HINT_INTEGER) { IBW value = ~SvIV(sv); SETi(BWi(value)); } @@ -1550,6 +1554,19 @@ PP(pp_cos) } } +/* Support Configure command-line overrides for rand() functions. + After 5.005, perhaps we should replace this by Configure support + for drand48(), random(), or rand(). For 5.005, though, maintain + compatibility by calling rand() but allow the user to override it. + See INSTALL for details. --Andy Dougherty 15 July 1998 +*/ +#ifndef my_rand +# define my_rand rand +#endif +#ifndef my_srand +# define my_srand srand +#endif + PP(pp_rand) { djSP; dTARGET; @@ -1561,19 +1578,19 @@ PP(pp_rand) if (value == 0.0) value = 1.0; if (!srand_called) { - (void)srand((unsigned)seed()); + (void)my_srand((unsigned)seed()); srand_called = TRUE; } #if RANDBITS == 31 - value = rand() * value / 2147483648.0; + value = my_rand() * value / 2147483648.0; #else #if RANDBITS == 16 - value = rand() * value / 65536.0; + value = my_rand() * value / 65536.0; #else #if RANDBITS == 15 - value = rand() * value / 32768.0; + value = my_rand() * value / 32768.0; #else - value = rand() * value / (double)(((unsigned long)1) << RANDBITS); + value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS); #endif #endif #endif @@ -1589,7 +1606,7 @@ PP(pp_srand) anum = seed(); else anum = POPu; - (void)srand((unsigned)anum); + (void)my_srand((unsigned)anum); srand_called = TRUE; EXTEND(SP, 1); RETPUSHYES; @@ -1621,21 +1638,50 @@ seed(void) #define SEED_C5 26107 dTHR; +#ifndef PERL_NO_DEV_RANDOM + int fd; +#endif U32 u; #ifdef VMS # include /* when[] = (low 32 bits, high 32 bits) of time since epoch * in 100-ns units, typically incremented ever 10 ms. */ unsigned int when[2]; +#else +# ifdef HAS_GETTIMEOFDAY + struct timeval when; +# else + Time_t when; +# endif +#endif + +/* This test is an escape hatch, this symbol isn't set by Configure. */ +#ifndef PERL_NO_DEV_RANDOM +#ifndef PERL_RANDOM_DEVICE + /* /dev/random isn't used by default because reads from it will block + * if there isn't enough entropy available. You can compile with + * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there + * is enough real entropy to fill the seed. */ +# define PERL_RANDOM_DEVICE "/dev/urandom" +#endif + fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); + if (fd != -1) { + if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) + u = 0; + PerlLIO_close(fd); + if (u) + return u; + } +#endif + +#ifdef VMS _ckvmssts(sys$gettim(when)); u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; #else # ifdef HAS_GETTIMEOFDAY - struct timeval when; gettimeofday(&when,(struct timezone *) 0); u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; # else - Time_t when; (void)time(&when); u = (U32)SEED_C1 * when; # endif @@ -1778,6 +1824,12 @@ PP(pp_oct) PP(pp_length) { djSP; dTARGET; + + if (IN_UTF8) { + SETi( sv_len_utf8(TOPs) ); + RETURN; + } + SETi( sv_len(TOPs) ); RETURN; } @@ -1788,10 +1840,11 @@ PP(pp_substr) SV *sv; I32 len; STRLEN curlen; + STRLEN utfcurlen; I32 pos; I32 rem; I32 fail; - I32 lvalue = op->op_flags & OPf_MOD; + I32 lvalue = PL_op->op_flags & OPf_MOD; char *tmps; I32 arybase = PL_curcop->cop_arybase; char *repl = 0; @@ -1809,6 +1862,16 @@ PP(pp_substr) sv = POPs; PUTBACK; tmps = SvPV(sv, curlen); + if (IN_UTF8) { + utfcurlen = sv_len_utf8(sv); + if (utfcurlen == curlen) + utfcurlen = 0; + else + curlen = utfcurlen; + } + else + utfcurlen = 0; + if (pos >= arybase) { pos -= arybase; rem = curlen-pos; @@ -1843,19 +1906,22 @@ PP(pp_substr) rem -= pos; } if (fail < 0) { - if (PL_dowarn || lvalue || repl) - warn("substr outside of string"); + if (ckWARN(WARN_SUBSTR) || lvalue || repl) + warner(WARN_SUBSTR, "substr outside of string"); RETPUSHUNDEF; } else { + if (utfcurlen) + sv_pos_u2b(sv, &pos, &rem); tmps += pos; sv_setpvn(TARG, tmps, rem); if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { SvPV_force(sv,PL_na); - if (PL_dowarn) - warn("Attempt to use reference as lvalue in substr"); + if (ckWARN(WARN_SUBSTR)) + warner(WARN_SUBSTR, + "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ (void)SvPOK_only(sv); @@ -1891,7 +1957,7 @@ PP(pp_vec) register I32 size = POPi; register I32 offset = POPi; register SV *src = POPs; - I32 lvalue = op->op_flags & OPf_MOD; + I32 lvalue = PL_op->op_flags & OPf_MOD; STRLEN srclen; unsigned char *s = (unsigned char*)SvPV(src, srclen); unsigned long retnum; @@ -1983,16 +2049,20 @@ PP(pp_index) little = POPs; big = POPs; tmps = SvPV(big, biglen); + if (IN_UTF8 && offset > 0) + sv_pos_u2b(big, &offset, 0); if (offset < 0) offset = 0; else if (offset > biglen) offset = biglen; if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset, (unsigned char*)tmps + biglen, little, 0))) - retval = -1 + arybase; + retval = -1; else - retval = tmps2 - tmps + arybase; - PUSHi(retval); + retval = tmps2 - tmps; + if (IN_UTF8 && retval > 0) + sv_pos_b2u(big, &retval); + PUSHi(retval + arybase); RETURN; } @@ -2003,7 +2073,6 @@ PP(pp_rindex) SV *little; STRLEN blen; STRLEN llen; - SV *offstr; I32 offset; I32 retval; char *tmps; @@ -2011,25 +2080,30 @@ PP(pp_rindex) I32 arybase = PL_curcop->cop_arybase; if (MAXARG >= 3) - offstr = POPs; + offset = POPi; little = POPs; big = POPs; tmps2 = SvPV(little, llen); tmps = SvPV(big, blen); if (MAXARG < 3) offset = blen; - else - offset = SvIV(offstr) - arybase + llen; + else { + if (IN_UTF8 && offset > 0) + sv_pos_u2b(big, &offset, 0); + offset = offset - arybase + llen; + } if (offset < 0) offset = 0; else if (offset > blen) offset = blen; if (!(tmps2 = rninstr(tmps, tmps + offset, tmps2, tmps2 + llen))) - retval = -1 + arybase; + retval = -1; else - retval = tmps2 - tmps + arybase; - PUSHi(retval); + retval = tmps2 - tmps; + if (IN_UTF8 && retval > 0) + sv_pos_b2u(big, &retval); + PUSHi(retval + arybase); RETURN; } @@ -2037,7 +2111,7 @@ PP(pp_sprintf) { djSP; dMARK; dORIGMARK; dTARGET; #ifdef USE_LOCALE_NUMERIC - if (op->op_private & OPpLOCALE) + if (PL_op->op_private & OPpLOCALE) SET_NUMERIC_LOCAL(); else SET_NUMERIC_STANDARD(); @@ -2053,17 +2127,13 @@ PP(pp_ord) { djSP; dTARGET; I32 value; - char *tmps; + U8 *tmps = (U8*)POPp; + I32 retlen; -#ifndef I286 - tmps = POPp; - value = (I32) (*tmps & 255); -#else - I32 anum; - tmps = POPp; - anum = (I32) *tmps; - value = (I32) (anum & 255); -#endif + if (IN_UTF8 && (*tmps & 0x80)) + value = (I32) utf8_to_uv(tmps, &retlen); + else + value = (I32) (*tmps & 255); XPUSHi(value); RETURN; } @@ -2072,12 +2142,25 @@ PP(pp_chr) { djSP; dTARGET; char *tmps; + I32 value = POPi; (void)SvUPGRADE(TARG,SVt_PV); + + if (IN_UTF8 && value >= 128) { + SvGROW(TARG,8); + tmps = SvPVX(TARG); + tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value); + SvCUR_set(TARG, tmps - SvPVX(TARG)); + *tmps = '\0'; + (void)SvPOK_only(TARG); + XPUSHs(TARG); + RETURN; + } + SvGROW(TARG,2); SvCUR_set(TARG, 1); tmps = SvPVX(TARG); - *tmps++ = POPi; + *tmps++ = value; *tmps = '\0'; (void)SvPOK_only(TARG); XPUSHs(TARG); @@ -2090,9 +2173,9 @@ PP(pp_crypt) #ifdef HAS_CRYPT char *tmps = SvPV(left, PL_na); #ifdef FCRYPT - sv_setpv(TARG, fcrypt(tmps, SvPV(right, na))); + sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na))); #else - sv_setpv(TARG, crypt(tmps, SvPV(right, PL_na))); + sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na))); #endif #else DIE( @@ -2106,7 +2189,37 @@ PP(pp_ucfirst) { djSP; SV *sv = TOPs; - register char *s; + register U8 *s; + STRLEN slen; + + if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { + I32 ulen; + U8 tmpbuf[10]; + U8 *tend; + UV uv = utf8_to_uv(s, &ulen); + + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + uv = toTITLE_LC_uni(uv); + } + else + uv = toTITLE_utf8(s); + + tend = uv_to_utf8(tmpbuf, uv); + + if (!SvPADTMP(sv) || tend - tmpbuf != ulen) { + dTARGET; + sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); + sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); + SETs(TARG); + } + else { + s = (U8*)SvPV_force(sv, slen); + Copy(tmpbuf, s, ulen, U8); + } + RETURN; + } if (!SvPADTMP(sv)) { dTARGET; @@ -2114,9 +2227,9 @@ PP(pp_ucfirst) sv = TARG; SETs(sv); } - s = SvPV_force(sv, PL_na); + s = (U8*)SvPV_force(sv, PL_na); if (*s) { - if (op->op_private & OPpLOCALE) { + if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); *s = toUPPER_LC(*s); @@ -2132,7 +2245,37 @@ PP(pp_lcfirst) { djSP; SV *sv = TOPs; - register char *s; + register U8 *s; + STRLEN slen; + + if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { + I32 ulen; + U8 tmpbuf[10]; + U8 *tend; + UV uv = utf8_to_uv(s, &ulen); + + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + uv = toLOWER_LC_uni(uv); + } + else + uv = toLOWER_utf8(s); + + tend = uv_to_utf8(tmpbuf, uv); + + if (!SvPADTMP(sv) || tend - tmpbuf != ulen) { + dTARGET; + sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); + sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); + SETs(TARG); + } + else { + s = (U8*)SvPV_force(sv, slen); + Copy(tmpbuf, s, ulen, U8); + } + RETURN; + } if (!SvPADTMP(sv)) { dTARGET; @@ -2140,9 +2283,9 @@ PP(pp_lcfirst) sv = TARG; SETs(sv); } - s = SvPV_force(sv, PL_na); + s = (U8*)SvPV_force(sv, PL_na); if (*s) { - if (op->op_private & OPpLOCALE) { + if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); *s = toLOWER_LC(*s); @@ -2159,9 +2302,47 @@ PP(pp_uc) { djSP; SV *sv = TOPs; - register char *s; + register U8 *s; STRLEN len; + if (IN_UTF8) { + dTARGET; + I32 ulen; + register U8 *d; + U8 *send; + + s = (U8*)SvPV(sv,len); + if (!len) { + sv_setpvn(TARG, "", 0); + SETs(TARG); + RETURN; + } + + (void)SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, (len * 2) + 1); + (void)SvPOK_only(TARG); + d = (U8*)SvPVX(TARG); + send = s + len; + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(TARG); + while (s < send) { + d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen))); + s += ulen; + } + } + else { + while (s < send) { + d = uv_to_utf8(d, toUPPER_utf8( s )); + s += UTF8SKIP(s); + } + } + *d = '\0'; + SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); + SETs(TARG); + RETURN; + } + if (!SvPADTMP(sv)) { dTARGET; sv_setsv(TARG, sv); @@ -2169,11 +2350,11 @@ PP(pp_uc) SETs(sv); } - s = SvPV_force(sv, len); + s = (U8*)SvPV_force(sv, len); if (len) { - register char *send = s + len; + register U8 *send = s + len; - if (op->op_private & OPpLOCALE) { + if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); for (; s < send; s++) @@ -2191,9 +2372,47 @@ PP(pp_lc) { djSP; SV *sv = TOPs; - register char *s; + register U8 *s; STRLEN len; + if (IN_UTF8) { + dTARGET; + I32 ulen; + register U8 *d; + U8 *send; + + s = (U8*)SvPV(sv,len); + if (!len) { + sv_setpvn(TARG, "", 0); + SETs(TARG); + RETURN; + } + + (void)SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, (len * 2) + 1); + (void)SvPOK_only(TARG); + d = (U8*)SvPVX(TARG); + send = s + len; + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(TARG); + while (s < send) { + d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen))); + s += ulen; + } + } + else { + while (s < send) { + d = uv_to_utf8(d, toLOWER_utf8(s)); + s += UTF8SKIP(s); + } + } + *d = '\0'; + SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); + SETs(TARG); + RETURN; + } + if (!SvPADTMP(sv)) { dTARGET; sv_setsv(TARG, sv); @@ -2201,11 +2420,11 @@ PP(pp_lc) SETs(sv); } - s = SvPV_force(sv, len); + s = (U8*)SvPV_force(sv, len); if (len) { - register char *send = s + len; + register U8 *send = s + len; - if (op->op_private & OPpLOCALE) { + if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); for (; s < send; s++) @@ -2232,7 +2451,7 @@ PP(pp_quotemeta) SvGROW(TARG, (len * 2) + 1); d = SvPVX(TARG); while (len--) { - if (!isALNUM(*s)) + if (!(*s & 0x80) && !isALNUM(*s)) *d++ = '\\'; *d++ = *s++; } @@ -2253,12 +2472,12 @@ PP(pp_aslice) djSP; dMARK; dORIGMARK; register SV** svp; register AV* av = (AV*)POPs; - register I32 lval = op->op_flags & OPf_MOD; + register I32 lval = PL_op->op_flags & OPf_MOD; I32 arybase = PL_curcop->cop_arybase; I32 elem; if (SvTYPE(av) == SVt_PVAV) { - if (lval && op->op_private & OPpLVAL_INTRO) { + if (lval && PL_op->op_private & OPpLVAL_INTRO) { I32 max = -1; for (svp = MARK + 1; svp <= SP; svp++) { elem = SvIVx(*svp); @@ -2277,7 +2496,7 @@ PP(pp_aslice) if (lval) { if (!svp || *svp == &PL_sv_undef) DIE(no_aelem, elem); - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) save_aelem(av, elem, svp); } *MARK = svp ? *svp : &PL_sv_undef; @@ -2342,7 +2561,7 @@ PP(pp_delete) SV *sv; HV *hv; - if (op->op_private & OPpSLICE) { + if (PL_op->op_private & OPpSLICE) { dMARK; dORIGMARK; U32 hvtype; hv = (HV*)POPs; @@ -2398,9 +2617,12 @@ PP(pp_hslice) { djSP; dMARK; dORIGMARK; register HV *hv = (HV*)POPs; - register I32 lval = op->op_flags & OPf_MOD; + register I32 lval = PL_op->op_flags & OPf_MOD; I32 realhv = (SvTYPE(hv) == SVt_PVHV); + if (!realhv && PL_op->op_private & OPpLVAL_INTRO) + DIE("Can't localize pseudo-hash element"); + if (realhv || SvTYPE(hv) == SVt_PVAV) { while (++MARK <= SP) { SV *keysv = *MARK; @@ -2414,7 +2636,7 @@ PP(pp_hslice) if (lval) { if (!svp || *svp == &PL_sv_undef) DIE(no_helem, SvPV(keysv, PL_na)); - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) save_helem(hv, keysv, svp); } *MARK = svp ? *svp : &PL_sv_undef; @@ -2451,7 +2673,7 @@ PP(pp_lslice) SV **firstlelem = PL_stack_base + POPMARK + 1; register SV **firstrelem = lastlelem + 1; I32 arybase = PL_curcop->cop_arybase; - I32 lval = op->op_flags & OPf_MOD; + I32 lval = PL_op->op_flags & OPf_MOD; I32 is_something_there = lval; register I32 max = lastrelem - lastlelem; @@ -2521,8 +2743,8 @@ PP(pp_anonhash) SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); - else if (PL_dowarn) - warn("Odd number of elements in hash assignment"); + else if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Odd number of elements in hash assignment"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; @@ -2849,6 +3071,31 @@ PP(pp_reverse) sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV); up = SvPV_force(TARG, len); if (len > 1) { + if (IN_UTF8) { /* first reverse each character */ + U8* s = (U8*)SvPVX(TARG); + U8* send = (U8*)(s + len); + while (s < send) { + if (*s < 0x80) { + s++; + continue; + } + else { + up = (char*)s; + s += UTF8SKIP(s); + down = (char*)(s - 1); + if (s > send || !((*down & 0xc0) == 0x80)) { + warn("Malformed UTF-8 character"); + break; + } + while (down > up) { + tmp = *up; + *up++ = *down; + *down-- = tmp; + } + } + } + up = SvPVX(TARG); + } down = SvPVX(TARG) + len - 1; while (down > up) { tmp = *up; @@ -2892,6 +3139,20 @@ mul128(SV *sv, U8 m) /* Explosives and implosives. */ +static const char uuemap[] = + "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; +static char uudmap[256]; /* Initialised on first use */ +#if 'I' == 73 && 'J' == 74 +/* On an ASCII/ISO kind of system */ +#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a') +#else +/* + Some other sort of character set - use memchr() so we don't match + the null byte. + */ +#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ') +#endif + PP(pp_unpack) { djSP; @@ -2965,8 +3226,8 @@ PP(pp_unpack) default: croak("Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ - if (commas++ == 0 && PL_dowarn) - warn("Invalid type in unpack: '%c'", (int)datumtype); + if (commas++ == 0 && ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') @@ -3158,6 +3419,28 @@ PP(pp_unpack) } } break; + case 'U': + if (len > strend - s) + len = strend - s; + if (checksum) { + while (len-- > 0 && s < strend) { + auint = utf8_to_uv((U8*)s, &along); + s += along; + culong += auint; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0 && s < strend) { + auint = utf8_to_uv((U8*)s, &along); + s += along; + sv = NEWSV(37, 0); + sv_setiv(sv, (IV)auint); + PUSHs(sv_2mortal(sv)); + } + } + break; case 's': along = (strend - s) / SIZE16; if (len > along) @@ -3518,31 +3801,48 @@ PP(pp_unpack) } break; case 'u': + /* MKS: + * Initialise the decode mapping. By using a table driven + * algorithm, the code will be character-set independent + * (and just as fast as doing character arithmetic) + */ + if (uudmap['M'] == 0) { + int i; + + for (i = 0; i < sizeof(uuemap); i += 1) + uudmap[uuemap[i]] = i; + /* + * Because ' ' and '`' map to the same value, + * we need to decode them both the same. + */ + uudmap[' '] = 0; + } + along = (strend - s) * 3 / 4; sv = NEWSV(42, along); if (along) SvPOK_on(sv); - while (s < strend && *s > ' ' && *s < 'a') { + while (s < strend && *s > ' ' && ISUUCHAR(*s)) { I32 a, b, c, d; char hunk[4]; hunk[3] = '\0'; - len = (*s++ - ' ') & 077; + len = uudmap[*s++] & 077; while (len > 0) { - if (s < strend && *s >= ' ') - a = (*s++ - ' ') & 077; - else - a = 0; - if (s < strend && *s >= ' ') - b = (*s++ - ' ') & 077; - else - b = 0; - if (s < strend && *s >= ' ') - c = (*s++ - ' ') & 077; - else - c = 0; - if (s < strend && *s >= ' ') - d = (*s++ - ' ') & 077; + if (s < strend && ISUUCHAR(*s)) + a = uudmap[*s++] & 077; + else + a = 0; + if (s < strend && ISUUCHAR(*s)) + b = uudmap[*s++] & 077; + else + b = 0; + if (s < strend && ISUUCHAR(*s)) + c = uudmap[*s++] & 077; + else + c = 0; + if (s < strend && ISUUCHAR(*s)) + d = uudmap[*s++] & 077; else d = 0; hunk[0] = (a << 2) | (b >> 4); @@ -3603,21 +3903,25 @@ doencodes(register SV *sv, register char *s, register I32 len) { char hunk[5]; - *hunk = len + ' '; + *hunk = uuemap[len]; sv_catpvn(sv, hunk, 1); hunk[4] = '\0'; - while (len > 0) { - hunk[0] = ' ' + (077 & (*s >> 2)); - hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017))); - hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03))); - hunk[3] = ' ' + (077 & (s[2] & 077)); + while (len > 2) { + hunk[0] = uuemap[(077 & (*s >> 2))]; + hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))]; + hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; + hunk[3] = uuemap[(077 & (s[2] & 077))]; sv_catpvn(sv, hunk, 4); s += 3; len -= 3; } - for (s = SvPVX(sv); *s; s++) { - if (*s == ' ') - *s = '`'; + if (len > 0) { + char r = (len > 1 ? s[1] : '\0'); + hunk[0] = uuemap[(077 & (*s >> 2))]; + hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))]; + hunk[2] = uuemap[(077 & ((r << 2) & 074))]; + hunk[3] = uuemap[0]; + sv_catpvn(sv, hunk, 4); } sv_catpvn(sv, "\n", 1); } @@ -3753,8 +4057,8 @@ PP(pp_pack) default: croak("Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ - if (commas++ == 0 && PL_dowarn) - warn("Invalid type in pack: '%c'", (int)datumtype); + if (commas++ == 0 && ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype); break; case '%': DIE("%% may only be used in unpack"); @@ -3933,6 +4237,16 @@ PP(pp_pack) sv_catpvn(cat, &achar, sizeof(char)); } break; + case 'U': + while (len-- > 0) { + fromstr = NEXTFROM; + auint = SvUV(fromstr); + SvGROW(cat, SvCUR(cat) + 10); + SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint) + - SvPVX(cat)); + } + *SvEND(cat) = '\0'; + break; /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ case 'f': case 'F': @@ -4126,8 +4440,9 @@ PP(pp_pack) * of pack() (and all copies of the result) are * gone. */ - if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr))) - warn("Attempt to pack pointer to temporary value"); + if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr))) + warner(WARN_UNSAFE, + "Attempt to pack pointer to temporary value"); if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,PL_na); else @@ -4208,7 +4523,7 @@ PP(pp_split) ary = GvAVn((GV*)pm->op_pmreplroot); else if (gimme != G_ARRAY) #ifdef USE_THREADS - ary = (AV*)curpad[0]; + ary = (AV*)PL_curpad[0]; #else ary = GvAVn(PL_defgv); #endif /* USE_THREADS */ @@ -4443,7 +4758,7 @@ unlock_condpair(void *svv) croak("panic: unlock_condpair unlocking mutex that we don't own"); MgOWNER(mg) = 0; COND_SIGNAL(MgOWNERCONDP(mg)); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n", (unsigned long)thr, (unsigned long)svv);) MUTEX_UNLOCK(MgMUTEXP(mg)); } @@ -4468,7 +4783,7 @@ PP(pp_lock) while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", (unsigned long)thr, (unsigned long)sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */ @@ -4488,10 +4803,10 @@ PP(pp_threadsv) djSP; #ifdef USE_THREADS EXTEND(SP, 1); - if (op->op_private & OPpLVAL_INTRO) - PUSHs(*save_threadsv(op->op_targ)); + if (PL_op->op_private & OPpLVAL_INTRO) + PUSHs(*save_threadsv(PL_op->op_targ)); else - PUSHs(THREADSV(op->op_targ)); + PUSHs(THREADSV(PL_op->op_targ)); RETURN; #else DIE("tried to access per-thread data in non-threaded perl");