/* pp.c * * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "It's a big house this, and very peculiar. Always a bit more to discover, * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise */ #include "EXTERN.h" #define PERL_IN_PP_C #include "perl.h" /* * The compiler on Concurrent CX/UX systems has a subtle bug which only * seems to show up when compiling pp.c - it generates the wrong double * precision constant value for (double)UV_MAX when used inline in the body * of the code below, so this makes a static variable up front (which the * compiler seems to get correct) and uses it in place of UV_MAX below. */ #ifdef CXUX_BROKEN_CONSTANT_CONVERT static double UV_MAX_cxux = ((double)UV_MAX); #endif /* * Offset for integer pack/unpack. * * On architectures where I16 and I32 aren't really 16 and 32 bits, * which for now are all Crays, pack and unpack have to play games. */ /* * These values are required for portability of pack() output. * 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 appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE defines are now in config.h. --Andy Dougherty April 1998 */ #define SIZE16 2 #define SIZE32 4 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack(). --jhi Feb 1999 */ #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32 # define PERL_NATINT_PACK #endif #if LONGSIZE > 4 && defined(_CRAY) # if BYTEORDER == 0x12345678 # define OFF16(p) (char*)(p) # define OFF32(p) (char*)(p) # else # if BYTEORDER == 0x87654321 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) # else }}}} bad cray byte order # endif # 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 /* variations on pp_null */ #ifdef I_UNISTD #include #endif /* XXX I can't imagine anyone who doesn't have this actually _needs_ it, since pid_t is an integral type. --AD 2/20/1998 */ #ifdef NEED_GETPID_PROTO extern Pid_t getpid (void); #endif PP(pp_stub) { djSP; if (GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); RETURN; } PP(pp_scalar) { return NORMAL; } /* Pushy stuff. */ PP(pp_padav) { djSP; dTARGET; if (PL_op->op_private & OPpLVAL_INTRO) SAVECLEARSV(PL_curpad[PL_op->op_targ]); EXTEND(SP, 1); if (PL_op->op_flags & OPf_REF) { PUSHs(TARG); RETURN; } if (GIMME == G_ARRAY) { I32 maxarg = AvFILL((AV*)TARG) + 1; EXTEND(SP, maxarg); if (SvMAGICAL(TARG)) { U32 i; for (i=0; i < maxarg; i++) { SV **svp = av_fetch((AV*)TARG, i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } else { Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*); } SP += maxarg; } else { SV* sv = sv_newmortal(); I32 maxarg = AvFILL((AV*)TARG) + 1; sv_setiv(sv, maxarg); PUSHs(sv); } RETURN; } PP(pp_padhv) { djSP; dTARGET; I32 gimme; XPUSHs(TARG); 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) { RETURNOP(do_kv()); } else if (gimme == G_SCALAR) { SV* sv = sv_newmortal(); if (HvFILL((HV*)TARG)) Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1); else sv_setiv(sv, 0); SETs(sv); } RETURN; } PP(pp_padany) { DIE(aTHX_ "NOT IMPL LINE %d",__LINE__); } /* Translations. */ PP(pp_rv2gv) { djSP; dTOPss; if (SvROK(sv)) { wasref: tryAMAGICunDEREF(to_gv); sv = SvRV(sv); if (SvTYPE(sv) == SVt_PVIO) { GV *gv = (GV*) sv_newmortal(); gv_init(gv, 0, "", 0, 0); GvIOp(gv) = (IO *)sv; (void)SvREFCNT_inc(sv); sv = (SV*) gv; } else if (SvTYPE(sv) != SVt_PVGV) DIE(aTHX_ "Not a GLOB reference"); } else { if (SvTYPE(sv) != SVt_PVGV) { char *sym; STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) goto wasref; } if (!SvOK(sv) && sv != &PL_sv_undef) { /* If this is a 'my' scalar and flag is set then vivify * NI-S 1999/05/07 */ if (PL_op->op_private & OPpDEREF) { char *name; GV *gv; if (cUNOP->op_targ) { STRLEN len; SV *namesv = PL_curpad[cUNOP->op_targ]; name = SvPV(namesv, len); gv = (GV*)NEWSV(0,0); gv_init(gv, CopSTASH(PL_curcop), name, len, 0); } else { name = CopSTASHPV(PL_curcop); gv = newGVgen(name); } sv_upgrade(sv, SVt_RV); SvRV(sv) = (SV*)gv; SvROK_on(sv); SvSETMAGIC(sv); goto wasref; } if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a symbol"); if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); RETSETUNDEF; } sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV); if (!sv && (!is_gv_magical(sym,len,0) || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV)))) { RETSETUNDEF; } } else { if (PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_symref, sym, "a symbol"); sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); } } } if (PL_op->op_private & OPpLVAL_INTRO) save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL)); SETs(sv); RETURN; } PP(pp_rv2sv) { djSP; dTOPss; if (SvROK(sv)) { wasref: tryAMAGICunDEREF(to_sv); sv = SvRV(sv); switch (SvTYPE(sv)) { case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: DIE(aTHX_ "Not a SCALAR reference"); } } else { GV *gv = (GV*)sv; char *sym; STRLEN len; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) goto wasref; } if (!SvOK(sv)) { if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a SCALAR"); if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); RETSETUNDEF; } sym = SvPV(sv, len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV); if (!gv && (!is_gv_magical(sym,len,0) || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV)))) { RETSETUNDEF; } } else { if (PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_symref, sym, "a SCALAR"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); } } sv = GvSV(gv); } if (PL_op->op_flags & OPf_MOD) { if (PL_op->op_private & OPpLVAL_INTRO) sv = save_scalar((GV*)TOPs); else if (PL_op->op_private & OPpDEREF) vivify_ref(sv, PL_op->op_private & OPpDEREF); } SETs(sv); RETURN; } PP(pp_av2arylen) { djSP; AV *av = (AV*)TOPs; SV *sv = AvARYLEN(av); if (!sv) { AvARYLEN(av) = sv = NEWSV(0,0); sv_upgrade(sv, SVt_IV); sv_magic(sv, (SV*)av, '#', Nullch, 0); } SETs(sv); RETURN; } PP(pp_pos) { djSP; dTARGET; dPOPss; 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) = '.'; if (LvTARG(TARG) != sv) { if (LvTARG(TARG)) SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc(sv); } PUSHs(TARG); /* no SvSETMAGIC */ RETURN; } else { MAGIC* mg; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { mg = mg_find(sv, 'g'); if (mg && mg->mg_len >= 0) { I32 i = mg->mg_len; if (DO_UTF8(sv)) sv_pos_b2u(sv, &i); PUSHi(i + PL_curcop->cop_arybase); RETURN; } } RETPUSHUNDEF; } } PP(pp_rv2cv) { djSP; GV *gv; HV *stash; /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ /* (But not in defined().) */ 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)); if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv)) DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } else cv = (CV*)&PL_sv_undef; SETs((SV*)cv); RETURN; } PP(pp_prototype) { djSP; CV *cv; HV *stash; GV *gv; SV *ret; ret = &PL_sv_undef; if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { char *s = SvPVX(TOPs); if (strnEQ(s, "CORE::", 6)) { int code; code = keyword(s + 6, SvCUR(TOPs) - 6); if (code < 0) { /* Overridable. */ #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) int i = 0, n = 0, seen_question = 0; I32 oa; char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ while (i < MAXO) { /* The slow way. */ 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 = PL_opargs[i] >> OASHIFT; while (oa) { if (oa & OA_OPTIONAL) { seen_question = 1; str[n++] = ';'; } else if (n && str[0] == ';' && seen_question) goto set; /* XXXX system, exec */ if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) { str[n++] = '\\'; } /* What to do with R ((un)tie, tied, (sys)read, recv)? */ str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; oa = oa >> 4; } str[n++] = '\0'; ret = sv_2mortal(newSVpvn(str, n - 1)); } else if (code) /* Non-Overridable */ goto set; else { /* None such */ nonesuch: DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); } } } cv = sv_2cv(TOPs, &stash, &gv, FALSE); if (cv && SvPOK(cv)) ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv))); set: SETs(ret); RETURN; } PP(pp_anoncode) { djSP; CV* cv = (CV*)PL_curpad[PL_op->op_targ]; if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); EXTEND(SP,1); PUSHs((SV*)cv); RETURN; } PP(pp_srefgen) { djSP; *SP = refto(*SP); RETURN; } PP(pp_refgen) { djSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; else *MARK = &PL_sv_undef; *MARK = refto(*MARK); SP = MARK; RETURN; } EXTEND_MORTAL(SP - MARK); while (++MARK <= SP) *MARK = refto(*MARK); RETURN; } STATIC SV* S_refto(pTHX_ SV *sv) { SV* rv; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { if (LvTARGLEN(sv)) vivify_defelem(sv); if (!(sv = LvTARG(sv))) sv = &PL_sv_undef; else (void)SvREFCNT_inc(sv); } else if (SvTYPE(sv) == SVt_PVAV) { if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv)) av_reify((AV*)sv); SvTEMP_off(sv); (void)SvREFCNT_inc(sv); } else if (SvPADTMP(sv)) sv = newSVsv(sv); else { SvTEMP_off(sv); (void)SvREFCNT_inc(sv); } rv = sv_newmortal(); sv_upgrade(rv, SVt_RV); SvRV(rv) = sv; SvROK_on(rv); return rv; } PP(pp_ref) { djSP; dTARGET; SV *sv; char *pv; sv = POPs; if (sv && SvGMAGICAL(sv)) mg_get(sv); if (!sv || !SvROK(sv)) RETPUSHNO; sv = SvRV(sv); pv = sv_reftype(sv,TRUE); PUSHp(pv, strlen(pv)); RETURN; } PP(pp_bless) { djSP; HV *stash; if (MAXARG == 1) stash = CopSTASH(PL_curcop); else { SV *ssv = POPs; STRLEN len; char *ptr = SvPV(ssv,len); if (ckWARN(WARN_MISC) && len == 0) Perl_warner(aTHX_ WARN_MISC, "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, TRUE); } (void)sv_bless(TOPs, stash); RETURN; } PP(pp_gelem) { GV *gv; SV *sv; SV *tmpRef; char *elem; djSP; STRLEN n_a; sv = POPs; elem = SvPV(sv, n_a); gv = (GV*)POPs; tmpRef = Nullsv; sv = Nullsv; switch (elem ? *elem : '\0') { case 'A': if (strEQ(elem, "ARRAY")) tmpRef = (SV*)GvAV(gv); break; case 'C': if (strEQ(elem, "CODE")) tmpRef = (SV*)GvCVu(gv); break; case 'F': if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ tmpRef = (SV*)GvIOp(gv); else if (strEQ(elem, "FORMAT")) tmpRef = (SV*)GvFORM(gv); break; case 'G': if (strEQ(elem, "GLOB")) tmpRef = (SV*)gv; break; case 'H': if (strEQ(elem, "HASH")) tmpRef = (SV*)GvHV(gv); break; case 'I': if (strEQ(elem, "IO")) tmpRef = (SV*)GvIOp(gv); break; case 'N': if (strEQ(elem, "NAME")) sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); break; case 'P': if (strEQ(elem, "PACKAGE")) sv = newSVpv(HvNAME(GvSTASH(gv)), 0); break; case 'S': if (strEQ(elem, "SCALAR")) tmpRef = GvSV(gv); break; } if (tmpRef) sv = newRV(tmpRef); if (sv) sv_2mortal(sv); else sv = &PL_sv_undef; XPUSHs(sv); RETURN; } /* Pattern matching */ PP(pp_study) { djSP; dPOPss; register unsigned char *s; register I32 pos; register I32 ch; register I32 *sfirst; register I32 *snext; STRLEN len; if (sv == PL_lastscream) { if (SvSCREAM(sv)) RETPUSHYES; } else { if (PL_lastscream) { SvSCREAM_off(PL_lastscream); SvREFCNT_dec(PL_lastscream); } PL_lastscream = SvREFCNT_inc(sv); } s = (unsigned char*)(SvPV(sv, len)); pos = len; if (pos <= 0) RETPUSHNO; 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 { PL_maxscream = pos + pos / 4; Renew(PL_screamnext, PL_maxscream, I32); } } sfirst = PL_screamfirst; snext = PL_screamnext; if (!sfirst || !snext) DIE(aTHX_ "do_study: out of memory"); for (ch = 256; ch; --ch) *sfirst++ = -1; sfirst -= 256; while (--pos >= 0) { ch = s[pos]; if (sfirst[ch] >= 0) snext[pos] = sfirst[ch] - pos; else snext[pos] = -pos; sfirst[ch] = pos; } SvSCREAM_on(sv); sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */ RETPUSHYES; } PP(pp_trans) { djSP; dTARG; SV *sv; if (PL_op->op_flags & OPf_STACKED) sv = POPs; else { sv = DEFSV; EXTEND(SP,1); } TARG = sv_newmortal(); PUSHi(do_trans(sv)); RETURN; } /* Lvalue operators. */ PP(pp_schop) { djSP; dTARGET; do_chop(TARG, TOPs); SETTARG; RETURN; } PP(pp_chop) { djSP; dMARK; dTARGET; while (SP > MARK) do_chop(TARG, POPs); PUSHTARG; RETURN; } PP(pp_schomp) { djSP; dTARGET; SETi(do_chomp(TOPs)); RETURN; } PP(pp_chomp) { djSP; dMARK; dTARGET; register I32 count = 0; while (SP > MARK) count += do_chomp(POPs); PUSHi(count); RETURN; } PP(pp_defined) { djSP; register SV* sv; sv = POPs; if (!sv || !SvANY(sv)) RETPUSHNO; switch (SvTYPE(sv)) { case SVt_PVAV: if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P'))) RETPUSHYES; break; case SVt_PVHV: if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P'))) RETPUSHYES; break; case SVt_PVCV: if (CvROOT(sv) || CvXSUB(sv)) RETPUSHYES; break; default: if (SvGMAGICAL(sv)) mg_get(sv); if (SvOK(sv)) RETPUSHYES; } RETPUSHNO; } PP(pp_undef) { djSP; SV *sv; if (!PL_op->op_private) { EXTEND(SP, 1); RETPUSHUNDEF; } sv = POPs; if (!sv) RETPUSHUNDEF; if (SvTHINKFIRST(sv)) sv_force_normal(sv); switch (SvTYPE(sv)) { case SVt_NULL: break; case SVt_PVAV: av_undef((AV*)sv); break; case SVt_PVHV: hv_undef((HV*)sv); break; case SVt_PVCV: if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv)) Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined", CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); /* FALL THROUGH */ case SVt_PVFM: { /* let user-undef'd sub keep its identity */ GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv)); cv_undef((CV*)sv); CvGV((CV*)sv) = gv; } break; case SVt_PVGV: if (SvFAKE(sv)) 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) = CopLINE(PL_curcop); GvEGV(sv) = (GV*)sv; GvMULTI_on(sv); } break; default: if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) { (void)SvOOK_off(sv); Safefree(SvPVX(sv)); SvPV_set(sv, Nullch); SvLEN_set(sv, 0); } (void)SvOK_off(sv); SvSETMAGIC(sv); } RETPUSHUNDEF; } PP(pp_predec) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { --SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_dec(TOPs); SvSETMAGIC(TOPs); return NORMAL; } PP(pp_postinc) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_inc(TOPs); SvSETMAGIC(TOPs); if (!SvOK(TARG)) sv_setiv(TARG, 0); SETs(TARG); return NORMAL; } PP(pp_postdec) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { --SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_dec(TOPs); SvSETMAGIC(TOPs); SETs(TARG); return NORMAL; } /* Ordinary operators. */ PP(pp_pow) { djSP; dATARGET; tryAMAGICbin(pow,opASSIGN); { dPOPTOPnnrl; SETn( Perl_pow( left, right) ); RETURN; } } PP(pp_multiply) { djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPnnrl; SETn( left * right ); RETURN; } } PP(pp_divide) { djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPPOPnnrl; NV value; if (right == 0.0) DIE(aTHX_ "Illegal division by zero"); #ifdef SLOPPYDIVIDE /* insure that 20./5. == 4. */ { IV k; if ((NV)I_V(left) == left && (NV)I_V(right) == right && (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) { value = k; } else { value = left / right; } } #else value = left / right; #endif PUSHn( value ); RETURN; } } PP(pp_modulo) { djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { UV left; UV right; bool left_neg; bool right_neg; bool use_double = 0; NV dright; NV dleft; if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); right = (right_neg = (i < 0)) ? -i : i; } else { dright = POPn; use_double = 1; right_neg = dright < 0; if (right_neg) dright = -dright; } if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); left = (left_neg = (i < 0)) ? -i : i; } else { dleft = POPn; if (!use_double) { use_double = 1; dright = right; } left_neg = dleft < 0; if (left_neg) dleft = -dleft; } if (use_double) { NV dans; #if 1 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */ # if CASTFLAGS & 2 # define CAST_D2UV(d) U_V(d) # else # define CAST_D2UV(d) ((UV)(d)) # endif /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE, * or, in other words, precision of UV more than of NV. * But in fact the approach below turned out to be an * optimization - floor() may be slow */ if (dright <= UV_MAX && dleft <= UV_MAX) { right = CAST_D2UV(dright); left = CAST_D2UV(dleft); goto do_uv; } #endif /* Backward-compatibility clause: */ dright = Perl_floor(dright + 0.5); dleft = Perl_floor(dleft + 0.5); if (!dright) DIE(aTHX_ "Illegal modulus zero"); dans = Perl_fmod(dleft, dright); if ((left_neg != right_neg) && dans) dans = dright - dans; if (right_neg) dans = -dans; sv_setnv(TARG, dans); } else { UV ans; do_uv: if (!right) DIE(aTHX_ "Illegal modulus zero"); ans = left % right; if ((left_neg != right_neg) && ans) ans = right - ans; if (right_neg) { /* XXX may warn: unary minus operator applied to unsigned type */ /* could change -foo to be (~foo)+1 instead */ if (ans <= ~((UV)IV_MAX)+1) sv_setiv(TARG, ~ans+1); else sv_setnv(TARG, -(NV)ans); } else sv_setuv(TARG, ans); } PUSHTARG; RETURN; } } PP(pp_repeat) { djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { register I32 count = POPi; if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; I32 items = SP - MARK; I32 max; max = items * count; MEXTEND(MARK, max); if (count > 1) { while (SP > MARK) { if (*SP) SvTEMP_off((*SP)); SP--; } MARK++; repeatcpy((char*)(MARK + items), (char*)MARK, items * sizeof(SV*), count - 1); SP += max; } else if (count <= 0) SP -= items; } else { /* Note: mark already snarfed by pp_list */ SV *tmpstr = POPs; STRLEN len; bool isutf = DO_UTF8(tmpstr); SvSetSV(TARG, tmpstr); SvPV_force(TARG, len); if (count != 1) { if (count < 1) SvCUR_set(TARG, 0); else { SvGROW(TARG, (count * len) + 1); repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); SvCUR(TARG) *= count; } *SvEND(TARG) = '\0'; } if (isutf) (void)SvPOK_only_UTF8(TARG); else (void)SvPOK_only(TARG); PUSHTARG; } RETURN; } } PP(pp_subtract) { djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPnnrl_ul; SETn( left - right ); RETURN; } } PP(pp_left_shift) { djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { IV i = TOPi; SETi(i << shift); } else { UV u = TOPu; SETu(u << shift); } RETURN; } } PP(pp_right_shift) { djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { IV i = TOPi; SETi(i >> shift); } else { UV u = TOPu; SETu(u >> shift); } RETURN; } } PP(pp_lt) { djSP; tryAMAGICbinSET(lt,0); { dPOPnv; SETs(boolSV(TOPn < value)); RETURN; } } PP(pp_gt) { djSP; tryAMAGICbinSET(gt,0); { dPOPnv; SETs(boolSV(TOPn > value)); RETURN; } } PP(pp_le) { djSP; tryAMAGICbinSET(le,0); { dPOPnv; SETs(boolSV(TOPn <= value)); RETURN; } } PP(pp_ge) { djSP; tryAMAGICbinSET(ge,0); { dPOPnv; SETs(boolSV(TOPn >= value)); RETURN; } } PP(pp_ne) { djSP; tryAMAGICbinSET(ne,0); { dPOPnv; SETs(boolSV(TOPn != value)); RETURN; } } PP(pp_ncmp) { djSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPnnrl; I32 value; #ifdef Perl_isnan if (Perl_isnan(left) || Perl_isnan(right)) { SETs(&PL_sv_undef); RETURN; } value = (left > right) - (left < right); #else if (left == right) value = 0; else if (left < right) value = -1; else if (left > right) value = 1; else { SETs(&PL_sv_undef); RETURN; } #endif SETi(value); RETURN; } } PP(pp_slt) { djSP; tryAMAGICbinSET(slt,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp < 0)); RETURN; } } PP(pp_sgt) { djSP; tryAMAGICbinSET(sgt,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp > 0)); RETURN; } } PP(pp_sle) { djSP; tryAMAGICbinSET(sle,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp <= 0)); RETURN; } } PP(pp_sge) { djSP; tryAMAGICbinSET(sge,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp >= 0)); RETURN; } } PP(pp_seq) { djSP; tryAMAGICbinSET(seq,0); { dPOPTOPssrl; SETs(boolSV(sv_eq(left, right))); RETURN; } } PP(pp_sne) { djSP; tryAMAGICbinSET(sne,0); { dPOPTOPssrl; SETs(boolSV(!sv_eq(left, right))); RETURN; } } PP(pp_scmp) { djSP; dTARGET; tryAMAGICbin(scmp,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETi( cmp ); RETURN; } } PP(pp_bit_and) { djSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { IV i = SvIV(left) & SvIV(right); SETi(i); } else { UV u = SvUV(left) & SvUV(right); SETu(u); } } else { do_vop(PL_op->op_type, TARG, left, right); SETTARG; } RETURN; } } PP(pp_bit_xor) { djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); SETi(i); } else { UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); SETu(u); } } else { do_vop(PL_op->op_type, TARG, left, right); SETTARG; } RETURN; } } PP(pp_bit_or) { djSP; dATARGET; tryAMAGICbin(bor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); SETi(i); } else { UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); SETu(u); } } else { do_vop(PL_op->op_type, TARG, left, right); SETTARG; } RETURN; } } PP(pp_negate) { djSP; dTARGET; tryAMAGICun(neg); { dTOPss; if (SvGMAGICAL(sv)) mg_get(sv); if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) { if (SvIsUV(sv)) { if (SvIVX(sv) == IV_MIN) { SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ RETURN; } else if (SvUVX(sv) <= IV_MAX) { SETi(-SvIVX(sv)); RETURN; } } else if (SvIVX(sv) != IV_MIN) { SETi(-SvIVX(sv)); RETURN; } } if (SvNIOKp(sv)) SETn(-SvNV(sv)); else if (SvPOKp(sv)) { STRLEN len; char *s = SvPV(sv, len); if (isIDFIRST(*s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); } else if (*s == '+' || *s == '-') { sv_setsv(TARG, sv); *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; } else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); } else sv_setnv(TARG, -SvNV(sv)); SETTARG; } else SETn(-SvNV(sv)); } RETURN; } PP(pp_not) { djSP; tryAMAGICunSET(not); *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); return NORMAL; } PP(pp_complement) { djSP; dTARGET; tryAMAGICun(compl); { dTOPss; if (SvNIOKp(sv)) { if (PL_op->op_private & HINT_INTEGER) { IV i = ~SvIV(sv); SETi(i); } else { UV u = ~SvUV(sv); SETu(u); } } else { register char *tmps; register long *tmpl; register I32 anum; STRLEN len; SvSetSV(TARG, sv); tmps = SvPV_force(TARG, len); anum = len; #ifdef LIBERAL for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) *tmps = ~*tmps; tmpl = (long*)tmps; for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) *tmpl = ~*tmpl; tmps = (char*)tmpl; #endif for ( ; anum > 0; anum--, tmps++) *tmps = ~*tmps; SETs(TARG); } RETURN; } } /* integer versions of some of the above */ PP(pp_i_multiply) { djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPiirl; SETi( left * right ); RETURN; } } PP(pp_i_divide) { djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPiv; if (value == 0) DIE(aTHX_ "Illegal division by zero"); value = POPi / value; PUSHi( value ); RETURN; } } PP(pp_i_modulo) { djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) DIE(aTHX_ "Illegal modulus zero"); SETi( left % right ); RETURN; } } PP(pp_i_add) { djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPiirl; SETi( left + right ); RETURN; } } PP(pp_i_subtract) { djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPiirl; SETi( left - right ); RETURN; } } PP(pp_i_lt) { djSP; tryAMAGICbinSET(lt,0); { dPOPTOPiirl; SETs(boolSV(left < right)); RETURN; } } PP(pp_i_gt) { djSP; tryAMAGICbinSET(gt,0); { dPOPTOPiirl; SETs(boolSV(left > right)); RETURN; } } PP(pp_i_le) { djSP; tryAMAGICbinSET(le,0); { dPOPTOPiirl; SETs(boolSV(left <= right)); RETURN; } } PP(pp_i_ge) { djSP; tryAMAGICbinSET(ge,0); { dPOPTOPiirl; SETs(boolSV(left >= right)); RETURN; } } PP(pp_i_eq) { djSP; tryAMAGICbinSET(eq,0); { dPOPTOPiirl; SETs(boolSV(left == right)); RETURN; } } PP(pp_i_ne) { djSP; tryAMAGICbinSET(ne,0); { dPOPTOPiirl; SETs(boolSV(left != right)); RETURN; } } PP(pp_i_ncmp) { djSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPiirl; I32 value; if (left > right) value = 1; else if (left < right) value = -1; else value = 0; SETi(value); RETURN; } } PP(pp_i_negate) { djSP; dTARGET; tryAMAGICun(neg); SETi(-TOPi); RETURN; } /* High falutin' math. */ PP(pp_atan2) { djSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; SETn(Perl_atan2(left, right)); RETURN; } } PP(pp_sin) { djSP; dTARGET; tryAMAGICun(sin); { NV value; value = POPn; value = Perl_sin(value); XPUSHn(value); RETURN; } } PP(pp_cos) { djSP; dTARGET; tryAMAGICun(cos); { NV value; value = POPn; value = Perl_cos(value); XPUSHn(value); RETURN; } } /* 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; NV value; if (MAXARG < 1) value = 1.0; else value = POPn; if (value == 0.0) value = 1.0; if (!PL_srand_called) { (void)seedDrand01((Rand_seed_t)seed()); PL_srand_called = TRUE; } value *= Drand01(); XPUSHn(value); RETURN; } PP(pp_srand) { djSP; UV anum; if (MAXARG < 1) anum = seed(); else anum = POPu; (void)seedDrand01((Rand_seed_t)anum); PL_srand_called = TRUE; EXTEND(SP, 1); RETPUSHYES; } STATIC U32 S_seed(pTHX) { /* * 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 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 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. */ #if RANDBITS > 16 # define SEED_C1 1000003 #define SEED_C4 73819 #else # define SEED_C1 25747 #define SEED_C4 20639 #endif #define SEED_C2 3 #define SEED_C3 269 #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 gettimeofday(&when,(struct timezone *) 0); u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; # else (void)time(&when); u = (U32)SEED_C1 * when; # endif #endif u += SEED_C3 * (U32)PerlProc_getpid(); u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ u += SEED_C5 * (U32)PTR2UV(&when); #endif return u; } PP(pp_exp) { djSP; dTARGET; tryAMAGICun(exp); { NV value; value = POPn; value = Perl_exp(value); XPUSHn(value); RETURN; } } PP(pp_log) { djSP; dTARGET; tryAMAGICun(log); { NV value; value = POPn; if (value <= 0.0) { RESTORE_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take log of %g", value); } value = Perl_log(value); XPUSHn(value); RETURN; } } PP(pp_sqrt) { djSP; dTARGET; tryAMAGICun(sqrt); { NV value; value = POPn; if (value < 0.0) { RESTORE_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take sqrt of %g", value); } value = Perl_sqrt(value); XPUSHn(value); RETURN; } } PP(pp_int) { djSP; dTARGET; { NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { iv = SvIVX(TOPs); SETi(iv); } else { if (value >= 0.0) (void)Perl_modf(value, &value); else { (void)Perl_modf(-value, &value); value = -value; } iv = I_V(value); if (iv == value) SETi(iv); else SETn(value); } } RETURN; } PP(pp_abs) { djSP; dTARGET; tryAMAGICun(abs); { NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && (iv = SvIVX(TOPs)) != IV_MIN) { if (iv < 0) iv = -iv; SETi(iv); } else { if (value < 0.0) value = -value; SETn(value); } } RETURN; } PP(pp_hex) { djSP; dTARGET; char *tmps; I32 argtype; STRLEN n_a; tmps = POPpx; argtype = 1; /* allow underscores */ XPUSHn(scan_hex(tmps, 99, &argtype)); RETURN; } PP(pp_oct) { djSP; dTARGET; NV value; I32 argtype; char *tmps; STRLEN n_a; tmps = POPpx; while (*tmps && isSPACE(*tmps)) tmps++; if (*tmps == '0') tmps++; argtype = 1; /* allow underscores */ 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); XPUSHn(value); RETURN; } /* String stuff. */ PP(pp_length) { djSP; dTARGET; SV *sv = TOPs; if (DO_UTF8(sv)) SETi(sv_len_utf8(sv)); else SETi(sv_len(sv)); RETURN; } PP(pp_substr) { djSP; dTARGET; SV *sv; I32 len; STRLEN curlen; STRLEN utfcurlen; I32 pos; I32 rem; I32 fail; I32 lvalue = PL_op->op_flags & OPf_MOD; char *tmps; I32 arybase = PL_curcop->cop_arybase; char *repl = 0; STRLEN repl_len; SvTAINTED_off(TARG); /* decontaminate */ SvUTF8_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 (DO_UTF8(sv)) { 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; } } 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; } if (fail < 0) { if (lvalue || repl) Perl_croak(aTHX_ "substr outside of string"); if (ckWARN(WARN_SUBSTR)) Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string"); RETPUSHUNDEF; } else { if (utfcurlen) sv_pos_u2b(sv, &pos, &rem); tmps += pos; sv_setpvn(TARG, tmps, rem); if (utfcurlen) SvUTF8_on(TARG); if (repl) sv_insert(sv, pos, rem, repl, repl_len); else if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { STRLEN n_a; SvPV_force(sv,n_a); if (ckWARN(WARN_SUBSTR)) Perl_warner(aTHX_ WARN_SUBSTR, "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ (void)SvPOK_only_UTF8(sv); else sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, 'x', Nullch, 0); } LvTYPE(TARG) = 'x'; if (LvTARG(TARG) != sv) { if (LvTARG(TARG)) SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc(sv); } LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; } } SPAGAIN; PUSHs(TARG); /* avoid SvSETMAGIC here */ RETURN; } PP(pp_vec) { djSP; dTARGET; register I32 size = POPi; register I32 offset = POPi; register SV *src = POPs; I32 lvalue = PL_op->op_flags & OPf_MOD; SvTAINTED_off(TARG); /* decontaminate */ if (lvalue) { /* it's an lvalue! */ if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, 'v', Nullch, 0); } LvTYPE(TARG) = 'v'; if (LvTARG(TARG) != src) { if (LvTARG(TARG)) SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc(src); } LvTARGOFF(TARG) = offset; LvTARGLEN(TARG) = size; } sv_setuv(TARG, do_vecget(src, offset, size)); PUSHs(TARG); RETURN; } PP(pp_index) { djSP; dTARGET; SV *big; SV *little; I32 offset; I32 retval; char *tmps; char *tmps2; STRLEN biglen; I32 arybase = PL_curcop->cop_arybase; if (MAXARG < 3) offset = 0; else offset = POPi - arybase; little = POPs; big = POPs; tmps = SvPV(big, biglen); if (offset > 0 && DO_UTF8(big)) sv_pos_u2b(big, &offset, 0); if (offset < 0) offset = 0; else if (offset > biglen) offset = biglen; if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset, (unsigned char*)tmps + biglen, little, 0))) retval = -1; else retval = tmps2 - tmps; if (retval > 0 && DO_UTF8(big)) sv_pos_b2u(big, &retval); PUSHi(retval + arybase); RETURN; } PP(pp_rindex) { djSP; dTARGET; SV *big; SV *little; STRLEN blen; STRLEN llen; I32 offset; I32 retval; char *tmps; char *tmps2; I32 arybase = PL_curcop->cop_arybase; if (MAXARG >= 3) offset = POPi; little = POPs; big = POPs; tmps2 = SvPV(little, llen); tmps = SvPV(big, blen); if (MAXARG < 3) offset = blen; else { if (offset > 0 && DO_UTF8(big)) 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; else retval = tmps2 - tmps; if (retval > 0 && DO_UTF8(big)) sv_pos_b2u(big, &retval); PUSHi(retval + arybase); RETURN; } PP(pp_sprintf) { djSP; dMARK; dORIGMARK; dTARGET; do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); SP = ORIGMARK; PUSHTARG; RETURN; } PP(pp_ord) { djSP; dTARGET; UV value; STRLEN n_a; SV *tmpsv = POPs; U8 *tmps = (U8*)SvPVx(tmpsv,n_a); I32 retlen; if ((*tmps & 0x80) && DO_UTF8(tmpsv)) value = utf8_to_uv(tmps, &retlen); else value = (UV)(*tmps & 255); XPUSHu(value); RETURN; } PP(pp_chr) { djSP; dTARGET; char *tmps; U32 value = POPu; (void)SvUPGRADE(TARG,SVt_PV); if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) { SvGROW(TARG, UTF8_MAXLEN+1); tmps = SvPVX(TARG); tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value); SvCUR_set(TARG, tmps - SvPVX(TARG)); *tmps = '\0'; (void)SvPOK_only(TARG); SvUTF8_on(TARG); XPUSHs(TARG); RETURN; } SvGROW(TARG,2); SvCUR_set(TARG, 1); tmps = SvPVX(TARG); *tmps++ = value; *tmps = '\0'; (void)SvPOK_only(TARG); XPUSHs(TARG); RETURN; } PP(pp_crypt) { djSP; dTARGET; dPOPTOPssrl; STRLEN n_a; #ifdef HAS_CRYPT char *tmps = SvPV(left, n_a); #ifdef FCRYPT sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); #else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); #endif #else DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif SETs(TARG); RETURN; } PP(pp_ucfirst) { djSP; SV *sv = TOPs; register U8 *s; STRLEN slen; if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { I32 ulen; U8 tmpbuf[UTF8_MAXLEN]; 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 || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); SvUTF8_on(TARG); SETs(TARG); } else { s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } } else { if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); } s = (U8*)SvPV_force(sv, slen); if (*s) { if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); *s = toUPPER_LC(*s); } else *s = toUPPER(*s); } } if (SvSMAGICAL(sv)) mg_set(sv); RETURN; } PP(pp_lcfirst) { djSP; SV *sv = TOPs; register U8 *s; STRLEN slen; if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { I32 ulen; U8 tmpbuf[UTF8_MAXLEN]; 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 || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); SvUTF8_on(TARG); SETs(TARG); } else { s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } } else { if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); } s = (U8*)SvPV_force(sv, slen); if (*s) { if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); *s = toLOWER_LC(*s); } else *s = toLOWER(*s); } } if (SvSMAGICAL(sv)) mg_set(sv); RETURN; } PP(pp_uc) { djSP; SV *sv = TOPs; register U8 *s; STRLEN len; if (DO_UTF8(sv)) { dTARGET; I32 ulen; register U8 *d; U8 *send; s = (U8*)SvPV(sv,len); if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); SETs(TARG); } else { (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'; SvUTF8_on(TARG); SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); SETs(TARG); } } else { if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); } s = (U8*)SvPV_force(sv, len); if (len) { register U8 *send = s + len; if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); for (; s < send; s++) *s = toUPPER_LC(*s); } else { for (; s < send; s++) *s = toUPPER(*s); } } } if (SvSMAGICAL(sv)) mg_set(sv); RETURN; } PP(pp_lc) { djSP; SV *sv = TOPs; register U8 *s; STRLEN len; if (DO_UTF8(sv)) { dTARGET; I32 ulen; register U8 *d; U8 *send; s = (U8*)SvPV(sv,len); if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); SETs(TARG); } else { (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'; SvUTF8_on(TARG); SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); SETs(TARG); } } else { if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ sv_setsv(TARG, sv); sv = TARG; SETs(sv); } s = (U8*)SvPV_force(sv, len); if (len) { register U8 *send = s + len; if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); for (; s < send; s++) *s = toLOWER_LC(*s); } else { for (; s < send; s++) *s = toLOWER(*s); } } } if (SvSMAGICAL(sv)) mg_set(sv); RETURN; } PP(pp_quotemeta) { djSP; dTARGET; SV *sv = TOPs; STRLEN len; register char *s = SvPV(sv,len); register char *d; SvUTF8_off(TARG); /* decontaminate */ if (len) { (void)SvUPGRADE(TARG, SVt_PV); SvGROW(TARG, (len * 2) + 1); d = SvPVX(TARG); if (DO_UTF8(sv)) { 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--; } } SvUTF8_on(TARG); } else { while (len--) { if (!isALNUM(*s)) *d++ = '\\'; *d++ = *s++; } } *d = '\0'; SvCUR_set(TARG, d - SvPVX(TARG)); (void)SvPOK_only_UTF8(TARG); } else sv_setpvn(TARG, s, len); SETs(TARG); if (SvSMAGICAL(TARG)) mg_set(TARG); RETURN; } /* Arrays. */ PP(pp_aslice) { djSP; dMARK; dORIGMARK; register SV** svp; register AV* av = (AV*)POPs; register I32 lval = PL_op->op_flags & OPf_MOD; I32 arybase = PL_curcop->cop_arybase; I32 elem; if (SvTYPE(av) == SVt_PVAV) { if (lval && PL_op->op_private & OPpLVAL_INTRO) { I32 max = -1; for (svp = MARK + 1; svp <= SP; svp++) { elem = SvIVx(*svp); if (elem > max) max = elem; } if (max > AvMAX(av)) av_extend(av, max); } while (++MARK <= SP) { elem = SvIVx(*MARK); if (elem > 0) elem -= arybase; svp = av_fetch(av, elem, lval); if (lval) { if (!svp || *svp == &PL_sv_undef) DIE(aTHX_ PL_no_aelem, elem); if (PL_op->op_private & OPpLVAL_INTRO) save_aelem(av, elem, svp); } *MARK = svp ? *svp : &PL_sv_undef; } } if (GIMME != G_ARRAY) { MARK = ORIGMARK; *++MARK = *SP; SP = MARK; } RETURN; } /* Associative arrays. */ PP(pp_each) { djSP; HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; I32 realhv = (SvTYPE(hash) == SVt_PVHV); PUTBACK; /* might clobber stack_sp */ entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash); SPAGAIN; EXTEND(SP, 2); if (entry) { PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { SV *val; PUTBACK; /* might clobber stack_sp */ val = realhv ? hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry); SPAGAIN; PUSHs(val); } } else if (gimme == G_SCALAR) RETPUSHUNDEF; RETURN; } PP(pp_values) { return do_kv(); } PP(pp_keys) { return do_kv(); } PP(pp_delete) { djSP; I32 gimme = GIMME_V; I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; SV *sv; HV *hv; if (PL_op->op_private & OPpSLICE) { dMARK; dORIGMARK; U32 hvtype; hv = (HV*)POPs; hvtype = SvTYPE(hv); if (hvtype == SVt_PVHV) { /* hash element */ while (++MARK <= SP) { sv = hv_delete_ent(hv, *MARK, discard, 0); *MARK = sv ? sv : &PL_sv_undef; } } else if (hvtype == SVt_PVAV) { if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ while (++MARK <= SP) { sv = av_delete((AV*)hv, SvIV(*MARK), discard); *MARK = sv ? sv : &PL_sv_undef; } } else { /* pseudo-hash element */ while (++MARK <= SP) { sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0); *MARK = sv ? sv : &PL_sv_undef; } } } else DIE(aTHX_ "Not a HASH reference"); if (discard) SP = ORIGMARK; else if (gimme == G_SCALAR) { MARK = ORIGMARK; *++MARK = *SP; SP = MARK; } } else { SV *keysv = POPs; hv = (HV*)POPs; if (SvTYPE(hv) == SVt_PVHV) sv = hv_delete_ent(hv, keysv, discard, 0); else if (SvTYPE(hv) == SVt_PVAV) { if (PL_op->op_flags & OPf_SPECIAL) sv = av_delete((AV*)hv, SvIV(keysv), discard); else sv = avhv_delete_ent((AV*)hv, keysv, discard, 0); } else DIE(aTHX_ "Not a HASH reference"); if (!sv) sv = &PL_sv_undef; if (!discard) PUSHs(sv); } RETURN; } PP(pp_exists) { djSP; SV *tmpsv; HV *hv; if (PL_op->op_private & OPpEXISTS_SUB) { GV *gv; CV *cv; SV *sv = POPs; cv = sv_2cv(sv, &hv, &gv, FALSE); if (cv) RETPUSHYES; if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) RETPUSHYES; RETPUSHNO; } tmpsv = POPs; hv = (HV*)POPs; if (SvTYPE(hv) == SVt_PVHV) { if (hv_exists_ent(hv, tmpsv, 0)) RETPUSHYES; } else if (SvTYPE(hv) == SVt_PVAV) { if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ if (av_exists((AV*)hv, SvIV(tmpsv))) RETPUSHYES; } else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */ RETPUSHYES; } else { DIE(aTHX_ "Not a HASH reference"); } RETPUSHNO; } PP(pp_hslice) { djSP; dMARK; dORIGMARK; register HV *hv = (HV*)POPs; register I32 lval = PL_op->op_flags & OPf_MOD; I32 realhv = (SvTYPE(hv) == SVt_PVHV); if (!realhv && PL_op->op_private & OPpLVAL_INTRO) DIE(aTHX_ "Can't localize pseudo-hash element"); if (realhv || SvTYPE(hv) == SVt_PVAV) { while (++MARK <= SP) { SV *keysv = *MARK; SV **svp; if (realhv) { HE *he = hv_fetch_ent(hv, keysv, lval, 0); svp = he ? &HeVAL(he) : 0; } else { svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0); } if (lval) { if (!svp || *svp == &PL_sv_undef) { STRLEN n_a; DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); } if (PL_op->op_private & OPpLVAL_INTRO) save_helem(hv, keysv, svp); } *MARK = svp ? *svp : &PL_sv_undef; } } if (GIMME != G_ARRAY) { MARK = ORIGMARK; *++MARK = *SP; SP = MARK; } RETURN; } /* List operators. */ PP(pp_list) { djSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; /* unwanted list, return last item */ else *MARK = &PL_sv_undef; SP = MARK; } RETURN; } PP(pp_lslice) { djSP; 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 = PL_curcop->cop_arybase; I32 lval = PL_op->op_flags & OPf_MOD; I32 is_something_there = lval; register I32 max = lastrelem - lastlelem; register SV **lelem; register I32 ix; if (GIMME != G_ARRAY) { ix = SvIVx(*lastlelem); if (ix < 0) ix += max; else ix -= arybase; if (ix < 0 || ix >= max) *firstlelem = &PL_sv_undef; else *firstlelem = firstrelem[ix]; SP = firstlelem; RETURN; } if (max == 0) { SP = firstlelem - 1; RETURN; } for (lelem = firstlelem; lelem <= lastlelem; lelem++) { ix = SvIVx(*lelem); if (ix < 0) ix += max; else ix -= arybase; if (ix < 0 || ix >= max) *lelem = &PL_sv_undef; else { is_something_there = TRUE; if (!(*lelem = firstrelem[ix])) *lelem = &PL_sv_undef; } } if (is_something_there) SP = lastlelem; else SP = firstlelem - 1; RETURN; } PP(pp_anonlist) { djSP; dMARK; dORIGMARK; I32 items = SP - MARK; SV *av = sv_2mortal((SV*)av_make(items, MARK+1)); SP = ORIGMARK; /* av_make() might realloc stack_sp */ XPUSHs(av); RETURN; } PP(pp_anonhash) { djSP; dMARK; dORIGMARK; HV* hv = (HV*)sv_2mortal((SV*)newHV()); while (MARK < SP) { SV* key = *++MARK; SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); else if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; XPUSHs((SV*)hv); RETURN; } PP(pp_splice) { djSP; dMARK; dORIGMARK; register AV *ary = (AV*)*++MARK; register SV **src; register SV **dst; register I32 i; register I32 offset; register I32 length; I32 newlen; I32 after; I32 diff; SV **tmparyval = 0; MAGIC *mg; if ((mg = SvTIED_mg((SV*)ary, 'P'))) { *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; ENTER; call_method("SPLICE",GIMME_V); LEAVE; SPAGAIN; RETURN; } SP++; if (++MARK < SP) { offset = i = SvIVx(*MARK); if (offset < 0) offset += AvFILLp(ary) + 1; else offset -= PL_curcop->cop_arybase; if (offset < 0) DIE(aTHX_ PL_no_aelem, i); if (++MARK < SP) { length = SvIVx(*MARK++); if (length < 0) { length += AvFILLp(ary) - offset + 1; if (length < 0) length = 0; } } else length = AvMAX(ary) + 1; /* close enough to infinity */ } else { offset = 0; length = AvMAX(ary) + 1; } if (offset > AvFILLp(ary) + 1) offset = AvFILLp(ary) + 1; after = AvFILLp(ary) + 1 - (offset + length); if (after < 0) { /* not that much array */ length += after; /* offset+length now in array */ after = 0; if (!AvALLOC(ary)) av_extend(ary, 0); } /* At this point, MARK .. SP-1 is our new LIST */ newlen = SP - MARK; diff = newlen - length; if (newlen && !AvREAL(ary) && AvREIFY(ary)) av_reify(ary); if (diff < 0) { /* shrinking the area */ if (newlen) { New(451, tmparyval, newlen, SV*); /* so remember insertion */ Copy(MARK, tmparyval, newlen, SV*); } MARK = ORIGMARK + 1; if (GIMME == G_ARRAY) { /* copy return vals to stack */ MEXTEND(MARK, length); Copy(AvARRAY(ary)+offset, MARK, length, SV*); if (AvREAL(ary)) { EXTEND_MORTAL(length); for (i = length, dst = MARK; i; i--) { sv_2mortal(*dst); /* free them eventualy */ dst++; } } MARK += length - 1; } else { *MARK = AvARRAY(ary)[offset+length-1]; if (AvREAL(ary)) { sv_2mortal(*MARK); for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) SvREFCNT_dec(*dst++); /* free them now */ } } AvFILLp(ary) += diff; /* pull up or down? */ if (offset < after) { /* easier to pull up */ if (offset) { /* esp. if nothing to pull */ src = &AvARRAY(ary)[offset-1]; dst = src - diff; /* diff is negative */ for (i = offset; i > 0; i--) /* can't trust Copy */ *dst-- = *src--; } dst = AvARRAY(ary); SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */ AvMAX(ary) += diff; } else { if (after) { /* anything to pull down? */ src = AvARRAY(ary) + offset + length; dst = src + diff; /* diff is negative */ Move(src, dst, after, SV*); } dst = &AvARRAY(ary)[AvFILLp(ary)+1]; /* avoid later double free */ } i = -diff; while (i) dst[--i] = &PL_sv_undef; if (newlen) { for (src = tmparyval, dst = AvARRAY(ary) + offset; newlen; newlen--) { *dst = NEWSV(46, 0); sv_setsv(*dst++, *src++); } Safefree(tmparyval); } } else { /* no, expanding (or same) */ if (length) { New(452, tmparyval, length, SV*); /* so remember deletion */ Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); } if (diff > 0) { /* expanding */ /* push up or down? */ if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { if (offset) { src = AvARRAY(ary); dst = src - diff; Move(src, dst, offset, SV*); } SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */ AvMAX(ary) += diff; AvFILLp(ary) += diff; } else { if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ av_extend(ary, AvFILLp(ary) + diff); AvFILLp(ary) += diff; if (after) { dst = AvARRAY(ary) + AvFILLp(ary); src = dst - diff; for (i = after; i; i--) { *dst-- = *src--; } } } } for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) { *dst = NEWSV(46, 0); sv_setsv(*dst++, *src++); } MARK = ORIGMARK + 1; if (GIMME == G_ARRAY) { /* copy return vals to stack */ if (length) { Copy(tmparyval, MARK, length, SV*); if (AvREAL(ary)) { EXTEND_MORTAL(length); for (i = length, dst = MARK; i; i--) { sv_2mortal(*dst); /* free them eventualy */ dst++; } } Safefree(tmparyval); } MARK += length - 1; } else if (length--) { *MARK = tmparyval[length]; if (AvREAL(ary)) { sv_2mortal(*MARK); while (length-- > 0) SvREFCNT_dec(tmparyval[length]); } Safefree(tmparyval); } else *MARK = &PL_sv_undef; } SP = MARK; RETURN; } PP(pp_push) { djSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv = &PL_sv_undef; MAGIC *mg; if ((mg = SvTIED_mg((SV*)ary, 'P'))) { *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; ENTER; call_method("PUSH",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; } else { /* Why no pre-extend of ary here ? */ for (++MARK; MARK <= SP; MARK++) { sv = NEWSV(51, 0); if (*MARK) sv_setsv(sv, *MARK); av_push(ary, sv); } } SP = ORIGMARK; PUSHi( AvFILL(ary) + 1 ); RETURN; } PP(pp_pop) { djSP; AV *av = (AV*)POPs; SV *sv = av_pop(av); if (AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); RETURN; } PP(pp_shift) { djSP; AV *av = (AV*)POPs; SV *sv = av_shift(av); EXTEND(SP, 1); if (!sv) RETPUSHUNDEF; if (AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); RETURN; } PP(pp_unshift) { djSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv; register I32 i = 0; MAGIC *mg; if ((mg = SvTIED_mg((SV*)ary, 'P'))) { *MARK-- = SvTIED_obj((SV*)ary, mg); PUSHMARK(MARK); PUTBACK; ENTER; call_method("UNSHIFT",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; } else { av_unshift(ary, SP - MARK); while (MARK < SP) { sv = NEWSV(27, 0); sv_setsv(sv, *++MARK); (void)av_store(ary, i++, sv); } } SP = ORIGMARK; PUSHi( AvFILL(ary) + 1 ); RETURN; } PP(pp_reverse) { djSP; dMARK; register SV *tmp; SV **oldsp = SP; if (GIMME == G_ARRAY) { MARK++; while (MARK < SP) { tmp = *MARK; *MARK++ = *SP; *SP-- = tmp; } /* safe as long as stack cannot get extended in the above */ SP = oldsp; } else { register char *up; register char *down; register I32 tmp; dTARGET; STRLEN len; SvUTF8_off(TARG); /* decontaminate */ if (SP - MARK > 1) 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 (DO_UTF8(TARG)) { /* 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)) { if (ckWARN_d(WARN_UTF8)) Perl_warner(aTHX_ WARN_UTF8, "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; *up++ = *down; *down-- = tmp; } (void)SvPOK_only_UTF8(TARG); } SP = MARK + 1; SETTARG; } RETURN; } STATIC SV * S_mul128(pTHX_ SV *sv, U8 m) { STRLEN len; char *s = SvPV(sv, len); char *t; U32 i = 0; if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ SV *tmpNew = newSVpvn("0000000000", 10); sv_catsv(tmpNew, sv); SvREFCNT_dec(sv); /* free old sv */ sv = tmpNew; s = SvPV(sv, len); } t = s + len - 1; while (!*t) /* trailing '\0'? */ t--; while (t > s) { i = ((*t - '0') << 7) + m; *(t--) = '0' + (i % 10); m = i / 10; } return (sv); } /* 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; I32 start_sp_offset = SP - PL_stack_base; I32 gimme = GIMME_V; SV *sv; STRLEN llen; STRLEN rlen; register char *pat = SvPV(left, llen); register char *s = SvPV(right, rlen); char *strend = s + rlen; char *strbeg = s; register char *patend = pat + llen; I32 datumtype; register I32 len; register I32 bits; register char *str; /* These must not be in registers: */ I16 ashort; int aint; I32 along; #ifdef HAS_QUAD Quad_t aquad; #endif U16 aushort; unsigned int auint; U32 aulong; #ifdef HAS_QUAD Uquad_t auquad; #endif char *aptr; float afloat; double adouble; I32 checksum = 0; register U32 culong; NV cdouble; int commas = 0; int star; #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("aAZbBhHP", *patend) || *pat == '%') { patend++; while (isDIGIT(*patend) || *patend == '*') patend++; } else patend++; } while (pat < patend) { reparse: datumtype = *pat++ & 0xFF; #ifdef PERL_NATINT_PACK natint = 0; #endif if (isSPACE(datumtype)) continue; if (datumtype == '#') { while (pat < patend && *pat != '\n') pat++; continue; } if (*pat == '!') { char *natstr = "sSiIlL"; if (strchr(natstr, datumtype)) { #ifdef PERL_NATINT_PACK natint = 1; #endif pat++; } else DIE(aTHX_ "'!' allowed only after types %s", natstr); } star = 0; if (pat >= patend) len = 1; else if (*pat == '*') { len = strend - strbeg; /* long enough */ pat++; star = 1; } else if (isDIGIT(*pat)) { len = *pat++ - '0'; while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); if (len < 0) DIE(aTHX_ "Repeat count in unpack overflows"); } } else len = (datumtype != '@'); redo_switch: switch(datumtype) { default: DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNPACK)) Perl_warner(aTHX_ WARN_UNPACK, "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') len = 16; checksum = len; culong = 0; cdouble = 0; if (pat < patend) goto reparse; break; case '@': if (len > strend - strbeg) DIE(aTHX_ "@ outside of string"); s = strbeg + len; break; case 'X': if (len > s - strbeg) DIE(aTHX_ "X outside of string"); s -= len; break; case 'x': if (len > strend - s) DIE(aTHX_ "x outside of string"); s += len; break; case '/': if (start_sp_offset >= SP - PL_stack_base) DIE(aTHX_ "/ must follow a numeric type"); datumtype = *pat++; if (*pat == '*') pat++; /* ignore '*' for compatibility with pack */ if (isDIGIT(*pat)) DIE(aTHX_ "/ cannot take a count" ); len = POPi; star = 0; goto redo_switch; case 'A': case 'Z': case 'a': if (len > strend - s) len = strend - s; if (checksum) goto uchar_checksum; sv = NEWSV(35, len); sv_setpvn(sv, s, len); s += len; if (datumtype == 'A' || datumtype == 'Z') { aptr = s; /* borrow register */ 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 */ } XPUSHs(sv_2mortal(sv)); break; case 'B': case 'b': if (star || len > (strend - s) * 8) len = (strend - s) * 8; if (checksum) { if (!PL_bitcount) { Newz(601, PL_bitcount, 256, char); for (bits = 1; bits < 256; 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 += PL_bitcount[*(unsigned char*)s++]; len -= 8; } if (len) { bits = *s; if (datumtype == 'b') { while (len-- > 0) { if (bits & 1) culong++; bits >>= 1; } } else { while (len-- > 0) { if (bits & 128) culong++; bits <<= 1; } } } break; } sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); str = SvPVX(sv); if (datumtype == 'b') { aint = len; for (len = 0; len < aint; len++) { if (len & 7) /*SUPPRESS 595*/ bits >>= 1; else bits = *s++; *str++ = '0' + (bits & 1); } } else { aint = len; for (len = 0; len < aint; len++) { if (len & 7) bits <<= 1; else bits = *s++; *str++ = '0' + ((bits & 128) != 0); } } *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'H': case 'h': if (star || len > (strend - s) * 2) len = (strend - s) * 2; sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); str = SvPVX(sv); if (datumtype == 'h') { aint = len; for (len = 0; len < aint; len++) { if (len & 1) bits >>= 4; else bits = *s++; *str++ = PL_hexdigit[bits & 15]; } } else { aint = len; for (len = 0; len < aint; len++) { if (len & 1) bits <<= 4; else bits = *s++; *str++ = PL_hexdigit[(bits >> 4) & 15]; } } *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'c': if (len > strend - s) len = strend - s; if (checksum) { while (len-- > 0) { aint = *s++; if (aint >= 128) /* fake up signed chars */ aint -= 256; culong += aint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { aint = *s++; if (aint >= 128) /* fake up signed chars */ aint -= 256; sv = NEWSV(36, 0); sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } } break; case 'C': if (len > strend - s) len = strend - s; if (checksum) { uchar_checksum: while (len-- > 0) { auint = *s++ & 255; culong += auint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { auint = *s++ & 255; sv = NEWSV(37, 0); sv_setiv(sv, (IV)auint); PUSHs(sv_2mortal(sv)); } } 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 += (NV)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) { #if SHORTSIZE != SIZE16 if (natint) { short ashort; 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); #if SHORTSIZE != SIZE16 if (natint) { short ashort; 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) { #if SHORTSIZE != SIZE16 if (unatint) { unsigned short aushort; 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); #endif #ifdef HAS_VTOHS if (datumtype == 'v') aushort = vtohs(aushort); #endif culong += aushort; } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); #if SHORTSIZE != SIZE16 if (unatint) { unsigned short aushort; 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); #endif #ifdef HAS_VTOHS if (datumtype == 'v') aushort = vtohs(aushort); #endif sv_setiv(sv, (UV)aushort); PUSHs(sv_2mortal(sv)); } } } break; case 'i': along = (strend - s) / sizeof(int); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &aint, 1, int); s += sizeof(int); if (checksum > 32) cdouble += (NV)aint; else culong += aint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { 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. * * The bug was detected in * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E) * with optimization (-O4) turned on. * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B) * does not have this problem even with -O4. * * This bug was reported as DECC_BUGS 1431 * and tracked internally as GEM_BUGS 7775. * * The bug is fixed in * Tru64 UNIX V5.0: Compaq C V6.1-006 or later * UNIX V4.0F support: DEC C V5.9-006 or later * UNIX V4.0E support: DEC C V5.8-011 or later * and also in DTK. * * See also few lines later for the same bug. */ (aint) ? sv_setiv(sv, (IV)aint) : #endif sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } } break; case 'I': along = (strend - s) / sizeof(unsigned int); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); if (checksum > 32) cdouble += (NV)auint; else culong += auint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { 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. * See details few lines earlier. */ (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) { #if LONGSIZE != SIZE32 if (natint) { long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); if (checksum > 32) cdouble += (NV)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 += (NV)along; else culong += along; } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (natint) { long along; 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) { #if LONGSIZE != SIZE32 if (unatint) { unsigned long aulong; while (len-- > 0) { COPYNN(s, &aulong, sizeof(unsigned long)); s += sizeof(unsigned long); if (checksum > 32) cdouble += (NV)aulong; else culong += aulong; } } else #endif { while (len-- > 0) { COPY32(s, &aulong); s += SIZE32; #ifdef HAS_NTOHL if (datumtype == 'N') aulong = PerlSock_ntohl(aulong); #endif #ifdef HAS_VTOHL if (datumtype == 'V') aulong = vtohl(aulong); #endif if (checksum > 32) cdouble += (NV)aulong; else culong += aulong; } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (unatint) { unsigned long aulong; 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); #endif #ifdef HAS_VTOHL if (datumtype == 'V') aulong = vtohl(aulong); #endif sv = NEWSV(43, 0); sv_setuv(sv, (UV)aulong); PUSHs(sv_2mortal(sv)); } } } break; case 'p': along = (strend - s) / sizeof(char*); if (len > along) len = along; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { if (sizeof(char*) > strend - s) break; else { Copy(s, &aptr, 1, char*); s += sizeof(char*); } sv = NEWSV(44, 0); if (aptr) sv_setpv(sv, aptr); PUSHs(sv_2mortal(sv)); } break; case 'w': EXTEND(SP, len); EXTEND_MORTAL(len); { UV auv = 0; U32 bytes = 0; while ((len > 0) && (s < strend)) { auv = (auv << 7) | (*s & 0x7f); if (!(*s++ & 0x80)) { bytes = 0; sv = NEWSV(40, 0); sv_setuv(sv, auv); PUSHs(sv_2mortal(sv)); len--; auv = 0; } else if (++bytes >= sizeof(UV)) { /* promote to string */ char *t; STRLEN n_a; sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv); while (s < strend) { sv = mul128(sv, *s & 0x7f); if (!(*s++ & 0x80)) { bytes = 0; break; } } t = SvPV(sv, n_a); while (*t == '0') t++; sv_chop(sv, t); PUSHs(sv_2mortal(sv)); len--; auv = 0; } } if ((s >= strend) && bytes) DIE(aTHX_ "Unterminated compressed integer"); } break; case 'P': EXTEND(SP, 1); if (sizeof(char*) > strend - s) break; else { Copy(s, &aptr, 1, char*); s += sizeof(char*); } sv = NEWSV(44, 0); if (aptr) sv_setpvn(sv, aptr, len); PUSHs(sv_2mortal(sv)); 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) { if (s + sizeof(Quad_t) > strend) aquad = 0; else { Copy(s, &aquad, 1, Quad_t); s += sizeof(Quad_t); } sv = NEWSV(42, 0); if (aquad >= IV_MIN && aquad <= IV_MAX) sv_setiv(sv, (IV)aquad); else sv_setnv(sv, (NV)aquad); PUSHs(sv_2mortal(sv)); } 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(Uquad_t) > strend) auquad = 0; else { Copy(s, &auquad, 1, Uquad_t); s += sizeof(Uquad_t); } sv = NEWSV(43, 0); if (auquad <= UV_MAX) sv_setuv(sv, (UV)auquad); else sv_setnv(sv, (NV)auquad); PUSHs(sv_2mortal(sv)); } break; #endif /* float and double added gnb@melba.bby.oz.au 22/11/89 */ case 'f': case 'F': along = (strend - s) / sizeof(float); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &afloat, 1, float); s += sizeof(float); cdouble += afloat; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &afloat, 1, float); s += sizeof(float); sv = NEWSV(47, 0); sv_setnv(sv, (NV)afloat); PUSHs(sv_2mortal(sv)); } } break; case 'd': case 'D': along = (strend - s) / sizeof(double); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &adouble, 1, double); s += sizeof(double); cdouble += adouble; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &adouble, 1, double); s += sizeof(double); sv = NEWSV(48, 0); sv_setnv(sv, (NV)adouble); PUSHs(sv_2mortal(sv)); } } 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[(U8)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 > ' ' && ISUUCHAR(*s)) { I32 a, b, c, d; char hunk[4]; hunk[3] = '\0'; len = PL_uudmap[*(U8*)s++] & 077; while (len > 0) { if (s < strend && ISUUCHAR(*s)) a = PL_uudmap[*(U8*)s++] & 077; else a = 0; if (s < strend && ISUUCHAR(*s)) b = PL_uudmap[*(U8*)s++] & 077; else b = 0; if (s < strend && ISUUCHAR(*s)) c = PL_uudmap[*(U8*)s++] & 077; else c = 0; if (s < strend && ISUUCHAR(*s)) d = PL_uudmap[*(U8*)s++] & 077; else d = 0; hunk[0] = (a << 2) | (b >> 4); hunk[1] = (b << 4) | (c >> 2); hunk[2] = (c << 6) | d; sv_catpvn(sv, hunk, (len > 3) ? 3 : len); len -= 3; } if (*s == '\n') s++; else if (s[1] == '\n') /* possible checksum byte */ s += 2; } XPUSHs(sv_2mortal(sv)); break; } if (checksum) { sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || (checksum > 32 && strchr("iIlLNU", datumtype)) ) { NV trouble; adouble = 1.0; while (checksum >= 16) { checksum -= 16; adouble *= 65536.0; } while (checksum >= 4) { checksum -= 4; adouble *= 16.0; } while (checksum--) adouble *= 2.0; along = (1 << checksum) - 1; while (cdouble < 0.0) cdouble += adouble; cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; sv_setnv(sv, cdouble); } else { if (checksum < 32) { aulong = (1 << checksum) - 1; culong &= aulong; } sv_setuv(sv, (UV)culong); } XPUSHs(sv_2mortal(sv)); checksum = 0; } } if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR) PUSHs(&PL_sv_undef); RETURN; } STATIC void S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len) { char hunk[5]; *hunk = PL_uuemap[len]; sv_catpvn(sv, hunk, 1); hunk[4] = '\0'; 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; } 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 * S_is_an_int(pTHX_ char *s, STRLEN l) { STRLEN n_a; SV *result = newSVpvn(s, l); char *result_c = SvPV(result, n_a); /* convenience */ char *out = result_c; bool skip = 1; bool ignore = 0; while (*s) { switch (*s) { case ' ': break; case '+': if (!skip) { SvREFCNT_dec(result); return (NULL); } break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': skip = 0; if (!ignore) { *(out++) = *s; } break; case '.': ignore = 1; break; default: SvREFCNT_dec(result); return (NULL); } s++; } *(out++) = '\0'; SvCUR_set(result, out - result_c); return (result); } /* pnum must be '\0' terminated */ STATIC int S_div128(pTHX_ SV *pnum, bool *done) { STRLEN len; char *s = SvPV(pnum, len); int m = 0; int r = 0; char *t = s; *done = 1; while (*t) { int i; i = m * 10 + (*t - '0'); m = i & 0x7F; r = (i >> 7); /* r < 10 */ if (r) { *done = 0; } *(t++) = '0' + r; } *(t++) = '\0'; SvCUR_set(pnum, (STRLEN) (t - s)); return (m); } PP(pp_pack) { djSP; dMARK; dORIGMARK; dTARGET; register SV *cat = TARG; register I32 items; STRLEN fromlen; register char *pat = SvPVx(*++MARK, fromlen); char *patcopy; register char *patend = pat + fromlen; register I32 len; I32 datumtype; SV *fromstr; /*SUPPRESS 442*/ static char null10[] = {0,0,0,0,0,0,0,0,0,0}; static char *space10 = " "; /* These must not be in registers: */ char achar; I16 ashort; int aint; unsigned int auint; I32 along; U32 aulong; #ifdef HAS_QUAD Quad_t aquad; 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); patcopy = pat; while (pat < patend) { SV *lengthcode = Nullsv; #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) datumtype = *pat++ & 0xFF; #ifdef PERL_NATINT_PACK natint = 0; #endif if (isSPACE(datumtype)) { patcopy++; continue; } if (datumtype == 'U' && pat == patcopy+1) SvUTF8_on(cat); if (datumtype == '#') { while (pat < patend && *pat != '\n') pat++; continue; } if (*pat == '!') { char *natstr = "sSiIlL"; if (strchr(natstr, datumtype)) { #ifdef PERL_NATINT_PACK natint = 1; #endif pat++; } else DIE(aTHX_ "'!' allowed only after types %s", natstr); } if (*pat == '*') { len = strchr("@Xxu", datumtype) ? 0 : items; pat++; } else if (isDIGIT(*pat)) { len = *pat++ - '0'; while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); if (len < 0) DIE(aTHX_ "Repeat count in pack overflows"); } } else len = 1; if (*pat == '/') { ++pat; if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*') DIE(aTHX_ "/ must be followed by a*, A* or Z*"); lengthcode = sv_2mortal(newSViv(sv_len(items > 0 ? *MARK : &PL_sv_no) + (*pat == 'Z' ? 1 : 0))); } switch(datumtype) { default: DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_PACK)) Perl_warner(aTHX_ WARN_PACK, "Invalid type in pack: '%c'", (int)datumtype); break; case '%': DIE(aTHX_ "%% may only be used in unpack"); case '@': len -= SvCUR(cat); if (len > 0) goto grow; len = -len; if (len > 0) goto shrink; break; case 'X': shrink: if (SvCUR(cat) < len) DIE(aTHX_ "X outside of string"); SvCUR(cat) -= len; *SvEND(cat) = '\0'; break; case 'x': grow: while (len >= 10) { sv_catpvn(cat, null10, 10); len -= 10; } sv_catpvn(cat, null10, len); break; case 'A': case 'Z': case 'a': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); if (pat[-1] == '*') { len = fromlen; if (datumtype == 'Z') ++len; } if (fromlen >= len) { sv_catpvn(cat, aptr, len); if (datumtype == 'Z') *(SvEND(cat)-1) = '\0'; } else { sv_catpvn(cat, aptr, fromlen); len -= fromlen; if (datumtype == 'A') { while (len >= 10) { sv_catpvn(cat, space10, 10); len -= 10; } sv_catpvn(cat, space10, len); } else { while (len >= 10) { sv_catpvn(cat, null10, 10); len -= 10; } sv_catpvn(cat, null10, len); } } break; case 'B': case 'b': { register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; str = SvPV(fromstr, fromlen); if (pat[-1] == '*') len = fromlen; aint = SvCUR(cat); SvCUR(cat) += (len+7)/8; SvGROW(cat, SvCUR(cat) + 1); aptr = SvPVX(cat) + aint; if (len > fromlen) len = fromlen; aint = len; items = 0; if (datumtype == 'B') { for (len = 0; len++ < aint;) { items |= *str++ & 1; if (len & 7) items <<= 1; else { *aptr++ = items & 0xff; items = 0; } } } else { for (len = 0; len++ < aint;) { if (*str++ & 1) items |= 128; if (len & 7) items >>= 1; else { *aptr++ = items & 0xff; items = 0; } } } if (aint & 7) { if (datumtype == 'B') items <<= 7 - (aint & 7); else items >>= 7 - (aint & 7); *aptr++ = items & 0xff; } str = SvPVX(cat) + SvCUR(cat); while (aptr <= str) *aptr++ = '\0'; items = saveitems; } break; case 'H': case 'h': { register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; str = SvPV(fromstr, fromlen); if (pat[-1] == '*') len = fromlen; aint = SvCUR(cat); SvCUR(cat) += (len+1)/2; SvGROW(cat, SvCUR(cat) + 1); aptr = SvPVX(cat) + aint; if (len > fromlen) len = fromlen; aint = len; items = 0; if (datumtype == 'H') { for (len = 0; len++ < aint;) { if (isALPHA(*str)) items |= ((*str++ & 15) + 9) & 15; else items |= *str++ & 15; if (len & 1) items <<= 4; else { *aptr++ = items & 0xff; items = 0; } } } else { for (len = 0; len++ < aint;) { if (isALPHA(*str)) items |= (((*str++ & 15) + 9) & 15) << 4; else items |= (*str++ & 15) << 4; if (len & 1) items >>= 4; else { *aptr++ = items & 0xff; items = 0; } } } if (aint & 1) *aptr++ = items & 0xff; str = SvPVX(cat) + SvCUR(cat); while (aptr <= str) *aptr++ = '\0'; items = saveitems; } break; case 'C': case 'c': while (len-- > 0) { fromstr = NEXTFROM; aint = SvIV(fromstr); achar = aint; sv_catpvn(cat, &achar, sizeof(char)); } break; case 'U': while (len-- > 0) { fromstr = NEXTFROM; auint = SvUV(fromstr); SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN); 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': while (len-- > 0) { fromstr = NEXTFROM; afloat = (float)SvNV(fromstr); sv_catpvn(cat, (char *)&afloat, sizeof (float)); } break; case 'd': case 'D': while (len-- > 0) { fromstr = NEXTFROM; adouble = (double)SvNV(fromstr); sv_catpvn(cat, (char *)&adouble, sizeof (double)); } break; case 'n': while (len-- > 0) { fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); #ifdef HAS_HTONS ashort = PerlSock_htons(ashort); #endif CAT16(cat, &ashort); } break; case 'v': while (len-- > 0) { fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); #ifdef HAS_HTOVS ashort = htovs(ashort); #endif CAT16(cat, &ashort); } 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': #if SHORTSIZE != SIZE16 if (natint) { short ashort; 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': while (len-- > 0) { fromstr = NEXTFROM; auint = SvUV(fromstr); sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); } break; case 'w': while (len-- > 0) { fromstr = NEXTFROM; adouble = Perl_floor(SvNV(fromstr)); if (adouble < 0) DIE(aTHX_ "Cannot compress negative numbers"); if ( #if UVSIZE > 4 && UVSIZE >= NVSIZE adouble <= 0xffffffff #else # ifdef CXUX_BROKEN_CONSTANT_CONVERT adouble <= UV_MAX_cxux # else adouble <= UV_MAX # endif #endif ) { char buf[1 + sizeof(UV)]; char *in = buf + sizeof(buf); UV auv = U_V(adouble); do { *--in = (auv & 0x7f) | 0x80; auv >>= 7; } while (auv); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } else if (SvPOKp(fromstr)) { /* decimal string arithmetics */ char *from, *result, *in; SV *norm; STRLEN len; bool done; /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) DIE(aTHX_ "can compress only unsigned integer"); New('w', result, len, char); in = result + len; done = FALSE; while (!done) *--in = div128(norm, &done) | 0x80; result[len - 1] &= 0x7F; /* clear continue bit */ sv_catpvn(cat, in, (result + len) - in); Safefree(result); SvREFCNT_dec(norm); /* free norm */ } else if (SvNOKp(fromstr)) { char buf[sizeof(double) * 2]; /* 8/7 <= 2 */ char *in = buf + sizeof(buf); do { double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; if (--in < buf) /* this cannot happen ;-) */ DIE(aTHX_ "Cannot compress integer"); adouble = next; } while (adouble > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } else DIE(aTHX_ "Cannot compress non integer"); } break; case 'i': while (len-- > 0) { fromstr = NEXTFROM; aint = SvIV(fromstr); sv_catpvn(cat, (char*)&aint, sizeof(int)); } break; case 'N': while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); #ifdef HAS_HTONL aulong = PerlSock_htonl(aulong); #endif CAT32(cat, &aulong); } break; case 'V': while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); #ifdef HAS_HTOVL aulong = htovl(aulong); #endif CAT32(cat, &aulong); } break; case 'L': #if LONGSIZE != SIZE32 if (natint) { unsigned long aulong; 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': #if LONGSIZE != SIZE32 if (natint) { long along; 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 = (Uquad_t)SvUV(fromstr); sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); } break; case 'q': while (len-- > 0) { fromstr = NEXTFROM; aquad = (Quad_t)SvIV(fromstr); sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); } break; #endif case 'P': len = 1; /* assume SV is correct length */ /* FALL THROUGH */ case 'p': while (len-- > 0) { fromstr = NEXTFROM; 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 (ckWARN(WARN_PACK) && (SvTEMP(fromstr) || (SvPADTMP(fromstr) && !SvREADONLY(fromstr)))) { Perl_warner(aTHX_ WARN_PACK, "Attempt to pack pointer to temporary value"); } if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,n_a); else aptr = SvPV_force(fromstr,n_a); } sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } break; case 'u': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); SvGROW(cat, fromlen * 4 / 3); if (len <= 1) len = 45; else len = len / 3 * 3; while (fromlen > 0) { I32 todo; if (fromlen > len) todo = len; else todo = fromlen; doencodes(cat, aptr, todo); fromlen -= todo; aptr += todo; } break; } } SvSETMAGIC(cat); SP = ORIGMARK; PUSHs(cat); RETURN; } #undef NEXTFROM PP(pp_split) { djSP; dTARG; AV *ary; register I32 limit = POPi; /* note, negative is forever */ SV *sv = POPs; STRLEN len; register char *s = SvPV(sv, len); char *strend = s + len; register PMOP *pm; register REGEXP *rx; register SV *dstr; register char *m; I32 iters = 0; I32 maxiters = (strend - s) + 10; I32 i; char *orig; I32 origlimit = limit; I32 realarray = 0; I32 base; AV *oldstack = PL_curstack; I32 gimme = GIMME_V; I32 oldsave = PL_savestack_ix; I32 make_mortal = 1; MAGIC *mg = (MAGIC *) NULL; #ifdef DEBUGGING Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*); #else pm = (PMOP*)POPs; #endif if (!pm || !s) DIE(aTHX_ "panic: do_split"); rx = pm->op_pmregexp; TAINT_IF((pm->op_pmflags & PMf_LOCALE) && (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); if (pm->op_pmreplroot) { #ifdef USE_ITHREADS ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]); #else ary = GvAVn((GV*)pm->op_pmreplroot); #endif } else if (gimme != G_ARRAY) #ifdef USE_THREADS ary = (AV*)PL_curpad[0]; #else ary = GvAVn(PL_defgv); #endif /* USE_THREADS */ else ary = Nullav; if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { realarray = 1; PUTBACK; av_extend(ary,0); av_clear(ary); SPAGAIN; if ((mg = SvTIED_mg((SV*)ary, 'P'))) { PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)ary, mg)); } else { if (!AvREAL(ary)) { AvREAL_on(ary); AvREIFY_off(ary); for (i = AvFILLp(ary); i >= 0; i--) AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ } /* temporarily switch stacks */ SWITCHSTACK(PL_curstack, ary); make_mortal = 0; } } base = SP - PL_stack_base; orig = s; if (pm->op_pmflags & PMf_SKIPWHITE) { if (pm->op_pmflags & PMf_LOCALE) { while (isSPACE_LC(*s)) s++; } else { while (isSPACE(*s)) s++; } } if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(PL_multiline); PL_multiline = pm->op_pmflags & PMf_MULTILINE; } if (!limit) limit = maxiters + 2; if (pm->op_pmflags & PMf_WHITE) { while (--limit) { m = s; while (m < strend && !((pm->op_pmflags & PMf_LOCALE) ? isSPACE_LC(*m) : isSPACE(*m))) ++m; if (m >= strend) break; dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m + 1; while (s < strend && ((pm->op_pmflags & PMf_LOCALE) ? isSPACE_LC(*s) : isSPACE(*s))) ++s; } } else if (strEQ("^", rx->precomp)) { while (--limit) { /*SUPPRESS 530*/ for (m = s; m < strend && *m != '\n'; m++) ; m++; if (m >= strend) break; dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m; } } else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens && (rx->reganch & ROPT_CHECK_ALL) && !(rx->reganch & ROPT_ANCH)) { int tail = (rx->reganch & RE_INTUIT_TAIL); SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); char c; len = rx->minlen; if (len == 1 && !tail) { c = *SvPV(csv,len); while (--limit) { /*SUPPRESS 530*/ for (m = s; m < strend && *m != c; m++) ; if (m >= strend) break; dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m + 1; } } else { #ifndef lint while (s < strend && --limit && (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, csv, PL_multiline ? FBMrf_MULTILINE : 0)) ) #endif { dstr = NEWSV(31, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m + len; /* Fake \n at the end */ } } } else { maxiters += (strend - s) * rx->nparens; while (s < strend && --limit /* && (!rx->check_substr || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend, 0, NULL)))) */ && CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 /* minend */, sv, NULL, 0)) { TAINT_IF(RX_MATCH_TAINTED(rx)); if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { m = s; s = orig; orig = rx->subbeg; s = orig + (m - s); strend = s + (strend - m); } m = rx->startp[0] + orig; dstr = NEWSV(32, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); if (rx->nparens) { for (i = 1; i <= rx->nparens; i++) { s = rx->startp[i] + orig; m = rx->endp[i] + orig; if (m && s) { dstr = NEWSV(33, m-s); sv_setpvn(dstr, s, m-s); } else dstr = NEWSV(33, 0); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); } } s = rx->endp[0] + orig; } } LEAVE_SCOPE(oldsave); iters = (SP - PL_stack_base) - base; if (iters > maxiters) DIE(aTHX_ "Split loop"); /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { dstr = NEWSV(34, strend-s); sv_setpvn(dstr, s, strend-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); iters++; } else if (!origlimit) { while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) iters--, SP--; } if (realarray) { if (!mg) { SWITCHSTACK(ary, oldstack); if (SvSMAGICAL(ary)) { PUTBACK; mg_set((SV*)ary); SPAGAIN; } if (gimme == G_ARRAY) { EXTEND(SP, iters); Copy(AvARRAY(ary), SP + 1, iters, SV*); SP += iters; RETURN; } } else { PUTBACK; ENTER; call_method("PUSH",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; if (gimme == G_ARRAY) { /* EXTEND should not be needed - we just popped them */ EXTEND(SP, iters); for (i=0; i < iters; i++) { SV **svp = av_fetch(ary, i, FALSE); PUSHs((svp) ? *svp : &PL_sv_undef); } RETURN; } } } else { if (gimme == G_ARRAY) RETURN; } if (iters || !pm->op_pmreplroot) { GETTARGET; PUSHi(iters); RETURN; } RETPUSHUNDEF; } #ifdef USE_THREADS void Perl_unlock_condpair(pTHX_ void *svv) { dTHR; MAGIC *mg = mg_find((SV*)svv, 'm'); if (!mg) Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex"); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) != thr) Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own"); MgOWNER(mg) = 0; COND_SIGNAL(MgOWNERCONDP(mg)); DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n", PTR2UV(thr), PTR2UV(svv));) MUTEX_UNLOCK(MgMUTEXP(mg)); } #endif /* USE_THREADS */ PP(pp_lock) { djSP; dTOPss; SV *retsv = sv; #ifdef USE_THREADS sv_lock(sv); #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV || SvTYPE(retsv) == SVt_PVCV) { retsv = refto(retsv); } SETs(retsv); RETURN; } PP(pp_threadsv) { #ifdef USE_THREADS djSP; EXTEND(SP, 1); if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(*save_threadsv(PL_op->op_targ)); else PUSHs(THREADSV(PL_op->op_targ)); RETURN; #else DIE(aTHX_ "tried to access per-thread data in non-threaded perl"); #endif /* USE_THREADS */ }