summaryrefslogtreecommitdiff
path: root/contrib/perl5/pp.c
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/perl5/pp.c')
-rw-r--r--contrib/perl5/pp.c4550
1 files changed, 4550 insertions, 0 deletions
diff --git a/contrib/perl5/pp.c b/contrib/perl5/pp.c
new file mode 100644
index 000000000000..35b1552af76f
--- /dev/null
+++ b/contrib/perl5/pp.c
@@ -0,0 +1,4550 @@
+/* pp.c
+ *
+ * Copyright (c) 1991-1997, 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"
+#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
+
+/*
+ * Types used in bitwise operations.
+ *
+ * Normally we'd just use IV and UV. However, some hardware and
+ * software combinations (e.g. Alpha and current OSF/1) don't have a
+ * floating-point type to use for NV that has adequate bits to fully
+ * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
+ *
+ * It just so happens that "int" is the right size almost everywhere.
+ */
+typedef int IBW;
+typedef unsigned UBW;
+
+/*
+ * Mask used after bitwise operations.
+ *
+ * There is at least one realm (Cray word machines) that doesn't
+ * 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 LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
+# define BW_BITS 32
+# define BW_MASK ((1 << BW_BITS) - 1)
+# define BW_SIGN (1 << (BW_BITS - 1))
+# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
+# define BWu(u) ((u) & BW_MASK)
+#else
+# define BWi(i) (i)
+# define BWu(u) (u)
+#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
+
+#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
+# 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 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 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));
+#endif
+
+static bool srand_called = FALSE;
+
+/* variations on pp_null */
+
+#ifdef I_UNISTD
+#include <unistd.h>
+#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(ARGS));
+ }
+ else if (gimme == G_SCALAR) {
+ SV* sv = sv_newmortal();
+ if (HvFILL((HV*)TARG))
+ sv_setpvf(sv, "%ld/%ld",
+ (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
+ else
+ sv_setiv(sv, 0);
+ SETs(sv);
+ }
+ RETURN;
+}
+
+PP(pp_padany)
+{
+ DIE("NOT IMPL LINE %d",__LINE__);
+}
+
+/* Translations. */
+
+PP(pp_rv2gv)
+{
+ djSP; dTOPss;
+
+ if (SvROK(sv)) {
+ wasref:
+ 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("Not a GLOB reference");
+ }
+ else {
+ if (SvTYPE(sv) != SVt_PVGV) {
+ char *sym;
+
+ 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(no_usym, "a symbol");
+ if (PL_dowarn)
+ warn(warn_uninit);
+ RETSETUNDEF;
+ }
+ sym = SvPV(sv, PL_na);
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(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:
+ sv = SvRV(sv);
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ case SVt_PVHV:
+ case SVt_PVCV:
+ DIE("Not a SCALAR reference");
+ }
+ }
+ else {
+ GV *gv = (GV*)sv;
+ char *sym;
+
+ 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(no_usym, "a SCALAR");
+ if (PL_dowarn)
+ warn(warn_uninit);
+ RETSETUNDEF;
+ }
+ sym = SvPV(sv, PL_na);
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_symref, sym, "a SCALAR");
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
+ }
+ sv = GvSV(gv);
+ }
+ if (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) {
+ PUSHi(mg->mg_len + 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));
+ }
+ 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, op_name[i]) || strEQ(s + 6, op_desc[i]))
+ goto found;
+ i++;
+ }
+ goto nonesuch; /* Should not happen... */
+ found:
+ oa = opargs[i] >> OASHIFT;
+ while (oa) {
+ if (oa & OA_OPTIONAL) {
+ seen_question = 1;
+ str[n++] = ';';
+ } else if (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(newSVpv(str, n - 1));
+ } else if (code) /* Non-Overridable */
+ goto set;
+ else { /* None such */
+ nonesuch:
+ croak("Cannot find an opnumber for \"%s\"", s+6);
+ }
+ }
+ }
+ cv = sv_2cv(TOPs, &stash, &gv, FALSE);
+ if (cv && SvPOK(cv))
+ ret = sv_2mortal(newSVpv(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*
+refto(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 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 = PL_curcop->cop_stash;
+ else {
+ SV *ssv = POPs;
+ STRLEN len;
+ char *ptr = SvPV(ssv,len);
+ if (PL_dowarn && len == 0)
+ warn("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;
+
+ sv = POPs;
+ elem = SvPV(sv, PL_na);
+ 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);
+ 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 = newSVpv(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 UNOP *unop = cUNOP;
+ 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("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, PL_op));
+ 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))
+ RETPUSHYES;
+ break;
+ case SVt_PVHV:
+ if (HvARRAY(sv) || SvGMAGICAL(sv))
+ 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)) {
+ if (SvREADONLY(sv))
+ RETPUSHUNDEF;
+ if (SvROK(sv))
+ sv_unref(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 (PL_dowarn && cv_const_sv((CV*)sv))
+ warn("Constant subroutine %s undefined",
+ CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
+ /* FALL THROUGH */
+ case SVt_PVFM:
+ { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
+ cv_undef((CV*)sv);
+ CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
+ 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) = PL_curcop->cop_line;
+ 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)
+ croak(no_modify);
+ if (SvIOK(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)
+ croak(no_modify);
+ sv_setsv(TARG, TOPs);
+ if (SvIOK(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)
+ croak(no_modify);
+ sv_setsv(TARG, TOPs);
+ if (SvIOK(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( 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;
+ double value;
+ if (right == 0.0)
+ DIE("Illegal division by zero");
+#ifdef SLOPPYDIVIDE
+ /* insure that 20./5. == 4. */
+ {
+ IV k;
+ if ((double)I_V(left) == left &&
+ (double)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;
+ UV ans;
+
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ IV i = SvIVX(POPs);
+ right = (right_neg = (i < 0)) ? -i : i;
+ }
+ else {
+ double n = POPn;
+ right = U_V((right_neg = (n < 0)) ? -n : n);
+ }
+
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ IV i = SvIVX(POPs);
+ left = (left_neg = (i < 0)) ? -i : i;
+ }
+ else {
+ double n = POPn;
+ left = U_V((left_neg = (n < 0)) ? -n : n);
+ }
+
+ if (!right)
+ DIE("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, -(double)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;
+ STRLEN len;
+
+ tmpstr = POPs;
+ if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
+ if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
+ DIE("Can't x= to readonly value");
+ if (SvROK(tmpstr))
+ sv_unref(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';
+ }
+ (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);
+ {
+ IBW shift = POPi;
+ if (PL_op->op_private & HINT_INTEGER) {
+ IBW i = TOPi;
+ i = BWi(i) << shift;
+ SETi(BWi(i));
+ }
+ else {
+ UBW u = TOPu;
+ u <<= shift;
+ SETu(BWu(u));
+ }
+ RETURN;
+ }
+}
+
+PP(pp_right_shift)
+{
+ djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+ {
+ IBW shift = POPi;
+ if (PL_op->op_private & HINT_INTEGER) {
+ IBW i = TOPi;
+ i = BWi(i) >> shift;
+ SETi(BWi(i));
+ }
+ else {
+ UBW u = TOPu;
+ u >>= shift;
+ SETu(BWu(u));
+ }
+ 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;
+
+ if (left == right)
+ value = 0;
+ else if (left < right)
+ value = -1;
+ else if (left > right)
+ value = 1;
+ else {
+ SETs(&PL_sv_undef);
+ RETURN;
+ }
+ 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) {
+ IBW value = SvIV(left) & SvIV(right);
+ SETi(BWi(value));
+ }
+ else {
+ UBW value = SvUV(left) & SvUV(right);
+ SETu(BWu(value));
+ }
+ }
+ 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) {
+ IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+ SETi(BWi(value));
+ }
+ else {
+ UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+ SETu(BWu(value));
+ }
+ }
+ 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) {
+ IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+ SETi(BWi(value));
+ }
+ else {
+ UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+ SETu(BWu(value));
+ }
+ }
+ 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) && SvIVX(sv) != IV_MIN)
+ SETi(-SvIVX(sv));
+ else 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
+ sv_setnv(TARG, -SvNV(sv));
+ SETTARG;
+ }
+ else
+ SETn(-SvNV(sv));
+ }
+ RETURN;
+}
+
+PP(pp_not)
+{
+#ifdef OVERLOAD
+ djSP; tryAMAGICunSET(not);
+#endif /* OVERLOAD */
+ *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) {
+ IBW value = ~SvIV(sv);
+ SETi(BWi(value));
+ }
+ else {
+ UBW value = ~SvUV(sv);
+ SETu(BWu(value));
+ }
+ }
+ 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("Illegal division by zero");
+ value = POPi / value;
+ PUSHi( value );
+ RETURN;
+ }
+}
+
+PP(pp_i_modulo)
+{
+ djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE("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(atan2(left, right));
+ RETURN;
+ }
+}
+
+PP(pp_sin)
+{
+ djSP; dTARGET; tryAMAGICun(sin);
+ {
+ double value;
+ value = POPn;
+ value = sin(value);
+ XPUSHn(value);
+ RETURN;
+ }
+}
+
+PP(pp_cos)
+{
+ djSP; dTARGET; tryAMAGICun(cos);
+ {
+ double value;
+ value = POPn;
+ value = 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
+*/
+#ifndef my_rand
+# define my_rand rand
+#endif
+#ifndef my_srand
+# define my_srand srand
+#endif
+
+PP(pp_rand)
+{
+ djSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = 1.0;
+ else
+ value = POPn;
+ if (value == 0.0)
+ value = 1.0;
+ if (!srand_called) {
+ (void)my_srand((unsigned)seed());
+ srand_called = TRUE;
+ }
+#if RANDBITS == 31
+ value = my_rand() * value / 2147483648.0;
+#else
+#if RANDBITS == 16
+ value = my_rand() * value / 65536.0;
+#else
+#if RANDBITS == 15
+ value = my_rand() * value / 32768.0;
+#else
+ value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
+#endif
+#endif
+#endif
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_srand)
+{
+ djSP;
+ UV anum;
+ if (MAXARG < 1)
+ anum = seed();
+ else
+ anum = POPu;
+ (void)my_srand((unsigned)anum);
+ srand_called = TRUE;
+ EXTEND(SP, 1);
+ RETPUSHYES;
+}
+
+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.
+ * Might be a good idea to add that function to CORE as well.
+ * No numbers below come from careful analysis or anyting 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;
+ U32 u;
+#ifdef VMS
+# include <starlet.h>
+ /* when[] = (low 32 bits, high 32 bits) of time since epoch
+ * in 100-ns units, typically incremented ever 10 ms. */
+ unsigned int when[2];
+ _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)PL_stack_sp;
+#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
+ u += SEED_C5 * (U32)(UV)&when;
+#endif
+ return u;
+}
+
+PP(pp_exp)
+{
+ djSP; dTARGET; tryAMAGICun(exp);
+ {
+ double value;
+ value = POPn;
+ value = exp(value);
+ XPUSHn(value);
+ RETURN;
+ }
+}
+
+PP(pp_log)
+{
+ djSP; dTARGET; tryAMAGICun(log);
+ {
+ double value;
+ value = POPn;
+ if (value <= 0.0) {
+ SET_NUMERIC_STANDARD();
+ DIE("Can't take log of %g", value);
+ }
+ value = log(value);
+ XPUSHn(value);
+ RETURN;
+ }
+}
+
+PP(pp_sqrt)
+{
+ djSP; dTARGET; tryAMAGICun(sqrt);
+ {
+ double value;
+ value = POPn;
+ if (value < 0.0) {
+ SET_NUMERIC_STANDARD();
+ DIE("Can't take sqrt of %g", value);
+ }
+ value = sqrt(value);
+ XPUSHn(value);
+ RETURN;
+ }
+}
+
+PP(pp_int)
+{
+ djSP; dTARGET;
+ {
+ double value = TOPn;
+ IV iv;
+
+ if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
+ iv = SvIVX(TOPs);
+ SETi(iv);
+ }
+ else {
+ if (value >= 0.0)
+ (void)modf(value, &value);
+ else {
+ (void)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);
+ {
+ double 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;
+
+ tmps = POPp;
+ XPUSHu(scan_hex(tmps, 99, &argtype));
+ RETURN;
+}
+
+PP(pp_oct)
+{
+ djSP; dTARGET;
+ UV value;
+ I32 argtype;
+ char *tmps;
+
+ tmps = POPp;
+ while (*tmps && isSPACE(*tmps))
+ tmps++;
+ if (*tmps == '0')
+ tmps++;
+ if (*tmps == 'x')
+ value = scan_hex(++tmps, 99, &argtype);
+ else
+ value = scan_oct(tmps, 99, &argtype);
+ XPUSHu(value);
+ RETURN;
+}
+
+/* String stuff. */
+
+PP(pp_length)
+{
+ djSP; dTARGET;
+ SETi( sv_len(TOPs) );
+ RETURN;
+}
+
+PP(pp_substr)
+{
+ djSP; dTARGET;
+ SV *sv;
+ I32 len;
+ STRLEN curlen;
+ 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 */
+ 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 (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 (PL_dowarn || lvalue || repl)
+ warn("substr outside of string");
+ RETPUSHUNDEF;
+ }
+ else {
+ tmps += pos;
+ sv_setpvn(TARG, tmps, rem);
+ if (lvalue) { /* it's an lvalue! */
+ if (!SvGMAGICAL(sv)) {
+ if (SvROK(sv)) {
+ SvPV_force(sv,PL_na);
+ if (PL_dowarn)
+ warn("Attempt to use reference as lvalue in substr");
+ }
+ if (SvOK(sv)) /* is it defined ? */
+ (void)SvPOK_only(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;
+ }
+ else if (repl)
+ sv_insert(sv, pos, rem, repl, repl_len);
+ }
+ 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;
+ 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)
+ retnum = 0;
+ else {
+ 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;
+ }
+ if (len > srclen) {
+ if (size <= 8)
+ retnum = 0;
+ else {
+ offset >>= 3;
+ if (size == 16) {
+ if (offset >= srclen)
+ retnum = 0;
+ else
+ retnum = (unsigned long) s[offset] << 8;
+ }
+ else if (size == 32) {
+ if (offset >= srclen)
+ retnum = 0;
+ else if (offset + 1 >= srclen)
+ retnum = (unsigned long) s[offset] << 24;
+ else if (offset + 2 >= srclen)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16);
+ else
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8);
+ }
+ }
+ }
+ else if (size < 8)
+ retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
+ else {
+ offset >>= 3;
+ if (size == 8)
+ retnum = s[offset];
+ else if (size == 16)
+ retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
+ else if (size == 32)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8) + s[offset+3];
+ }
+ }
+
+ sv_setuv(TARG, (UV)retnum);
+ 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)
+ offset = 0;
+ else if (offset > biglen)
+ offset = biglen;
+ if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
+ (unsigned char*)tmps + biglen, little, 0)))
+ retval = -1 + arybase;
+ else
+ retval = tmps2 - tmps + arybase;
+ PUSHi(retval);
+ RETURN;
+}
+
+PP(pp_rindex)
+{
+ djSP; dTARGET;
+ SV *big;
+ SV *little;
+ STRLEN blen;
+ STRLEN llen;
+ SV *offstr;
+ I32 offset;
+ I32 retval;
+ char *tmps;
+ char *tmps2;
+ I32 arybase = PL_curcop->cop_arybase;
+
+ if (MAXARG >= 3)
+ offstr = POPs;
+ little = POPs;
+ big = POPs;
+ tmps2 = SvPV(little, llen);
+ tmps = SvPV(big, blen);
+ if (MAXARG < 3)
+ offset = blen;
+ else
+ offset = SvIV(offstr) - 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;
+ else
+ retval = tmps2 - tmps + arybase;
+ PUSHi(retval);
+ RETURN;
+}
+
+PP(pp_sprintf)
+{
+ djSP; dMARK; dORIGMARK; dTARGET;
+#ifdef USE_LOCALE_NUMERIC
+ if (PL_op->op_private & OPpLOCALE)
+ SET_NUMERIC_LOCAL();
+ else
+ SET_NUMERIC_STANDARD();
+#endif
+ do_sprintf(TARG, SP-MARK, MARK+1);
+ TAINT_IF(SvTAINTED(TARG));
+ SP = ORIGMARK;
+ PUSHTARG;
+ RETURN;
+}
+
+PP(pp_ord)
+{
+ djSP; dTARGET;
+ I32 value;
+ char *tmps;
+
+#ifndef I286
+ tmps = POPp;
+ value = (I32) (*tmps & 255);
+#else
+ I32 anum;
+ tmps = POPp;
+ anum = (I32) *tmps;
+ value = (I32) (anum & 255);
+#endif
+ XPUSHi(value);
+ RETURN;
+}
+
+PP(pp_chr)
+{
+ djSP; dTARGET;
+ char *tmps;
+
+ (void)SvUPGRADE(TARG,SVt_PV);
+ SvGROW(TARG,2);
+ SvCUR_set(TARG, 1);
+ tmps = SvPVX(TARG);
+ *tmps++ = POPi;
+ *tmps = '\0';
+ (void)SvPOK_only(TARG);
+ XPUSHs(TARG);
+ RETURN;
+}
+
+PP(pp_crypt)
+{
+ djSP; dTARGET; dPOPTOPssrl;
+#ifdef HAS_CRYPT
+ char *tmps = SvPV(left, PL_na);
+#ifdef FCRYPT
+ sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
+#else
+ sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
+#endif
+#else
+ DIE(
+ "The crypt() function is unimplemented due to excessive paranoia.");
+#endif
+ SETs(TARG);
+ RETURN;
+}
+
+PP(pp_ucfirst)
+{
+ djSP;
+ SV *sv = TOPs;
+ register char *s;
+
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPV_force(sv, PL_na);
+ if (*s) {
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toUPPER_LC(*s);
+ }
+ else
+ *s = toUPPER(*s);
+ }
+
+ RETURN;
+}
+
+PP(pp_lcfirst)
+{
+ djSP;
+ SV *sv = TOPs;
+ register char *s;
+
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPV_force(sv, PL_na);
+ if (*s) {
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toLOWER_LC(*s);
+ }
+ else
+ *s = toLOWER(*s);
+ }
+
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_uc)
+{
+ djSP;
+ SV *sv = TOPs;
+ register char *s;
+ STRLEN len;
+
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+
+ s = SvPV_force(sv, len);
+ if (len) {
+ register char *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);
+ }
+ }
+ RETURN;
+}
+
+PP(pp_lc)
+{
+ djSP;
+ SV *sv = TOPs;
+ register char *s;
+ STRLEN len;
+
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+
+ s = SvPV_force(sv, len);
+ if (len) {
+ register char *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);
+ }
+ }
+ RETURN;
+}
+
+PP(pp_quotemeta)
+{
+ djSP; dTARGET;
+ SV *sv = TOPs;
+ STRLEN len;
+ register char *s = SvPV(sv,len);
+ register char *d;
+
+ if (len) {
+ (void)SvUPGRADE(TARG, SVt_PV);
+ SvGROW(TARG, (len * 2) + 1);
+ d = SvPVX(TARG);
+ while (len--) {
+ if (!isALNUM(*s))
+ *d++ = '\\';
+ *d++ = *s++;
+ }
+ *d = '\0';
+ SvCUR_set(TARG, d - SvPVX(TARG));
+ (void)SvPOK_only(TARG);
+ }
+ else
+ sv_setpvn(TARG, s, len);
+ SETs(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(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; dTARGET;
+ 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) {
+ PUTBACK;
+ /* might clobber stack_sp */
+ sv_setsv(TARG, realhv ?
+ hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
+ SPAGAIN;
+ PUSHs(TARG);
+ }
+ }
+ else if (gimme == G_SCALAR)
+ RETPUSHUNDEF;
+
+ RETURN;
+}
+
+PP(pp_values)
+{
+ return do_kv(ARGS);
+}
+
+PP(pp_keys)
+{
+ return do_kv(ARGS);
+}
+
+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);
+ while (++MARK <= SP) {
+ if (hvtype == SVt_PVHV)
+ sv = hv_delete_ent(hv, *MARK, discard, 0);
+ else
+ DIE("Not a HASH reference");
+ *MARK = sv ? sv : &PL_sv_undef;
+ }
+ 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
+ DIE("Not a HASH reference");
+ if (!sv)
+ sv = &PL_sv_undef;
+ if (!discard)
+ PUSHs(sv);
+ }
+ RETURN;
+}
+
+PP(pp_exists)
+{
+ djSP;
+ SV *tmpsv = POPs;
+ HV *hv = (HV*)POPs;
+ if (SvTYPE(hv) == SVt_PVHV) {
+ if (hv_exists_ent(hv, tmpsv, 0))
+ RETPUSHYES;
+ } else if (SvTYPE(hv) == SVt_PVAV) {
+ if (avhv_exists_ent((AV*)hv, tmpsv, 0))
+ RETPUSHYES;
+ } else {
+ DIE("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("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)
+ DIE(no_helem, SvPV(keysv, PL_na));
+ 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;
+ if (ix < 0)
+ *lelem = &PL_sv_undef;
+ else if (!(*lelem = firstrelem[ix]))
+ *lelem = &PL_sv_undef;
+ }
+ else {
+ ix -= arybase;
+ if (ix >= max || !(*lelem = firstrelem[ix]))
+ *lelem = &PL_sv_undef;
+ }
+ if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
+ is_something_there = TRUE;
+ }
+ 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 (PL_dowarn)
+ warn("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 (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ *MARK-- = mg->mg_obj;
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ perl_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(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)) {
+ if (AvREIFY(ary))
+ av_reify(ary);
+ else
+ assert(AvREAL(ary)); /* would leak, so croak */
+ }
+
+ 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 (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ *MARK-- = mg->mg_obj;
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ perl_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 (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ *MARK-- = mg->mg_obj;
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ perl_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;
+ }
+ SP = oldsp;
+ }
+ else {
+ register char *up;
+ register char *down;
+ register I32 tmp;
+ dTARGET;
+ STRLEN len;
+
+ 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) {
+ down = SvPVX(TARG) + len - 1;
+ while (down > up) {
+ tmp = *up;
+ *up++ = *down;
+ *down-- = tmp;
+ }
+ (void)SvPOK_only(TARG);
+ }
+ SP = MARK + 1;
+ SETTARG;
+ }
+ RETURN;
+}
+
+STATIC SV *
+mul128(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 = newSVpv("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. */
+
+static const char uuemap[] =
+ "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
+static char uudmap[256]; /* Initialised on first use */
+#if 'I' == 73 && 'J' == 74
+/* On an ASCII/ISO kind of system */
+#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
+#else
+/*
+ Some other sort of character set - use memchr() so we don't match
+ the null byte.
+ */
+#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
+#endif
+
+PP(pp_unpack)
+{
+ djSP;
+ dPOPPOPssrl;
+ SV **oldsp = SP;
+ 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;
+
+ /* 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
+ unsigned Quad_t auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+ I32 checksum = 0;
+ register U32 culong;
+ double cdouble;
+ static char* bitcount = 0;
+ int commas = 0;
+
+ if (gimme != G_ARRAY) { /* arrange to do first one only */
+ /*SUPPRESS 530*/
+ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
+ if (strchr("aAbBhHP", *patend) || *pat == '%') {
+ patend++;
+ while (isDIGIT(*patend) || *patend == '*')
+ patend++;
+ }
+ else
+ patend++;
+ }
+ while (pat < patend) {
+ reparse:
+ datumtype = *pat++ & 0xFF;
+ if (isSPACE(datumtype))
+ continue;
+ if (pat >= patend)
+ len = 1;
+ else if (*pat == '*') {
+ len = strend - strbeg; /* long enough */
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = (datumtype != '@');
+ switch(datumtype) {
+ default:
+ croak("Invalid type in unpack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && PL_dowarn)
+ warn("Invalid type in unpack: '%c'", (int)datumtype);
+ 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("@ outside of string");
+ s = strbeg + len;
+ break;
+ case 'X':
+ if (len > s - strbeg)
+ DIE("X outside of string");
+ s -= len;
+ break;
+ case 'x':
+ if (len > strend - s)
+ DIE("x outside of string");
+ s += len;
+ break;
+ case 'A':
+ 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') {
+ aptr = s; /* borrow register */
+ 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 (pat[-1] == '*' || len > (strend - s) * 8)
+ len = (strend - s) * 8;
+ if (checksum) {
+ if (!bitcount) {
+ Newz(601, 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]++;
+ }
+ }
+ while (len >= 8) {
+ culong += 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);
+ aptr = pat; /* borrow register */
+ pat = SvPVX(sv);
+ if (datumtype == 'b') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7) /*SUPPRESS 595*/
+ bits >>= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + (bits & 1);
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7)
+ bits <<= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + ((bits & 128) != 0);
+ }
+ }
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ XPUSHs(sv_2mortal(sv));
+ break;
+ case 'H':
+ case 'h':
+ if (pat[-1] == '*' || len > (strend - s) * 2)
+ len = (strend - s) * 2;
+ sv = NEWSV(35, len + 1);
+ SvCUR_set(sv, len);
+ SvPOK_on(sv);
+ aptr = pat; /* borrow register */
+ pat = SvPVX(sv);
+ if (datumtype == 'h') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits >>= 4;
+ else
+ bits = *s++;
+ *pat++ = PL_hexdigit[bits & 15];
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits <<= 4;
+ else
+ bits = *s++;
+ *pat++ = PL_hexdigit[(bits >> 4) & 15];
+ }
+ }
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ 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 's':
+ along = (strend - s) / SIZE16;
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ COPY16(s, &ashort);
+ 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));
+ }
+ }
+ break;
+ case 'v':
+ case 'n':
+ case 'S':
+ along = (strend - s) / SIZE16;
+ if (len > along)
+ len = along;
+ if (checksum) {
+ 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);
+ 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, (IV)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 += (double)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 */
+ (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 += (double)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);
+ sv_setuv(sv, (UV)auint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'l':
+ along = (strend - s) / SIZE32;
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ COPY32(s, &along);
+ 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));
+ }
+ }
+ break;
+ case 'V':
+ case 'N':
+ case 'L':
+ along = (strend - s) / SIZE32;
+ if (len > along)
+ len = along;
+ if (checksum) {
+ 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 += (double)aulong;
+ else
+ culong += aulong;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ 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;
+
+ sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
+ while (s < strend) {
+ sv = mul128(sv, *s & 0x7f);
+ if (!(*s++ & 0x80)) {
+ bytes = 0;
+ break;
+ }
+ }
+ t = SvPV(sv, PL_na);
+ while (*t == '0')
+ t++;
+ sv_chop(sv, t);
+ PUSHs(sv_2mortal(sv));
+ len--;
+ auv = 0;
+ }
+ }
+ if ((s >= strend) && bytes)
+ croak("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, (double)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(unsigned Quad_t) > strend)
+ auquad = 0;
+ else {
+ Copy(s, &auquad, 1, unsigned Quad_t);
+ s += sizeof(unsigned Quad_t);
+ }
+ sv = NEWSV(43, 0);
+ if (auquad <= UV_MAX)
+ sv_setuv(sv, (UV)auquad);
+ else
+ sv_setnv(sv, (double)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, (double)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, (double)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 (uudmap['M'] == 0) {
+ int i;
+
+ for (i = 0; i < sizeof(uuemap); i += 1)
+ uudmap[uuemap[i]] = i;
+ /*
+ * Because ' ' and '`' map to the same value,
+ * we need to decode them both the same.
+ */
+ uudmap[' '] = 0;
+ }
+
+ along = (strend - s) * 3 / 4;
+ sv = NEWSV(42, along);
+ if (along)
+ SvPOK_on(sv);
+ while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
+ I32 a, b, c, d;
+ char hunk[4];
+
+ hunk[3] = '\0';
+ len = (*s++ - ' ') & 077;
+ while (len > 0) {
+ if (s < strend && ISUUCHAR(*s))
+ a = uudmap[*s++] & 077;
+ else
+ a = 0;
+ if (s < strend && ISUUCHAR(*s))
+ b = uudmap[*s++] & 077;
+ else
+ b = 0;
+ if (s < strend && ISUUCHAR(*s))
+ c = uudmap[*s++] & 077;
+ else
+ c = 0;
+ if (s < strend && ISUUCHAR(*s))
+ d = uudmap[*s++] & 077;
+ else
+ d = 0;
+ hunk[0] = (a << 2) | (b >> 4);
+ 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("iIlLN", datumtype)) ) {
+ double 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 = 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 == oldsp && gimme == G_SCALAR)
+ PUSHs(&PL_sv_undef);
+ RETURN;
+}
+
+STATIC void
+doencodes(register SV *sv, register char *s, register I32 len)
+{
+ char hunk[5];
+
+ *hunk = uuemap[len];
+ sv_catpvn(sv, hunk, 1);
+ hunk[4] = '\0';
+ while (len > 2) {
+ hunk[0] = uuemap[(077 & (*s >> 2))];
+ hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
+ hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
+ hunk[3] = uuemap[(077 & (s[2] & 077))];
+ sv_catpvn(sv, hunk, 4);
+ s += 3;
+ len -= 3;
+ }
+ if (len > 0) {
+ char r = (len > 1 ? s[1] : '\0');
+ hunk[0] = uuemap[(077 & (*s >> 2))];
+ hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
+ hunk[2] = uuemap[(077 & ((r << 2) & 074))];
+ hunk[3] = uuemap[0];
+ sv_catpvn(sv, hunk, 4);
+ }
+ sv_catpvn(sv, "\n", 1);
+}
+
+STATIC SV *
+is_an_int(char *s, STRLEN l)
+{
+ SV *result = newSVpv("", l);
+ char *result_c = SvPV(result, PL_na); /* 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);
+}
+
+STATIC int
+div128(SV *pnum, bool *done)
+ /* must be '\0' terminated */
+
+{
+ 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);
+ 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;
+ unsigned Quad_t auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+ int commas = 0;
+
+ items = SP - MARK;
+ MARK++;
+ sv_setpvn(cat, "", 0);
+ while (pat < patend) {
+#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
+ datumtype = *pat++ & 0xFF;
+ if (isSPACE(datumtype))
+ continue;
+ if (*pat == '*') {
+ len = strchr("@Xxu", datumtype) ? 0 : items;
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = 1;
+ switch(datumtype) {
+ default:
+ croak("Invalid type in pack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && PL_dowarn)
+ warn("Invalid type in pack: '%c'", (int)datumtype);
+ break;
+ case '%':
+ DIE("%% 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("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 'a':
+ fromstr = NEXTFROM;
+ aptr = SvPV(fromstr, fromlen);
+ if (pat[-1] == '*')
+ len = fromlen;
+ if (fromlen > len)
+ sv_catpvn(cat, aptr, len);
+ 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':
+ {
+ char *savepat = pat;
+ I32 saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = SvPV(fromstr, fromlen);
+ if (pat[-1] == '*')
+ len = fromlen;
+ pat = aptr;
+ 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 |= *pat++ & 1;
+ if (len & 7)
+ items <<= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (*pat++ & 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;
+ }
+ pat = SvPVX(cat) + SvCUR(cat);
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'H':
+ case 'h':
+ {
+ char *savepat = pat;
+ I32 saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = SvPV(fromstr, fromlen);
+ if (pat[-1] == '*')
+ len = fromlen;
+ pat = aptr;
+ 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(*pat))
+ items |= ((*pat++ & 15) + 9) & 15;
+ else
+ items |= *pat++ & 15;
+ if (len & 1)
+ items <<= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*pat))
+ items |= (((*pat++ & 15) + 9) & 15) << 4;
+ else
+ items |= (*pat++ & 15) << 4;
+ if (len & 1)
+ items >>= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 1)
+ *aptr++ = items & 0xff;
+ pat = SvPVX(cat) + SvCUR(cat);
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'C':
+ case 'c':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = SvIV(fromstr);
+ achar = aint;
+ sv_catpvn(cat, &achar, sizeof(char));
+ }
+ 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':
+ case 's':
+ 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 = floor(SvNV(fromstr));
+
+ if (adouble < 0)
+ croak("Cannot compress negative numbers");
+
+ if (
+#ifdef BW_BITS
+ adouble <= BW_MASK
+#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)
+ croak("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 ;-) */
+ croak ("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
+ croak("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':
+ 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);
+ }
+ 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));
+ }
+ break;
+ case 'q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aquad = (Quad_t)SvIV(fromstr);
+ sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
+ }
+ break;
+#endif /* HAS_QUAD */
+ 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 {
+ /* XXX better yet, could spirit away the string to
+ * a safe spot and hang on to it until the result
+ * of pack() (and all copies of the result) are
+ * gone.
+ */
+ if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
+ warn("Attempt to pack pointer to temporary value");
+ if (SvPOK(fromstr) || SvNIOK(fromstr))
+ aptr = SvPV(fromstr,PL_na);
+ else
+ aptr = SvPV_force(fromstr,PL_na);
+ }
+ 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("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)
+ ary = GvAVn((GV*)pm->op_pmreplroot);
+ 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 (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
+ PUSHMARK(SP);
+ XPUSHs(mg->mg_obj);
+ }
+ else {
+ if (!AvREAL(ary)) {
+ AvREAL_on(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->check_substr && !rx->nparens
+ && (rx->reganch & ROPT_CHECK_ALL)
+ && !(rx->reganch & ROPT_ANCH)) {
+ i = SvCUR(rx->check_substr);
+ if (i == 1 && !SvTAIL(rx->check_substr)) {
+ i = *SvPVX(rx->check_substr);
+ while (--limit) {
+ /*SUPPRESS 530*/
+ for (m = s; m < strend && *m != i; 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,
+ rx->check_substr, 0)) )
+#endif
+ {
+ dstr = NEWSV(31, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (make_mortal)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ s = m + i;
+ }
+ }
+ }
+ else {
+ maxiters += (strend - s) * rx->nparens;
+ while (s < strend && --limit &&
+ CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
+ {
+ TAINT_IF(RX_MATCH_TAINTED(rx));
+ if (rx->subbase
+ && rx->subbase != orig) {
+ m = s;
+ s = orig;
+ orig = rx->subbase;
+ s = orig + (m - s);
+ strend = s + (strend - m);
+ }
+ m = rx->startp[0];
+ 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];
+ m = rx->endp[i];
+ 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];
+ }
+ }
+
+ LEAVE_SCOPE(oldsave);
+ iters = (SP - PL_stack_base) - base;
+ if (iters > maxiters)
+ DIE("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;
+ perl_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
+unlock_condpair(void *svv)
+{
+ dTHR;
+ MAGIC *mg = mg_find((SV*)svv, 'm');
+
+ if (!mg)
+ croak("panic: unlock_condpair unlocking non-mutex");
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) != thr)
+ croak("panic: unlock_condpair unlocking mutex that we don't own");
+ MgOWNER(mg) = 0;
+ COND_SIGNAL(MgOWNERCONDP(mg));
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
+ (unsigned long)thr, (unsigned long)svv);)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+}
+#endif /* USE_THREADS */
+
+PP(pp_lock)
+{
+ djSP;
+ dTOPss;
+ SV *retsv = sv;
+#ifdef USE_THREADS
+ MAGIC *mg;
+
+ if (SvROK(sv))
+ sv = SvRV(sv);
+
+ mg = condpair_magic(sv);
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) == thr)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ else {
+ while (MgOWNER(mg))
+ COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
+ MgOWNER(mg) = thr;
+ 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 */
+ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
+ || SvTYPE(retsv) == SVt_PVCV) {
+ retsv = refto(retsv);
+ }
+ SETs(retsv);
+ RETURN;
+}
+
+PP(pp_threadsv)
+{
+ djSP;
+#ifdef USE_THREADS
+ 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("tried to access per-thread data in non-threaded perl");
+#endif /* USE_THREADS */
+}
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-21 15:27:57 +0000