X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=729d1e7ccca17849db8ef92e216b057b314cc24f;hb=47cadb06ccb7dbe87fdda243544a1ecb06fb104f;hp=a6f26f5c1ef7af822f7d27dd800f6820d97b306d;hpb=a5a20234c16adf3662345bdfd872d14c28021bc0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index a6f26f5..729d1e7 100644 --- a/pp.c +++ b/pp.c @@ -107,8 +107,6 @@ static SV* refto _((SV* sv)); static U32 seed _((void)); #endif -static bool srand_called = FALSE; - /* variations on pp_null */ #ifdef I_UNISTD @@ -211,6 +209,8 @@ PP(pp_rv2gv) if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_gv); + sv = SvRV(sv); if (SvTYPE(sv) == SVt_PVIO) { GV *gv = (GV*) sv_newmortal(); @@ -224,6 +224,7 @@ PP(pp_rv2gv) else { if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -233,14 +234,14 @@ PP(pp_rv2gv) if (!SvOK(sv)) { 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); + DIE(PL_no_usym, "a symbol"); + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, PL_warn_uninit); RETSETUNDEF; } - sym = SvPV(sv, PL_na); + sym = SvPV(sv, n_a); if (PL_op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "a symbol"); + DIE(PL_no_symref, sym, "a symbol"); sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); } } @@ -256,6 +257,8 @@ PP(pp_rv2sv) if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_sv); + sv = SvRV(sv); switch (SvTYPE(sv)) { case SVt_PVAV: @@ -267,6 +270,7 @@ PP(pp_rv2sv) else { GV *gv = (GV*)sv; char *sym; + STRLEN n_a; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { @@ -277,14 +281,14 @@ PP(pp_rv2sv) if (!SvOK(sv)) { 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); + DIE(PL_no_usym, "a SCALAR"); + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, PL_warn_uninit); RETSETUNDEF; } - sym = SvPV(sv, PL_na); + sym = SvPV(sv, n_a); if (PL_op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "a SCALAR"); + DIE(PL_no_symref, sym, "a SCALAR"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); } sv = GvSV(gv); @@ -390,13 +394,16 @@ PP(pp_prototype) char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ while (i < MAXO) { /* The slow way. */ - if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i])) + if (strEQ(s + 6, PL_op_name[i]) + || strEQ(s + 6, PL_op_desc[i])) + { goto found; + } i++; } goto nonesuch; /* Should not happen... */ found: - oa = opargs[i] >> OASHIFT; + oa = PL_opargs[i] >> OASHIFT; while (oa) { if (oa & OA_OPTIONAL) { seen_question = 1; @@ -520,8 +527,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); } @@ -536,9 +544,10 @@ PP(pp_gelem) SV *tmpRef; char *elem; djSP; - + STRLEN n_a; + sv = POPs; - elem = SvPV(sv, PL_na); + elem = SvPV(sv, n_a); gv = (GV*)POPs; tmpRef = Nullsv; sv = Nullsv; @@ -668,7 +677,7 @@ PP(pp_trans) EXTEND(SP,1); } TARG = sv_newmortal(); - PUSHi(do_trans(sv, PL_op)); + PUSHi(do_trans(sv)); RETURN; } @@ -719,11 +728,11 @@ PP(pp_defined) RETPUSHNO; switch (SvTYPE(sv)) { case SVt_PVAV: - if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)) + if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P'))) RETPUSHYES; break; case SVt_PVHV: - if (HvARRAY(sv) || SvGMAGICAL(sv)) + if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P'))) RETPUSHYES; break; case SVt_PVCV: @@ -754,8 +763,11 @@ PP(pp_undef) RETPUSHUNDEF; if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) - RETPUSHUNDEF; + if (SvREADONLY(sv)) { + dTHR; + if (PL_curcop != &PL_compiling) + croak(PL_no_modify); + } if (SvROK(sv)) sv_unref(sv); } @@ -770,8 +782,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: @@ -811,7 +823,7 @@ PP(pp_predec) { 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_MIN) { @@ -828,7 +840,7 @@ PP(pp_postinc) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(no_modify); + croak(PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) @@ -849,7 +861,7 @@ PP(pp_postdec) { djSP; dTARGET; if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(no_modify); + croak(PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) @@ -1315,6 +1327,10 @@ PP(pp_negate) sv_setsv(TARG, sv); *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; } + else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) { + sv_setpvn(TARG, "-", 1); + sv_catsv(TARG, sv); + } else sv_setnv(TARG, -SvNV(sv)); SETTARG; @@ -1559,11 +1575,13 @@ PP(pp_cos) 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 +/* Now it's after 5.005, and Configure supports drand48() and random(), + in addition to rand(). So the overrides should not be needed any more. + --Jarkko Hietaniemi 27 September 1998 + */ + +#ifndef HAS_DRAND48_PROTO +extern double drand48 _((void)); #endif PP(pp_rand) @@ -1576,23 +1594,11 @@ PP(pp_rand) value = POPn; if (value == 0.0) value = 1.0; - if (!srand_called) { - (void)my_srand((unsigned)seed()); - srand_called = TRUE; + if (!PL_srand_called) { + (void)seedDrand01((Rand_seed_t)seed()); + PL_srand_called = TRUE; } -#if RANDBITS == 31 - value = my_rand() * value / 2147483648.0; -#else -#if RANDBITS == 16 - value = my_rand() * value / 65536.0; -#else -#if RANDBITS == 15 - value = my_rand() * value / 32768.0; -#else - value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS); -#endif -#endif -#endif + value *= Drand01(); XPUSHn(value); RETURN; } @@ -1605,8 +1611,8 @@ PP(pp_srand) anum = seed(); else anum = POPu; - (void)my_srand((unsigned)anum); - srand_called = TRUE; + (void)seedDrand01((Rand_seed_t)anum); + PL_srand_called = TRUE; EXTEND(SP, 1); RETPUSHYES; } @@ -1618,9 +1624,9 @@ seed(void) * This is really just a quick hack which grabs various garbage * values. It really should be a real hash algorithm which * spreads the effect of every input bit onto every output bit, - * if someone who knows about such tings would bother to write it. + * if someone who knows about such things would bother to write it. * Might be a good idea to add that function to CORE as well. - * No numbers below come from careful analysis or anyting here, + * No numbers below come from careful analysis or anything here, * except they are primes and SEED_C1 > 1E6 to get a full-width * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should * probably be bigger too. @@ -1637,21 +1643,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 @@ -1763,8 +1798,9 @@ PP(pp_hex) djSP; dTARGET; char *tmps; I32 argtype; + STRLEN n_a; - tmps = POPp; + tmps = POPpx; XPUSHu(scan_hex(tmps, 99, &argtype)); RETURN; } @@ -1775,14 +1811,17 @@ PP(pp_oct) UV value; I32 argtype; char *tmps; + STRLEN n_a; - tmps = POPp; + tmps = POPpx; while (*tmps && isSPACE(*tmps)) tmps++; if (*tmps == '0') tmps++; if (*tmps == 'x') value = scan_hex(++tmps, 99, &argtype); + else if (*tmps == 'b') + value = scan_bin(++tmps, 99, &argtype); else value = scan_oct(tmps, 99, &argtype); XPUSHu(value); @@ -1876,8 +1915,8 @@ 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 { @@ -1888,9 +1927,11 @@ PP(pp_substr) 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"); + STRLEN n_a; + SvPV_force(sv,n_a); + 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); @@ -2095,15 +2136,16 @@ PP(pp_sprintf) PP(pp_ord) { djSP; dTARGET; - I32 value; - char *tmps = POPp; + UV value; + STRLEN n_a; + U8 *tmps = (U8*)POPpx; I32 retlen; if (IN_UTF8 && (*tmps & 0x80)) - value = (I32) utf8_to_uv(tmps, &retlen); + value = utf8_to_uv(tmps, &retlen); else - value = (I32) (*tmps & 255); - XPUSHi(value); + value = (UV)(*tmps & 255); + XPUSHu(value); RETURN; } @@ -2111,14 +2153,14 @@ PP(pp_chr) { djSP; dTARGET; char *tmps; - I32 value = POPi; + U32 value = POPu; (void)SvUPGRADE(TARG,SVt_PV); if (IN_UTF8 && value >= 128) { SvGROW(TARG,8); tmps = SvPVX(TARG); - tmps = uv_to_utf8(tmps, (UV)value); + tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value); SvCUR_set(TARG, tmps - SvPVX(TARG)); *tmps = '\0'; (void)SvPOK_only(TARG); @@ -2139,12 +2181,13 @@ PP(pp_chr) PP(pp_crypt) { djSP; dTARGET; dPOPTOPssrl; + STRLEN n_a; #ifdef HAS_CRYPT - char *tmps = SvPV(left, PL_na); + char *tmps = SvPV(left, n_a); #ifdef FCRYPT - sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na))); + sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); #else - sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na))); + sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); #endif #else DIE( @@ -2161,7 +2204,7 @@ PP(pp_ucfirst) register U8 *s; STRLEN slen; - if (IN_UTF8 && (s = SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { + if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { I32 ulen; U8 tmpbuf[10]; U8 *tend; @@ -2179,12 +2222,12 @@ PP(pp_ucfirst) if (!SvPADTMP(sv) || tend - tmpbuf != ulen) { dTARGET; - sv_setpvn(TARG, tmpbuf, tend - tmpbuf); - sv_catpvn(TARG, s + ulen, slen - ulen); + sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); + sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); SETs(TARG); } else { - s = SvPV_force(sv, slen); + s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } RETURN; @@ -2196,7 +2239,7 @@ PP(pp_ucfirst) sv = TARG; SETs(sv); } - s = SvPV_force(sv, PL_na); + s = (U8*)SvPV_force(sv, slen); if (*s) { if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2217,7 +2260,7 @@ PP(pp_lcfirst) register U8 *s; STRLEN slen; - if (IN_UTF8 && (s = SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { + if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { I32 ulen; U8 tmpbuf[10]; U8 *tend; @@ -2235,12 +2278,12 @@ PP(pp_lcfirst) if (!SvPADTMP(sv) || tend - tmpbuf != ulen) { dTARGET; - sv_setpvn(TARG, tmpbuf, tend - tmpbuf); - sv_catpvn(TARG, s + ulen, slen - ulen); + sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); + sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); SETs(TARG); } else { - s = SvPV_force(sv, slen); + s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } RETURN; @@ -2252,7 +2295,7 @@ PP(pp_lcfirst) sv = TARG; SETs(sv); } - s = SvPV_force(sv, PL_na); + s = (U8*)SvPV_force(sv, slen); if (*s) { if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2280,7 +2323,7 @@ PP(pp_uc) register U8 *d; U8 *send; - s = SvPV(sv,len); + s = (U8*)SvPV(sv,len); if (!len) { sv_setpvn(TARG, "", 0); SETs(TARG); @@ -2290,7 +2333,7 @@ PP(pp_uc) (void)SvUPGRADE(TARG, SVt_PV); SvGROW(TARG, (len * 2) + 1); (void)SvPOK_only(TARG); - d = SvPVX(TARG); + d = (U8*)SvPVX(TARG); send = s + len; if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2319,7 +2362,7 @@ PP(pp_uc) SETs(sv); } - s = SvPV_force(sv, len); + s = (U8*)SvPV_force(sv, len); if (len) { register U8 *send = s + len; @@ -2350,7 +2393,7 @@ PP(pp_lc) register U8 *d; U8 *send; - s = SvPV(sv,len); + s = (U8*)SvPV(sv,len); if (!len) { sv_setpvn(TARG, "", 0); SETs(TARG); @@ -2360,7 +2403,7 @@ PP(pp_lc) (void)SvUPGRADE(TARG, SVt_PV); SvGROW(TARG, (len * 2) + 1); (void)SvPOK_only(TARG); - d = SvPVX(TARG); + d = (U8*)SvPVX(TARG); send = s + len; if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2389,7 +2432,7 @@ PP(pp_lc) SETs(sv); } - s = SvPV_force(sv, len); + s = (U8*)SvPV_force(sv, len); if (len) { register U8 *send = s + len; @@ -2419,10 +2462,30 @@ PP(pp_quotemeta) (void)SvUPGRADE(TARG, SVt_PV); SvGROW(TARG, (len * 2) + 1); d = SvPVX(TARG); - while (len--) { - if (!(*s & 0x80) && !isALNUM(*s)) - *d++ = '\\'; - *d++ = *s++; + if (IN_UTF8) { + while (len) { + if (*s & 0x80) { + STRLEN ulen = UTF8SKIP(s); + if (ulen > len) + ulen = len; + len -= ulen; + while (ulen--) + *d++ = *s++; + } + else { + if (!isALNUM(*s)) + *d++ = '\\'; + *d++ = *s++; + len--; + } + } + } + else { + while (len--) { + if (!isALNUM(*s)) + *d++ = '\\'; + *d++ = *s++; + } } *d = '\0'; SvCUR_set(TARG, d - SvPVX(TARG)); @@ -2464,7 +2527,7 @@ PP(pp_aslice) svp = av_fetch(av, elem, lval); if (lval) { if (!svp || *svp == &PL_sv_undef) - DIE(no_aelem, elem); + DIE(PL_no_aelem, elem); if (PL_op->op_private & OPpLVAL_INTRO) save_aelem(av, elem, svp); } @@ -2603,8 +2666,10 @@ PP(pp_hslice) svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0); } if (lval) { - if (!svp || *svp == &PL_sv_undef) - DIE(no_helem, SvPV(keysv, PL_na)); + if (!svp || *svp == &PL_sv_undef) { + STRLEN n_a; + DIE(PL_no_helem, SvPV(keysv, n_a)); + } if (PL_op->op_private & OPpLVAL_INTRO) save_helem(hv, keysv, svp); } @@ -2712,8 +2777,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; @@ -2736,8 +2801,8 @@ PP(pp_splice) SV **tmparyval = 0; MAGIC *mg; - if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { - *MARK-- = mg->mg_obj; + if (mg = SvTIED_mg((SV*)ary, 'P')) { + *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; ENTER; @@ -2756,7 +2821,7 @@ PP(pp_splice) else offset -= PL_curcop->cop_arybase; if (offset < 0) - DIE(no_aelem, i); + DIE(PL_no_aelem, i); if (++MARK < SP) { length = SvIVx(*MARK++); if (length < 0) { @@ -2786,12 +2851,8 @@ PP(pp_splice) newlen = SP - MARK; diff = newlen - length; - if (newlen && !AvREAL(ary)) { - if (AvREIFY(ary)) - av_reify(ary); - else - assert(AvREAL(ary)); /* would leak, so croak */ - } + if (newlen && !AvREAL(ary) && AvREIFY(ary)) + av_reify(ary); if (diff < 0) { /* shrinking the area */ if (newlen) { @@ -2934,8 +2995,8 @@ PP(pp_push) register SV *sv = &PL_sv_undef; MAGIC *mg; - if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { - *MARK-- = mg->mg_obj; + if (mg = SvTIED_mg((SV*)ary, 'P')) { + *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; ENTER; @@ -2990,8 +3051,8 @@ PP(pp_unshift) register I32 i = 0; MAGIC *mg; - if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { - *MARK-- = mg->mg_obj; + if (mg = SvTIED_mg((SV*)ary, 'P')) { + *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; ENTER; @@ -3041,17 +3102,17 @@ PP(pp_reverse) up = SvPV_force(TARG, len); if (len > 1) { if (IN_UTF8) { /* first reverse each character */ - unsigned char* s = SvPVX(TARG); - unsigned char* send = s + len; + U8* s = (U8*)SvPVX(TARG); + U8* send = (U8*)(s + len); while (s < send) { if (*s < 0x80) { s++; continue; } else { - up = s; + up = (char*)s; s += UTF8SKIP(s); - down = s - 1; + down = (char*)(s - 1); if (s > send || !((*down & 0xc0) == 0x80)) { warn("Malformed UTF-8 character"); break; @@ -3108,9 +3169,6 @@ 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') @@ -3119,7 +3177,7 @@ static char uudmap[256]; /* Initialised on first use */ 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) == ' ') +#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') #endif PP(pp_unpack) @@ -3151,7 +3209,7 @@ PP(pp_unpack) unsigned int auint; U32 aulong; #ifdef HAS_QUAD - unsigned Quad_t auquad; + Uquad_t auquad; #endif char *aptr; float afloat; @@ -3159,13 +3217,12 @@ PP(pp_unpack) I32 checksum = 0; register U32 culong; double cdouble; - static char* bitcount = 0; int commas = 0; if (gimme != G_ARRAY) { /* arrange to do first one only */ /*SUPPRESS 530*/ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; - if (strchr("aAbBhHP", *patend) || *pat == '%') { + if (strchr("aAZbBhHP", *patend) || *pat == '%') { patend++; while (isDIGIT(*patend) || *patend == '*') patend++; @@ -3195,8 +3252,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') @@ -3223,6 +3280,7 @@ PP(pp_unpack) s += len; break; case 'A': + case 'Z': case 'a': if (len > strend - s) len = strend - s; @@ -3231,12 +3289,19 @@ PP(pp_unpack) sv = NEWSV(35, len); sv_setpvn(sv, s, len); s += len; - if (datumtype == 'A') { + if (datumtype == 'A' || datumtype == 'Z') { aptr = s; /* borrow register */ - s = SvPVX(sv) + len - 1; - while (s >= SvPVX(sv) && (!*s || isSPACE(*s))) - s--; - *++s = '\0'; + if (datumtype == 'Z') { /* 'Z' strips stuff after first null */ + s = SvPVX(sv); + while (*s) + s++; + } + else { /* 'A' strips both nulls and spaces */ + s = SvPVX(sv) + len - 1; + while (s >= SvPVX(sv) && (!*s || isSPACE(*s))) + s--; + *++s = '\0'; + } SvCUR_set(sv, s - SvPVX(sv)); s = aptr; /* unborrow register */ } @@ -3247,21 +3312,21 @@ PP(pp_unpack) if (pat[-1] == '*' || len > (strend - s) * 8) len = (strend - s) * 8; if (checksum) { - if (!bitcount) { - Newz(601, bitcount, 256, char); + if (!PL_bitcount) { + Newz(601, PL_bitcount, 256, char); for (bits = 1; bits < 256; bits++) { - if (bits & 1) bitcount[bits]++; - if (bits & 2) bitcount[bits]++; - if (bits & 4) bitcount[bits]++; - if (bits & 8) bitcount[bits]++; - if (bits & 16) bitcount[bits]++; - if (bits & 32) bitcount[bits]++; - if (bits & 64) bitcount[bits]++; - if (bits & 128) bitcount[bits]++; + if (bits & 1) PL_bitcount[bits]++; + if (bits & 2) PL_bitcount[bits]++; + if (bits & 4) PL_bitcount[bits]++; + if (bits & 8) PL_bitcount[bits]++; + if (bits & 16) PL_bitcount[bits]++; + if (bits & 32) PL_bitcount[bits]++; + if (bits & 64) PL_bitcount[bits]++; + if (bits & 128) PL_bitcount[bits]++; } } while (len >= 8) { - culong += bitcount[*(unsigned char*)s++]; + culong += PL_bitcount[*(unsigned char*)s++]; len -= 8; } if (len) { @@ -3393,19 +3458,22 @@ PP(pp_unpack) len = strend - s; if (checksum) { while (len-- > 0 && s < strend) { - auint = utf8_to_uv(s, &along); + auint = utf8_to_uv((U8*)s, &along); s += along; - culong += auint; + if (checksum > 32) + cdouble += (double)auint; + else + culong += auint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0 && s < strend) { - auint = utf8_to_uv(s, &along); + auint = utf8_to_uv((U8*)s, &along); s += along; sv = NEWSV(37, 0); - sv_setiv(sv, (IV)auint); + sv_setuv(sv, (UV)auint); PUSHs(sv_2mortal(sv)); } } @@ -3528,6 +3596,17 @@ PP(pp_unpack) Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); sv = NEWSV(41, 0); +#ifdef __osf__ + /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF)) + * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for + * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D) + * with optimization turned on. + * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B) + * does not have this problem even with -O4) + */ + (auint) ? + sv_setuv(sv, (UV)auint) : +#endif sv_setuv(sv, (UV)auint); PUSHs(sv_2mortal(sv)); } @@ -3641,6 +3720,7 @@ PP(pp_unpack) } else if (++bytes >= sizeof(UV)) { /* promote to string */ char *t; + STRLEN n_a; sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv); while (s < strend) { @@ -3650,7 +3730,7 @@ PP(pp_unpack) break; } } - t = SvPV(sv, PL_na); + t = SvPV(sv, n_a); while (*t == '0') t++; sv_chop(sv, t); @@ -3705,11 +3785,11 @@ PP(pp_unpack) EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { - if (s + sizeof(unsigned Quad_t) > strend) + if (s + sizeof(Uquad_t) > strend) auquad = 0; else { - Copy(s, &auquad, 1, unsigned Quad_t); - s += sizeof(unsigned Quad_t); + Copy(s, &auquad, 1, Uquad_t); + s += sizeof(Uquad_t); } sv = NEWSV(43, 0); if (auquad <= UV_MAX) @@ -3775,16 +3855,16 @@ PP(pp_unpack) * algorithm, the code will be character-set independent * (and just as fast as doing character arithmetic) */ - if (uudmap['M'] == 0) { + if (PL_uudmap['M'] == 0) { int i; - for (i = 0; i < sizeof(uuemap); i += 1) - uudmap[uuemap[i]] = i; + for (i = 0; i < sizeof(PL_uuemap); i += 1) + PL_uudmap[PL_uuemap[i]] = i; /* * Because ' ' and '`' map to the same value, * we need to decode them both the same. */ - uudmap[' '] = 0; + PL_uudmap[' '] = 0; } along = (strend - s) * 3 / 4; @@ -3796,22 +3876,22 @@ PP(pp_unpack) char hunk[4]; hunk[3] = '\0'; - len = (*s++ - ' ') & 077; + len = PL_uudmap[*s++] & 077; while (len > 0) { if (s < strend && ISUUCHAR(*s)) - a = uudmap[*s++] & 077; + a = PL_uudmap[*s++] & 077; else a = 0; if (s < strend && ISUUCHAR(*s)) - b = uudmap[*s++] & 077; + b = PL_uudmap[*s++] & 077; else b = 0; if (s < strend && ISUUCHAR(*s)) - c = uudmap[*s++] & 077; + c = PL_uudmap[*s++] & 077; else c = 0; if (s < strend && ISUUCHAR(*s)) - d = uudmap[*s++] & 077; + d = PL_uudmap[*s++] & 077; else d = 0; hunk[0] = (a << 2) | (b >> 4); @@ -3831,7 +3911,7 @@ PP(pp_unpack) if (checksum) { sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || - (checksum > 32 && strchr("iIlLN", datumtype)) ) { + (checksum > 32 && strchr("iIlLNU", datumtype)) ) { double trouble; adouble = 1.0; @@ -3872,24 +3952,24 @@ doencodes(register SV *sv, register char *s, register I32 len) { char hunk[5]; - *hunk = uuemap[len]; + *hunk = PL_uuemap[len]; sv_catpvn(sv, hunk, 1); hunk[4] = '\0'; 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))]; + hunk[0] = PL_uuemap[(077 & (*s >> 2))]; + hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))]; + hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; + hunk[3] = PL_uuemap[(077 & (s[2] & 077))]; sv_catpvn(sv, hunk, 4); s += 3; len -= 3; } 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]; + hunk[0] = PL_uuemap[(077 & (*s >> 2))]; + hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))]; + hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))]; + hunk[3] = PL_uuemap[0]; sv_catpvn(sv, hunk, 4); } sv_catpvn(sv, "\n", 1); @@ -3898,8 +3978,9 @@ doencodes(register SV *sv, register char *s, register I32 len) STATIC SV * is_an_int(char *s, STRLEN l) { + STRLEN n_a; SV *result = newSVpv("", l); - char *result_c = SvPV(result, PL_na); /* convenience */ + char *result_c = SvPV(result, n_a); /* convenience */ char *out = result_c; bool skip = 1; bool ignore = 0; @@ -3996,7 +4077,7 @@ PP(pp_pack) U32 aulong; #ifdef HAS_QUAD Quad_t aquad; - unsigned Quad_t auquad; + Uquad_t auquad; #endif char *aptr; float afloat; @@ -4026,8 +4107,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"); @@ -4055,6 +4136,7 @@ PP(pp_pack) sv_catpvn(cat, null10, len); break; case 'A': + case 'Z': case 'a': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); @@ -4211,7 +4293,8 @@ PP(pp_pack) fromstr = NEXTFROM; auint = SvUV(fromstr); SvGROW(cat, SvCUR(cat) + 10); - SvCUR_set(cat, uv_to_utf8(SvEND(cat), auint) - SvPVX(cat)); + SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint) + - SvPVX(cat)); } *SvEND(cat) = '\0'; break; @@ -4382,8 +4465,8 @@ PP(pp_pack) case 'Q': while (len-- > 0) { fromstr = NEXTFROM; - auquad = (unsigned Quad_t)SvIV(fromstr); - sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t)); + auquad = (Uquad_t)SvIV(fromstr); + sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); } break; case 'q': @@ -4403,17 +4486,19 @@ PP(pp_pack) if (fromstr == &PL_sv_undef) aptr = NULL; else { + STRLEN n_a; /* XXX better yet, could spirit away the string to * a safe spot and hang on to it until the result * 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); + aptr = SvPV(fromstr,n_a); else - aptr = SvPV_force(fromstr,PL_na); + aptr = SvPV_force(fromstr,n_a); } sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } @@ -4502,9 +4587,9 @@ PP(pp_split) av_extend(ary,0); av_clear(ary); SPAGAIN; - if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) { + if (mg = SvTIED_mg((SV*)ary, 'P')) { PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)ary, mg)); } else { if (!AvREAL(ary)) { @@ -4612,7 +4697,7 @@ PP(pp_split) else { maxiters += (strend - s) * rx->nparens; while (s < strend && --limit && - CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0)) + CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0)) { TAINT_IF(RX_MATCH_TAINTED(rx)); if (rx->subbase @@ -4753,7 +4838,6 @@ PP(pp_lock) 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 */ save_destructor(unlock_condpair, sv); } #endif /* USE_THREADS */