X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=a9ced1183b85973d5c71b9c41daa81e4ab54e6a1;hb=c67712b2e649d3ea6de971bd2e9efe6087948fc1;hp=4264e9b8a12958d37f27cdd907ae21ad46ae5c35;hpb=dfe9444ca7881e716e9e8feaf20b55da491363ca;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 4264e9b..a9ced11 100644 --- a/pp.c +++ b/pp.c @@ -46,7 +46,7 @@ typedef unsigned UBW; * have an integral type (except char) small enough to be represented * in a double without loss; that is, it has no 32-bit type. */ -#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP) +#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP) # define BW_BITS 32 # define BW_MASK ((1 << BW_BITS) - 1) # define BW_SIGN (1 << (BW_BITS - 1)) @@ -69,11 +69,19 @@ typedef unsigned UBW; * If they're not right on your machine, then pack() and unpack() * wouldn't work right anyway; you'll need to apply the Cray hack. * (I'd like to check them with #if, but you can't use sizeof() in - * the preprocessor.) + * the preprocessor.) --??? + */ +/* + The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE + defines are now in config.h. --Andy Dougherty April 1998 */ #define SIZE16 2 #define SIZE32 4 +#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32 +# define PERL_NATINT_PACK +#endif + #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP) # if BYTEORDER == 0x12345678 # define OFF16(p) (char*)(p) @@ -88,20 +96,22 @@ typedef unsigned UBW; # endif # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char)) # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char)) +# define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char)) # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16) # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32) #else # define COPY16(s,p) Copy(s, p, SIZE16, char) # define COPY32(s,p) Copy(s, p, SIZE32, char) +# define COPYNN(s,p,n) Copy(s, (char *)(p), n, char) # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16) # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32) #endif +#ifndef PERL_OBJECT static void doencodes _((SV* sv, char* s, I32 len)); static SV* refto _((SV* sv)); static U32 seed _((void)); - -static bool srand_called = FALSE; +#endif /* variations on pp_null */ @@ -121,7 +131,7 @@ PP(pp_stub) { djSP; if (GIMME_V == G_SCALAR) - XPUSHs(&sv_undef); + XPUSHs(&PL_sv_undef); RETURN; } @@ -135,10 +145,10 @@ PP(pp_scalar) PP(pp_padav) { djSP; dTARGET; - if (op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(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; } @@ -149,7 +159,7 @@ PP(pp_padav) U32 i; for (i=0; i < maxarg; i++) { SV **svp = av_fetch((AV*)TARG, i, FALSE); - SP[i+1] = (svp) ? *svp : &sv_undef; + SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } else { @@ -172,9 +182,9 @@ PP(pp_padhv) I32 gimme; XPUSHs(TARG); - if (op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(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) { @@ -205,6 +215,8 @@ PP(pp_rv2gv) if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_gv); + sv = SvRV(sv); if (SvTYPE(sv) == SVt_PVIO) { GV *gv = (GV*) sv_newmortal(); @@ -212,12 +224,14 @@ PP(pp_rv2gv) GvIOp(gv) = (IO *)sv; (void)SvREFCNT_inc(sv); sv = (SV*) gv; - } else if (SvTYPE(sv) != SVt_PVGV) + } + else if (SvTYPE(sv) != SVt_PVGV) DIE("Not a GLOB reference"); } else { if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -225,21 +239,30 @@ PP(pp_rv2gv) goto wasref; } if (!SvOK(sv)) { - if (op->op_flags & OPf_REF || - op->op_private & HINT_STRICT_REFS) - DIE(no_usym, "a symbol"); - if (dowarn) - warn(warn_uninit); + if (PL_op->op_flags & OPf_REF || + PL_op->op_private & HINT_STRICT_REFS) + DIE(PL_no_usym, "a symbol"); + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, PL_warn_uninit); RETSETUNDEF; } - sym = SvPV(sv, na); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "a symbol"); - sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); + sym = SvPV(sv, n_a); + if ((PL_op->op_flags & OPf_SPECIAL) && + !(PL_op->op_flags & OPf_MOD)) + { + sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV); + if (!sv) + RETSETUNDEF; + } + else { + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(PL_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; } @@ -250,6 +273,8 @@ PP(pp_rv2sv) if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_sv); + sv = SvRV(sv); switch (SvTYPE(sv)) { case SVt_PVAV: @@ -261,6 +286,7 @@ PP(pp_rv2sv) else { GV *gv = (GV*)sv; char *sym; + STRLEN n_a; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { @@ -269,25 +295,34 @@ PP(pp_rv2sv) goto wasref; } if (!SvOK(sv)) { - if (op->op_flags & OPf_REF || - op->op_private & HINT_STRICT_REFS) - DIE(no_usym, "a SCALAR"); - if (dowarn) - warn(warn_uninit); + if (PL_op->op_flags & OPf_REF || + PL_op->op_private & HINT_STRICT_REFS) + DIE(PL_no_usym, "a SCALAR"); + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, PL_warn_uninit); RETSETUNDEF; } - sym = SvPV(sv, na); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "a SCALAR"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); + sym = SvPV(sv, n_a); + if ((PL_op->op_flags & OPf_SPECIAL) && + !(PL_op->op_flags & OPf_MOD)) + { + gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV); + if (!gv) + RETSETUNDEF; + } + else { + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(PL_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; @@ -311,14 +346,18 @@ 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); } LvTYPE(TARG) = '.'; - LvTARG(TARG) = sv; + if (LvTARG(TARG) != sv) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(sv); + } PUSHs(TARG); /* no SvSETMAGIC */ RETURN; } @@ -328,7 +367,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 + curcop->cop_arybase); + I32 i = mg->mg_len; + if (IN_UTF8) + sv_pos_b2u(sv, &i); + PUSHi(i + PL_curcop->cop_arybase); RETURN; } } @@ -344,13 +386,13 @@ 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)); } else - cv = (CV*)&sv_undef; + cv = (CV*)&PL_sv_undef; SETs((SV*)cv); RETURN; } @@ -363,7 +405,7 @@ PP(pp_prototype) GV *gv; SV *ret; - ret = &sv_undef; + ret = &PL_sv_undef; if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { char *s = SvPVX(TOPs); if (strnEQ(s, "CORE::", 6)) { @@ -377,18 +419,22 @@ 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; str[n++] = ';'; - } else if (seen_question) + } + else if (seen_question) goto set; /* XXXX system, exec */ if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) { @@ -400,7 +446,8 @@ PP(pp_prototype) } str[n++] = '\0'; ret = sv_2mortal(newSVpv(str, n - 1)); - } else if (code) /* Non-Overridable */ + } + else if (code) /* Non-Overridable */ goto set; else { /* None such */ nonesuch: @@ -419,7 +466,7 @@ PP(pp_prototype) PP(pp_anoncode) { djSP; - CV* cv = (CV*)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); @@ -438,8 +485,13 @@ PP(pp_refgen) { djSP; dMARK; if (GIMME != G_ARRAY) { - MARK[1] = *SP; - SP = MARK + 1; + if (++MARK <= SP) + *MARK = *SP; + else + *MARK = &PL_sv_undef; + *MARK = refto(*MARK); + SP = MARK; + RETURN; } EXTEND_MORTAL(SP - MARK); while (++MARK <= SP) @@ -447,7 +499,7 @@ PP(pp_refgen) RETURN; } -static SV* +STATIC SV* refto(SV *sv) { SV* rv; @@ -456,7 +508,7 @@ refto(SV *sv) if (LvTARGLEN(sv)) vivify_defelem(sv); if (!(sv = LvTARG(sv))) - sv = &sv_undef; + sv = &PL_sv_undef; } else if (SvPADTMP(sv)) sv = newSVsv(sv); @@ -497,9 +549,16 @@ PP(pp_bless) HV *stash; if (MAXARG == 1) - stash = curcop->cop_stash; - else - stash = gv_stashsv(POPs, TRUE); + stash = PL_curcop->cop_stash; + else { + SV *ssv = POPs; + STRLEN len; + char *ptr = SvPV(ssv,len); + if (ckWARN(WARN_UNSAFE) && len == 0) + warner(WARN_UNSAFE, + "Explicit blessing to '' (assuming package main)"); + stash = gv_stashpvn(ptr, len, TRUE); + } (void)sv_bless(TOPs, stash); RETURN; @@ -509,40 +568,41 @@ PP(pp_gelem) { GV *gv; SV *sv; - SV *ref; + SV *tmpRef; char *elem; djSP; - + STRLEN n_a; + sv = POPs; - elem = SvPV(sv, na); + elem = SvPV(sv, n_a); gv = (GV*)POPs; - ref = Nullsv; + tmpRef = Nullsv; sv = Nullsv; switch (elem ? *elem : '\0') { case 'A': if (strEQ(elem, "ARRAY")) - ref = (SV*)GvAV(gv); + tmpRef = (SV*)GvAV(gv); break; case 'C': if (strEQ(elem, "CODE")) - ref = (SV*)GvCVu(gv); + tmpRef = (SV*)GvCVu(gv); break; case 'F': if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ - ref = (SV*)GvIOp(gv); + tmpRef = (SV*)GvIOp(gv); break; case 'G': if (strEQ(elem, "GLOB")) - ref = (SV*)gv; + tmpRef = (SV*)gv; break; case 'H': if (strEQ(elem, "HASH")) - ref = (SV*)GvHV(gv); + tmpRef = (SV*)GvHV(gv); break; case 'I': if (strEQ(elem, "IO")) - ref = (SV*)GvIOp(gv); + tmpRef = (SV*)GvIOp(gv); break; case 'N': if (strEQ(elem, "NAME")) @@ -554,15 +614,15 @@ PP(pp_gelem) break; case 'S': if (strEQ(elem, "SCALAR")) - ref = GvSV(gv); + tmpRef = GvSV(gv); break; } - if (ref) - sv = newRV(ref); + if (tmpRef) + sv = newRV(tmpRef); if (sv) sv_2mortal(sv); else - sv = &sv_undef; + sv = &PL_sv_undef; XPUSHs(sv); RETURN; } @@ -580,44 +640,36 @@ PP(pp_study) register I32 *snext; STRLEN len; - if(unop->op_first && unop->op_first->op_type == OP_PUSHRE) { - PMOP *pm = (PMOP *)unop->op_first; - SV *rv = sv_newmortal(); - sv = newSVrv(rv, "Regexp"); - sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0); - RETURNX(PUSHs(rv)); - } - - if (sv == lastscream) { + if (sv == PL_lastscream) { if (SvSCREAM(sv)) RETPUSHYES; } else { - if (lastscream) { - SvSCREAM_off(lastscream); - SvREFCNT_dec(lastscream); + if (PL_lastscream) { + SvSCREAM_off(PL_lastscream); + SvREFCNT_dec(PL_lastscream); } - lastscream = SvREFCNT_inc(sv); + PL_lastscream = SvREFCNT_inc(sv); } s = (unsigned char*)(SvPV(sv, len)); pos = len; if (pos <= 0) RETPUSHNO; - if (pos > maxscream) { - if (maxscream < 0) { - maxscream = pos + 80; - New(301, screamfirst, 256, I32); - New(302, screamnext, maxscream, I32); + if (pos > PL_maxscream) { + if (PL_maxscream < 0) { + PL_maxscream = pos + 80; + New(301, PL_screamfirst, 256, I32); + New(302, PL_screamnext, PL_maxscream, I32); } else { - maxscream = pos + pos / 4; - Renew(screamnext, maxscream, I32); + PL_maxscream = pos + pos / 4; + Renew(PL_screamnext, PL_maxscream, I32); } } - sfirst = screamfirst; - snext = screamnext; + sfirst = PL_screamfirst; + snext = PL_screamnext; if (!sfirst || !snext) DIE("do_study: out of memory"); @@ -645,14 +697,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; } @@ -703,11 +755,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: @@ -728,7 +780,7 @@ PP(pp_undef) djSP; SV *sv; - if (!op->op_private) { + if (!PL_op->op_private) { EXTEND(SP, 1); RETPUSHUNDEF; } @@ -738,8 +790,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); } @@ -754,8 +809,8 @@ PP(pp_undef) hv_undef((HV*)sv); break; case SVt_PVCV: - if (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: @@ -765,7 +820,17 @@ PP(pp_undef) break; case SVt_PVGV: if (SvFAKE(sv)) - sv_setsv(sv, &sv_undef); + SvSetMagicSV(sv, &PL_sv_undef); + else { + GP *gp; + gp_free((GV*)sv); + Newz(602, gp, 1, GP); + GvGP(sv) = gp_ref(gp); + GvSV(sv) = NEWSV(72,0); + GvLINE(sv) = PL_curcop->cop_line; + GvEGV(sv) = (GV*)sv; + GvMULTI_on(sv); + } break; default: if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) { @@ -785,7 +850,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) { @@ -802,7 +867,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) @@ -823,7 +888,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) @@ -876,7 +941,8 @@ PP(pp_divide) (double)I_V(right) == right && (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) { value = k; - } else { + } + else { value = left / right; } } @@ -890,7 +956,7 @@ PP(pp_divide) PP(pp_modulo) { - djSP; dATARGET; tryAMAGICbin(mod,opASSIGN); + djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { UV left; UV right; @@ -942,7 +1008,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; @@ -969,7 +1035,7 @@ PP(pp_repeat) tmpstr = POPs; if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) { - if (SvREADONLY(tmpstr) && curcop != &compiling) + if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling) DIE("Can't x= to readonly value"); if (SvROK(tmpstr)) sv_unref(tmpstr); @@ -1008,7 +1074,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)); @@ -1027,7 +1093,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)); @@ -1105,7 +1171,7 @@ PP(pp_ncmp) else if (left > right) value = 1; else { - SETs(&sv_undef); + SETs(&PL_sv_undef); RETURN; } SETi(value); @@ -1118,7 +1184,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)); @@ -1131,7 +1197,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)); @@ -1144,7 +1210,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)); @@ -1157,7 +1223,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)); @@ -1190,7 +1256,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 ); @@ -1204,7 +1270,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)); } @@ -1214,7 +1280,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; @@ -1227,7 +1293,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)); } @@ -1237,7 +1303,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; @@ -1250,7 +1316,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)); } @@ -1260,7 +1326,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; @@ -1289,6 +1355,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; @@ -1301,10 +1371,8 @@ PP(pp_negate) PP(pp_not) { -#ifdef OVERLOAD djSP; tryAMAGICunSET(not); -#endif /* OVERLOAD */ - *stack_sp = boolSV(!SvTRUE(*stack_sp)); + *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); return NORMAL; } @@ -1314,7 +1382,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)); } @@ -1376,7 +1444,7 @@ PP(pp_i_divide) PP(pp_i_modulo) { - djSP; dATARGET; tryAMAGICbin(mod,opASSIGN); + djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -1527,6 +1595,21 @@ 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 +*/ +/* 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) { djSP; dTARGET; @@ -1537,23 +1620,11 @@ PP(pp_rand) value = POPn; if (value == 0.0) value = 1.0; - if (!srand_called) { - (void)srand((unsigned)seed()); - srand_called = TRUE; + if (!PL_srand_called) { + (void)seedDrand01((Rand_seed_t)seed()); + PL_srand_called = TRUE; } -#if RANDBITS == 31 - value = rand() * value / 2147483648.0; -#else -#if RANDBITS == 16 - value = rand() * value / 65536.0; -#else -#if RANDBITS == 15 - value = rand() * value / 32768.0; -#else - value = rand() * value / (double)(((unsigned long)1) << RANDBITS); -#endif -#endif -#endif + value *= Drand01(); XPUSHn(value); RETURN; } @@ -1566,22 +1637,22 @@ PP(pp_srand) anum = seed(); else anum = POPu; - (void)srand((unsigned)anum); - srand_called = TRUE; + (void)seedDrand01((Rand_seed_t)anum); + PL_srand_called = TRUE; EXTEND(SP, 1); RETPUSHYES; } -static U32 +STATIC U32 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. @@ -1598,27 +1669,56 @@ 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 #endif u += SEED_C3 * (U32)getpid(); - u += SEED_C4 * (U32)(UV)stack_sp; + u += SEED_C4 * (U32)(UV)PL_stack_sp; #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ u += SEED_C5 * (U32)(UV)&when; #endif @@ -1724,8 +1824,9 @@ PP(pp_hex) djSP; dTARGET; char *tmps; I32 argtype; + STRLEN n_a; - tmps = POPp; + tmps = POPpx; XPUSHu(scan_hex(tmps, 99, &argtype)); RETURN; } @@ -1736,14 +1837,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); @@ -1755,6 +1859,12 @@ PP(pp_oct) PP(pp_length) { djSP; dTARGET; + + if (IN_UTF8) { + SETi( sv_len_utf8(TOPs) ); + RETURN; + } + SETi( sv_len(TOPs) ); RETURN; } @@ -1765,65 +1875,89 @@ 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 = curcop->cop_arybase; - - if (MAXARG > 2) + I32 arybase = PL_curcop->cop_arybase; + char *repl = 0; + STRLEN repl_len; + + SvTAINTED_off(TARG); /* decontaminate */ + if (MAXARG > 2) { + if (MAXARG > 3) { + sv = POPs; + repl = SvPV(sv, repl_len); + } len = POPi; + } pos = POPi; 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; fail = rem; - if (MAXARG > 2) { - if (len < 0) { - rem += len; - if (rem < 0) - rem = 0; - } - else if (rem > len) - rem = len; - } + if (MAXARG > 2) { + if (len < 0) { + rem += len; + if (rem < 0) + rem = 0; + } + else if (rem > len) + rem = len; + } } else { - pos += curlen; - if (MAXARG < 3) - rem = curlen; - else if (len >= 0) { - rem = pos+len; - if (rem > (I32)curlen) - rem = curlen; - } - else { - rem = curlen+len; - if (rem < pos) - rem = pos; - } - if (pos < 0) - pos = 0; - fail = rem; - rem -= pos; + pos += curlen; + if (MAXARG < 3) + rem = curlen; + else if (len >= 0) { + rem = pos+len; + if (rem > (I32)curlen) + rem = curlen; + } + else { + rem = curlen+len; + if (rem < pos) + rem = pos; + } + if (pos < 0) + pos = 0; + fail = rem; + rem -= pos; } if (fail < 0) { - if (dowarn || lvalue) - 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,na); - if (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); @@ -1837,11 +1971,18 @@ PP(pp_substr) } LvTYPE(TARG) = 'x'; - LvTARG(TARG) = sv; + if (LvTARG(TARG) != sv) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(sv); + } LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; } + else if (repl) + sv_insert(sv, pos, rem, repl, repl_len); } + SPAGAIN; PUSHs(TARG); /* avoid SvSETMAGIC here */ RETURN; } @@ -1852,12 +1993,13 @@ 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; I32 len; + SvTAINTED_off(TARG); /* decontaminate */ offset *= size; /* turn into bit offset */ len = (offset + size + 7) / 8; if (offset < 0 || size < 1) @@ -1870,7 +2012,11 @@ PP(pp_vec) } LvTYPE(TARG) = 'v'; - LvTARG(TARG) = src; + if (LvTARG(TARG) != src) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(src); + } LvTARGOFF(TARG) = offset; LvTARGLEN(TARG) = size; } @@ -1930,7 +2076,7 @@ PP(pp_index) char *tmps; char *tmps2; STRLEN biglen; - I32 arybase = curcop->cop_arybase; + I32 arybase = PL_curcop->cop_arybase; if (MAXARG < 3) offset = 0; @@ -1939,16 +2085,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))) - retval = -1 + arybase; + (unsigned char*)tmps + biglen, little, 0))) + 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; } @@ -1959,33 +2109,37 @@ PP(pp_rindex) SV *little; STRLEN blen; STRLEN llen; - SV *offstr; I32 offset; I32 retval; char *tmps; char *tmps2; - I32 arybase = curcop->cop_arybase; + 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; } @@ -1993,7 +2147,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(); @@ -2008,19 +2162,16 @@ PP(pp_sprintf) PP(pp_ord) { djSP; dTARGET; - I32 value; - char *tmps; + UV value; + STRLEN n_a; + U8 *tmps = (U8*)POPpx; + I32 retlen; -#ifndef I286 - tmps = POPp; - value = (I32) (*tmps & 255); -#else - I32 anum; - tmps = POPp; - anum = (I32) *tmps; - value = (I32) (anum & 255); -#endif - XPUSHi(value); + if (IN_UTF8 && (*tmps & 0x80)) + value = utf8_to_uv(tmps, &retlen); + else + value = (UV)(*tmps & 255); + XPUSHu(value); RETURN; } @@ -2028,12 +2179,25 @@ PP(pp_chr) { djSP; dTARGET; char *tmps; + U32 value = POPu; (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); @@ -2043,12 +2207,13 @@ PP(pp_chr) PP(pp_crypt) { djSP; dTARGET; dPOPTOPssrl; + STRLEN n_a; #ifdef HAS_CRYPT - char *tmps = SvPV(left, na); + char *tmps = SvPV(left, n_a); #ifdef FCRYPT - sv_setpv(TARG, fcrypt(tmps, SvPV(right, na))); + sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); #else - sv_setpv(TARG, crypt(tmps, SvPV(right, na))); + sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); #endif #else DIE( @@ -2062,7 +2227,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; @@ -2070,9 +2265,9 @@ PP(pp_ucfirst) sv = TARG; SETs(sv); } - s = SvPV_force(sv, na); + s = (U8*)SvPV_force(sv, slen); if (*s) { - if (op->op_private & OPpLOCALE) { + if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); *s = toUPPER_LC(*s); @@ -2088,7 +2283,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; @@ -2096,9 +2321,9 @@ PP(pp_lcfirst) sv = TARG; SETs(sv); } - s = SvPV_force(sv, na); + s = (U8*)SvPV_force(sv, slen); if (*s) { - if (op->op_private & OPpLOCALE) { + if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); *s = toLOWER_LC(*s); @@ -2115,9 +2340,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); @@ -2125,11 +2388,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++) @@ -2147,9 +2410,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); @@ -2157,11 +2458,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++) @@ -2187,10 +2488,30 @@ PP(pp_quotemeta) (void)SvUPGRADE(TARG, SVt_PV); SvGROW(TARG, (len * 2) + 1); d = SvPVX(TARG); - while (len--) { - if (!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)); @@ -2209,14 +2530,14 @@ PP(pp_aslice) djSP; dMARK; dORIGMARK; register SV** svp; register AV* av = (AV*)POPs; - register I32 lval = op->op_flags & OPf_MOD; - I32 arybase = curcop->cop_arybase; + 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++) { + for (svp = MARK + 1; svp <= SP; svp++) { elem = SvIVx(*svp); if (elem > max) max = elem; @@ -2231,12 +2552,12 @@ PP(pp_aslice) elem -= arybase; svp = av_fetch(av, elem, lval); if (lval) { - if (!svp || *svp == &sv_undef) - DIE(no_aelem, elem); - if (op->op_private & OPpLVAL_INTRO) - save_svref(svp); + if (!svp || *svp == &PL_sv_undef) + DIE(PL_no_aelem, elem); + if (PL_op->op_private & OPpLVAL_INTRO) + save_aelem(av, elem, svp); } - *MARK = svp ? *svp : &sv_undef; + *MARK = svp ? *svp : &PL_sv_undef; } } if (GIMME != G_ARRAY) { @@ -2298,7 +2619,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; @@ -2306,11 +2627,9 @@ PP(pp_delete) while (++MARK <= SP) { if (hvtype == SVt_PVHV) sv = hv_delete_ent(hv, *MARK, discard, 0); - else if (hvtype == SVt_PVAV) - sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0); else DIE("Not a HASH reference"); - *MARK = sv ? sv : &sv_undef; + *MARK = sv ? sv : &PL_sv_undef; } if (discard) SP = ORIGMARK; @@ -2325,12 +2644,10 @@ PP(pp_delete) hv = (HV*)POPs; if (SvTYPE(hv) == SVt_PVHV) sv = hv_delete_ent(hv, keysv, discard, 0); - else if (SvTYPE(hv) == SVt_PVAV) - sv = avhv_delete_ent((AV*)hv, keysv, discard, 0); else DIE("Not a HASH reference"); if (!sv) - sv = &sv_undef; + sv = &PL_sv_undef; if (!discard) PUSHs(sv); } @@ -2345,10 +2662,12 @@ PP(pp_exists) if (SvTYPE(hv) == SVt_PVHV) { if (hv_exists_ent(hv, tmpsv, 0)) RETPUSHYES; - } else if (SvTYPE(hv) == SVt_PVAV) { + } + else if (SvTYPE(hv) == SVt_PVAV) { if (avhv_exists_ent((AV*)hv, tmpsv, 0)) RETPUSHYES; - } else { + } + else { DIE("Not a HASH reference"); } RETPUSHNO; @@ -2357,28 +2676,33 @@ PP(pp_exists) PP(pp_hslice) { djSP; dMARK; dORIGMARK; - register HE *he; 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; SV **svp; if (realhv) { - he = hv_fetch_ent(hv, keysv, lval, 0); + HE *he = hv_fetch_ent(hv, keysv, lval, 0); svp = he ? &HeVAL(he) : 0; - } else { + } + else { svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0); } if (lval) { - if (!he || HeVAL(he) == &sv_undef) - DIE(no_helem, SvPV(keysv, na)); - if (op->op_private & OPpLVAL_INTRO) - save_svref(&HeVAL(he)); + 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); } - *MARK = he ? HeVAL(he) : &sv_undef; + *MARK = svp ? *svp : &PL_sv_undef; } } if (GIMME != G_ARRAY) { @@ -2398,7 +2722,7 @@ PP(pp_list) if (++MARK <= SP) *MARK = *SP; /* unwanted list, return last item */ else - *MARK = &sv_undef; + *MARK = &PL_sv_undef; SP = MARK; } RETURN; @@ -2407,12 +2731,12 @@ PP(pp_list) PP(pp_lslice) { djSP; - SV **lastrelem = stack_sp; - SV **lastlelem = stack_base + POPMARK; - SV **firstlelem = stack_base + POPMARK + 1; + SV **lastrelem = PL_stack_sp; + SV **lastlelem = PL_stack_base + POPMARK; + SV **firstlelem = PL_stack_base + POPMARK + 1; register SV **firstrelem = lastlelem + 1; - I32 arybase = curcop->cop_arybase; - I32 lval = op->op_flags & OPf_MOD; + I32 arybase = PL_curcop->cop_arybase; + I32 lval = PL_op->op_flags & OPf_MOD; I32 is_something_there = lval; register I32 max = lastrelem - lastlelem; @@ -2426,7 +2750,7 @@ PP(pp_lslice) else ix -= arybase; if (ix < 0 || ix >= max) - *firstlelem = &sv_undef; + *firstlelem = &PL_sv_undef; else *firstlelem = firstrelem[ix]; SP = firstlelem; @@ -2443,14 +2767,14 @@ PP(pp_lslice) if (ix < 0) { ix += max; if (ix < 0) - *lelem = &sv_undef; + *lelem = &PL_sv_undef; else if (!(*lelem = firstrelem[ix])) - *lelem = &sv_undef; + *lelem = &PL_sv_undef; } else { ix -= arybase; if (ix >= max || !(*lelem = firstrelem[ix])) - *lelem = &sv_undef; + *lelem = &PL_sv_undef; } if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem))) is_something_there = TRUE; @@ -2482,8 +2806,8 @@ PP(pp_anonhash) SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); - else if (dowarn) - warn("Odd number of elements in hash list"); + 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; @@ -2506,8 +2830,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; @@ -2524,13 +2848,16 @@ PP(pp_splice) if (offset < 0) offset += AvFILLp(ary) + 1; else - offset -= curcop->cop_arybase; + 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) - length = 0; + if (length < 0) { + length += AvFILLp(ary) - offset + 1; + if (length < 0) + length = 0; + } } else length = AvMAX(ary) + 1; /* close enough to infinity */ @@ -2553,12 +2880,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) { @@ -2573,8 +2896,7 @@ PP(pp_splice) if (AvREAL(ary)) { EXTEND_MORTAL(length); for (i = length, dst = MARK; i; i--) { - if (!SvIMMORTAL(*dst)) - sv_2mortal(*dst); /* free them eventualy */ + sv_2mortal(*dst); /* free them eventualy */ dst++; } } @@ -2583,8 +2905,7 @@ PP(pp_splice) else { *MARK = AvARRAY(ary)[offset+length-1]; if (AvREAL(ary)) { - if (!SvIMMORTAL(*MARK)) - sv_2mortal(*MARK); + sv_2mortal(*MARK); for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) SvREFCNT_dec(*dst++); /* free them now */ } @@ -2615,7 +2936,7 @@ PP(pp_splice) } i = -diff; while (i) - dst[--i] = &sv_undef; + dst[--i] = &PL_sv_undef; if (newlen) { for (src = tmparyval, dst = AvARRAY(ary) + offset; @@ -2672,8 +2993,7 @@ PP(pp_splice) if (AvREAL(ary)) { EXTEND_MORTAL(length); for (i = length, dst = MARK; i; i--) { - if (!SvIMMORTAL(*dst)) - sv_2mortal(*dst); /* free them eventualy */ + sv_2mortal(*dst); /* free them eventualy */ dst++; } } @@ -2684,15 +3004,14 @@ PP(pp_splice) else if (length--) { *MARK = tmparyval[length]; if (AvREAL(ary)) { - if (!SvIMMORTAL(*MARK)) - sv_2mortal(*MARK); + sv_2mortal(*MARK); while (length-- > 0) SvREFCNT_dec(tmparyval[length]); } Safefree(tmparyval); } else - *MARK = &sv_undef; + *MARK = &PL_sv_undef; } SP = MARK; RETURN; @@ -2702,11 +3021,11 @@ PP(pp_push) { djSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; - register SV *sv = &sv_undef; + 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; @@ -2733,7 +3052,7 @@ PP(pp_pop) djSP; AV *av = (AV*)POPs; SV *sv = av_pop(av); - if (!SvIMMORTAL(sv) && AvREAL(av)) + if (AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); RETURN; @@ -2747,7 +3066,7 @@ PP(pp_shift) EXTEND(SP, 1); if (!sv) RETPUSHUNDEF; - if (!SvIMMORTAL(sv) && AvREAL(av)) + if (AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); RETURN; @@ -2761,8 +3080,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; @@ -2806,11 +3125,36 @@ PP(pp_reverse) STRLEN len; if (SP - MARK > 1) - do_join(TARG, &sv_no, MARK, SP); + do_join(TARG, &PL_sv_no, MARK, SP); else 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; @@ -2825,7 +3169,7 @@ PP(pp_reverse) RETURN; } -static SV * +STATIC SV * mul128(SV *sv, U8 m) { STRLEN len; @@ -2834,11 +3178,11 @@ mul128(SV *sv, U8 m) U32 i = 0; if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ - SV *New = newSVpv("0000000000", 10); + SV *tmpNew = newSVpv("0000000000", 10); - sv_catsv(New, sv); + sv_catsv(tmpNew, sv); SvREFCNT_dec(sv); /* free old sv */ - sv = New; + sv = tmpNew; s = SvPV(sv, len); } t = s + len - 1; @@ -2854,11 +3198,22 @@ mul128(SV *sv, U8 m) /* Explosives and implosives. */ +#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(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') +#endif + PP(pp_unpack) { djSP; dPOPPOPssrl; - SV **oldsp = sp; + SV **oldsp = SP; I32 gimme = GIMME_V; SV *sv; STRLEN llen; @@ -2883,7 +3238,7 @@ PP(pp_unpack) unsigned int auint; U32 aulong; #ifdef HAS_QUAD - unsigned Quad_t auquad; + Uquad_t auquad; #endif char *aptr; float afloat; @@ -2891,13 +3246,16 @@ PP(pp_unpack) I32 checksum = 0; register U32 culong; double cdouble; - static char* bitcount = 0; int commas = 0; +#ifdef PERL_NATINT_PACK + int natint; /* native integer */ + int unatint; /* unsigned native integer */ +#endif 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++; @@ -2908,8 +3266,23 @@ PP(pp_unpack) while (pat < patend) { reparse: datumtype = *pat++ & 0xFF; +#ifdef PERL_NATINT_PACK + natint = 0; +#endif if (isSPACE(datumtype)) continue; + if (*pat == '_') { + char *natstr = "sSiIlL"; + + if (strchr(natstr, datumtype)) { +#ifdef PERL_NATINT_PACK + natint = 1; +#endif + pat++; + } + else + croak("'_' allowed only after types %s", natstr); + } if (pat >= patend) len = 1; else if (*pat == '*') { @@ -2927,8 +3300,8 @@ PP(pp_unpack) default: croak("Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ - if (commas++ == 0 && 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') @@ -2955,6 +3328,7 @@ PP(pp_unpack) s += len; break; case 'A': + case 'Z': case 'a': if (len > strend - s) len = strend - s; @@ -2963,12 +3337,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 */ } @@ -2979,21 +3360,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) { @@ -3058,7 +3439,7 @@ PP(pp_unpack) bits >>= 4; else bits = *s++; - *pat++ = hexdigit[bits & 15]; + *pat++ = PL_hexdigit[bits & 15]; } } else { @@ -3068,7 +3449,7 @@ PP(pp_unpack) bits <<= 4; else bits = *s++; - *pat++ = hexdigit[(bits >> 4) & 15]; + *pat++ = PL_hexdigit[(bits >> 4) & 15]; } } *pat = '\0'; @@ -3120,67 +3501,162 @@ 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; + 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((U8*)s, &along); + s += along; + sv = NEWSV(37, 0); + sv_setuv(sv, (UV)auint); + PUSHs(sv_2mortal(sv)); + } + } + break; case 's': +#if SHORTSIZE == SIZE16 along = (strend - s) / SIZE16; +#else + along = (strend - s) / (natint ? sizeof(short) : SIZE16); +#endif if (len > along) len = along; if (checksum) { - while (len-- > 0) { - COPY16(s, &ashort); - s += SIZE16; - culong += ashort; +#if SHORTSIZE != SIZE16 + if (natint) { + while (len-- > 0) { + COPYNN(s, &ashort, sizeof(short)); + s += sizeof(short); + culong += ashort; + + } + } + else +#endif + { + while (len-- > 0) { + COPY16(s, &ashort); +#if SHORTSIZE > SIZE16 + if (ashort > 32767) + ashort -= 65536; +#endif + s += SIZE16; + culong += ashort; + } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); - while (len-- > 0) { - COPY16(s, &ashort); - s += SIZE16; - sv = NEWSV(38, 0); - sv_setiv(sv, (IV)ashort); - PUSHs(sv_2mortal(sv)); +#if SHORTSIZE != SIZE16 + if (natint) { + while (len-- > 0) { + COPYNN(s, &ashort, sizeof(short)); + s += sizeof(short); + sv = NEWSV(38, 0); + sv_setiv(sv, (IV)ashort); + PUSHs(sv_2mortal(sv)); + } + } + else +#endif + { + while (len-- > 0) { + COPY16(s, &ashort); +#if SHORTSIZE > SIZE16 + if (ashort > 32767) + ashort -= 65536; +#endif + s += SIZE16; + sv = NEWSV(38, 0); + sv_setiv(sv, (IV)ashort); + PUSHs(sv_2mortal(sv)); + } } } break; case 'v': case 'n': case 'S': +#if SHORTSIZE == SIZE16 along = (strend - s) / SIZE16; +#else + unatint = natint && datumtype == 'S'; + along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16); +#endif if (len > along) len = along; if (checksum) { - while (len-- > 0) { - COPY16(s, &aushort); - s += SIZE16; +#if SHORTSIZE != SIZE16 + if (unatint) { + while (len-- > 0) { + COPYNN(s, &aushort, sizeof(unsigned short)); + s += sizeof(unsigned short); + culong += aushort; + } + } + else +#endif + { + while (len-- > 0) { + COPY16(s, &aushort); + s += SIZE16; #ifdef HAS_NTOHS - if (datumtype == 'n') - aushort = PerlSock_ntohs(aushort); + if (datumtype == 'n') + aushort = PerlSock_ntohs(aushort); #endif #ifdef HAS_VTOHS - if (datumtype == 'v') - aushort = vtohs(aushort); + if (datumtype == 'v') + aushort = vtohs(aushort); #endif - culong += aushort; + culong += aushort; + } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); - while (len-- > 0) { - COPY16(s, &aushort); - s += SIZE16; - sv = NEWSV(39, 0); +#if SHORTSIZE != SIZE16 + if (unatint) { + while (len-- > 0) { + COPYNN(s, &aushort, sizeof(unsigned short)); + s += sizeof(unsigned short); + sv = NEWSV(39, 0); + sv_setiv(sv, (UV)aushort); + PUSHs(sv_2mortal(sv)); + } + } + else +#endif + { + while (len-- > 0) { + COPY16(s, &aushort); + s += SIZE16; + sv = NEWSV(39, 0); #ifdef HAS_NTOHS - if (datumtype == 'n') - aushort = PerlSock_ntohs(aushort); + if (datumtype == 'n') + aushort = PerlSock_ntohs(aushort); #endif #ifdef HAS_VTOHS - if (datumtype == 'v') - aushort = vtohs(aushort); + if (datumtype == 'v') + aushort = vtohs(aushort); #endif - sv_setiv(sv, (IV)aushort); - PUSHs(sv_2mortal(sv)); + sv_setiv(sv, (UV)aushort); + PUSHs(sv_2mortal(sv)); + } } } break; @@ -3205,6 +3681,13 @@ PP(pp_unpack) Copy(s, &aint, 1, int); s += sizeof(int); sv = NEWSV(40, 0); +#ifdef __osf__ + /* Without the dummy below unpack("i", pack("i",-1)) + * return 0xFFffFFff instead of -1 for Digital Unix V4.0 + * cc with optimization turned on */ + (aint) ? + sv_setiv(sv, (IV)aint) : +#endif sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } @@ -3231,78 +3714,164 @@ 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)); } } break; case 'l': +#if LONGSIZE == SIZE32 along = (strend - s) / SIZE32; +#else + along = (strend - s) / (natint ? sizeof(long) : SIZE32); +#endif if (len > along) len = along; if (checksum) { - while (len-- > 0) { - COPY32(s, &along); - s += SIZE32; - if (checksum > 32) - cdouble += (double)along; - else - culong += along; +#if LONGSIZE != SIZE32 + if (natint) { + while (len-- > 0) { + COPYNN(s, &along, sizeof(long)); + s += sizeof(long); + if (checksum > 32) + cdouble += (double)along; + else + culong += along; + } + } + else +#endif + { + while (len-- > 0) { + COPY32(s, &along); +#if LONGSIZE > SIZE32 + if (along > 2147483647) + along -= 4294967296; +#endif + s += SIZE32; + if (checksum > 32) + cdouble += (double)along; + else + culong += along; + } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); - while (len-- > 0) { - COPY32(s, &along); - s += SIZE32; - sv = NEWSV(42, 0); - sv_setiv(sv, (IV)along); - PUSHs(sv_2mortal(sv)); +#if LONGSIZE != SIZE32 + if (natint) { + while (len-- > 0) { + COPYNN(s, &along, sizeof(long)); + s += sizeof(long); + sv = NEWSV(42, 0); + sv_setiv(sv, (IV)along); + PUSHs(sv_2mortal(sv)); + } + } + else +#endif + { + while (len-- > 0) { + COPY32(s, &along); +#if LONGSIZE > SIZE32 + if (along > 2147483647) + along -= 4294967296; +#endif + s += SIZE32; + sv = NEWSV(42, 0); + sv_setiv(sv, (IV)along); + PUSHs(sv_2mortal(sv)); + } } } break; case 'V': case 'N': case 'L': +#if LONGSIZE == SIZE32 along = (strend - s) / SIZE32; +#else + unatint = natint && datumtype == 'L'; + along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32); +#endif if (len > along) len = along; if (checksum) { - while (len-- > 0) { - COPY32(s, &aulong); - s += SIZE32; +#if LONGSIZE != SIZE32 + if (unatint) { + while (len-- > 0) { + COPYNN(s, &aulong, sizeof(unsigned long)); + s += sizeof(unsigned long); + if (checksum > 32) + cdouble += (double)aulong; + else + culong += aulong; + } + } + else +#endif + { + while (len-- > 0) { + COPY32(s, &aulong); + s += SIZE32; #ifdef HAS_NTOHL - if (datumtype == 'N') - aulong = PerlSock_ntohl(aulong); + if (datumtype == 'N') + aulong = PerlSock_ntohl(aulong); #endif #ifdef HAS_VTOHL - if (datumtype == 'V') - aulong = vtohl(aulong); + if (datumtype == 'V') + aulong = vtohl(aulong); #endif - if (checksum > 32) - cdouble += (double)aulong; - else - culong += aulong; + if (checksum > 32) + cdouble += (double)aulong; + else + culong += aulong; + } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); - while (len-- > 0) { - COPY32(s, &aulong); - s += SIZE32; +#if LONGSIZE != SIZE32 + if (unatint) { + while (len-- > 0) { + COPYNN(s, &aulong, sizeof(unsigned long)); + s += sizeof(unsigned long); + sv = NEWSV(43, 0); + sv_setuv(sv, (UV)aulong); + PUSHs(sv_2mortal(sv)); + } + } + else +#endif + { + while (len-- > 0) { + COPY32(s, &aulong); + s += SIZE32; #ifdef HAS_NTOHL - if (datumtype == 'N') - aulong = PerlSock_ntohl(aulong); + if (datumtype == 'N') + aulong = PerlSock_ntohl(aulong); #endif #ifdef HAS_VTOHL - if (datumtype == 'V') - aulong = vtohl(aulong); + if (datumtype == 'V') + aulong = vtohl(aulong); #endif - sv = NEWSV(43, 0); - sv_setuv(sv, (UV)aulong); - PUSHs(sv_2mortal(sv)); + sv = NEWSV(43, 0); + sv_setuv(sv, (UV)aulong); + PUSHs(sv_2mortal(sv)); + } } } break; @@ -3344,6 +3913,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) { @@ -3353,7 +3923,7 @@ PP(pp_unpack) break; } } - t = SvPV(sv, na); + t = SvPV(sv, n_a); while (*t == '0') t++; sv_chop(sv, t); @@ -3381,6 +3951,9 @@ PP(pp_unpack) break; #ifdef HAS_QUAD case 'q': + along = (strend - s) / sizeof(Quad_t); + if (len > along) + len = along; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { @@ -3399,17 +3972,20 @@ PP(pp_unpack) } break; case 'Q': + along = (strend - s) / sizeof(Quad_t); + if (len > along) + len = along; 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 (aquad <= UV_MAX) + if (auquad <= UV_MAX) sv_setuv(sv, (UV)auquad); else sv_setnv(sv, (double)auquad); @@ -3467,31 +4043,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 (PL_uudmap['M'] == 0) { + int 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. + */ + PL_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 = PL_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 = PL_uudmap[*s++] & 077; + else + a = 0; + if (s < strend && ISUUCHAR(*s)) + b = PL_uudmap[*s++] & 077; + else + b = 0; + if (s < strend && ISUUCHAR(*s)) + c = PL_uudmap[*s++] & 077; + else + c = 0; + if (s < strend && ISUUCHAR(*s)) + d = PL_uudmap[*s++] & 077; else d = 0; hunk[0] = (a << 2) | (b >> 4); @@ -3511,7 +4104,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; @@ -3542,40 +4135,45 @@ PP(pp_unpack) checksum = 0; } } - if (sp == oldsp && gimme == G_SCALAR) - PUSHs(&sv_undef); + if (SP == oldsp && gimme == G_SCALAR) + PUSHs(&PL_sv_undef); RETURN; } -static void +STATIC void doencodes(register SV *sv, register char *s, register I32 len) { char hunk[5]; - *hunk = len + ' '; + *hunk = PL_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] = 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; } - for (s = SvPVX(sv); *s; s++) { - if (*s == ' ') - *s = '`'; + if (len > 0) { + char r = (len > 1 ? s[1] : '\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); } -static SV * +STATIC SV * is_an_int(char *s, STRLEN l) { + STRLEN n_a; SV *result = newSVpv("", l); - char *result_c = SvPV(result, na); /* convenience */ + char *result_c = SvPV(result, n_a); /* convenience */ char *out = result_c; bool skip = 1; bool ignore = 0; @@ -3619,7 +4217,7 @@ is_an_int(char *s, STRLEN l) return (result); } -static int +STATIC int div128(SV *pnum, bool *done) /* must be '\0' terminated */ @@ -3672,21 +4270,39 @@ PP(pp_pack) U32 aulong; #ifdef HAS_QUAD Quad_t aquad; - unsigned Quad_t auquad; + Uquad_t auquad; #endif char *aptr; float afloat; double adouble; int commas = 0; +#ifdef PERL_NATINT_PACK + int natint; /* native integer */ +#endif items = SP - MARK; MARK++; sv_setpvn(cat, "", 0); while (pat < patend) { -#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no) +#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no) datumtype = *pat++ & 0xFF; +#ifdef PERL_NATINT_PACK + natint = 0; +#endif if (isSPACE(datumtype)) continue; + if (*pat == '_') { + char *natstr = "sSiIlL"; + + if (strchr(natstr, datumtype)) { +#ifdef PERL_NATINT_PACK + natint = 1; +#endif + pat++; + } + else + croak("'_' allowed only after types %s", natstr); + } if (*pat == '*') { len = strchr("@Xxu", datumtype) ? 0 : items; pat++; @@ -3702,8 +4318,8 @@ PP(pp_pack) default: croak("Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ - if (commas++ == 0 && 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"); @@ -3731,6 +4347,7 @@ PP(pp_pack) sv_catpvn(cat, null10, len); break; case 'A': + case 'Z': case 'a': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); @@ -3882,6 +4499,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': @@ -3920,11 +4547,46 @@ PP(pp_pack) } break; case 'S': +#if SHORTSIZE != SIZE16 + if (natint) { + unsigned short aushort; + + while (len-- > 0) { + fromstr = NEXTFROM; + aushort = SvUV(fromstr); + sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short)); + } + } + else +#endif + { + U16 aushort; + + while (len-- > 0) { + fromstr = NEXTFROM; + aushort = (U16)SvUV(fromstr); + CAT16(cat, &aushort); + } + + } + break; case 's': - while (len-- > 0) { - fromstr = NEXTFROM; - ashort = (I16)SvIV(fromstr); - CAT16(cat, &ashort); +#if SHORTSIZE != SIZE16 + if (natint) { + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = SvIV(fromstr); + sv_catpvn(cat, (char *)&ashort, sizeof(short)); + } + } + else +#endif + { + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (I16)SvIV(fromstr); + CAT16(cat, &ashort); + } } break; case 'I': @@ -4032,25 +4694,49 @@ PP(pp_pack) } break; case 'L': - while (len-- > 0) { - fromstr = NEXTFROM; - aulong = SvUV(fromstr); - CAT32(cat, &aulong); +#if LONGSIZE != SIZE32 + if (natint) { + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = SvUV(fromstr); + sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long)); + } + } + else +#endif + { + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = SvUV(fromstr); + CAT32(cat, &aulong); + } } break; case 'l': - while (len-- > 0) { - fromstr = NEXTFROM; - along = SvIV(fromstr); - CAT32(cat, &along); +#if LONGSIZE != SIZE32 + if (natint) { + while (len-- > 0) { + fromstr = NEXTFROM; + along = SvIV(fromstr); + sv_catpvn(cat, (char *)&along, sizeof(long)); + } + } + else +#endif + { + while (len-- > 0) { + fromstr = NEXTFROM; + along = SvIV(fromstr); + CAT32(cat, &along); + } } break; #ifdef HAS_QUAD 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': @@ -4067,20 +4753,22 @@ PP(pp_pack) case 'p': while (len-- > 0) { fromstr = NEXTFROM; - if (fromstr == &sv_undef) + 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 (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,na); + aptr = SvPV(fromstr,n_a); else - aptr = SvPV_force(fromstr,na); + aptr = SvPV_force(fromstr,n_a); } sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } @@ -4135,9 +4823,9 @@ PP(pp_split) I32 origlimit = limit; I32 realarray = 0; I32 base; - AV *oldstack = curstack; + AV *oldstack = PL_curstack; I32 gimme = GIMME_V; - I32 oldsave = savestack_ix; + I32 oldsave = PL_savestack_ix; I32 make_mortal = 1; MAGIC *mg = (MAGIC *) NULL; @@ -4157,9 +4845,9 @@ 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(defgv); + ary = GvAVn(PL_defgv); #endif /* USE_THREADS */ else ary = Nullav; @@ -4169,22 +4857,22 @@ 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)) { AvREAL_on(ary); for (i = AvFILLp(ary); i >= 0; i--) - AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */ + AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ } /* temporarily switch stacks */ - SWITCHSTACK(curstack, ary); + SWITCHSTACK(PL_curstack, ary); make_mortal = 0; } } - base = SP - stack_base; + base = SP - PL_stack_base; orig = s; if (pm->op_pmflags & PMf_SKIPWHITE) { if (pm->op_pmflags & PMf_LOCALE) { @@ -4197,8 +4885,8 @@ PP(pp_split) } } if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { - SAVEINT(multiline); - multiline = pm->op_pmflags & PMf_MULTILINE; + SAVEINT(PL_multiline); + PL_multiline = pm->op_pmflags & PMf_MULTILINE; } if (!limit) @@ -4264,7 +4952,7 @@ PP(pp_split) #ifndef lint while (s < strend && --limit && (m=fbm_instr((unsigned char*)s, (unsigned char*)strend, - rx->check_substr)) ) + rx->check_substr, 0)) ) #endif { dstr = NEWSV(31, m-s); @@ -4279,7 +4967,7 @@ PP(pp_split) else { maxiters += (strend - s) * rx->nparens; while (s < strend && --limit && - regexec_flags(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 @@ -4316,7 +5004,7 @@ PP(pp_split) } LEAVE_SCOPE(oldsave); - iters = (SP - stack_base) - base; + iters = (SP - PL_stack_base) - base; if (iters > maxiters) DIE("Split loop"); @@ -4360,7 +5048,7 @@ PP(pp_split) EXTEND(SP, iters); for (i=0; i < iters; i++) { SV **svp = av_fetch(ary, i, FALSE); - PUSHs((svp) ? *svp : &sv_undef); + PUSHs((svp) ? *svp : &PL_sv_undef); } RETURN; } @@ -4392,7 +5080,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)); } @@ -4417,10 +5105,9 @@ 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 */ save_destructor(unlock_condpair, sv); } #endif /* USE_THREADS */ @@ -4436,11 +5123,11 @@ PP(pp_threadsv) { djSP; #ifdef USE_THREADS - EXTEND(sp, 1); - if (op->op_private & OPpLVAL_INTRO) - PUSHs(*save_threadsv(op->op_targ)); + EXTEND(SP, 1); + 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");