-/***********************************************************
+/* pp.c
*
- * $Header: /usr/src/local/lwall/perl5/RCS/pp.c, v 4.1 92/08/07 18:26:21 lwall Exp Locker: lwall $
+ * Copyright (c) 1991-1997, Larry Wall
*
- * Description:
- * Push/Pop code.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
- * Standards:
- *
- * Created:
- * Mon Jun 15 16:45:59 1992
- *
- * Author:
- * Larry Wall <lwall@netlabs.com>
- *
- * $Log: pp.c, v $
- * Revision 4.1 92/08/07 18:26:21 lwall
- *
- *
- **********************************************************/
+ */
+
+/*
+ * "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"
-#ifdef HAS_SOCKET
-#include <sys/socket.h>
-#include <netdb.h>
-#ifndef ENOTSOCK
-#include <net/errno.h>
-#endif
-#endif
+/*
+ * 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;
-#ifdef HAS_SELECT
-#ifdef I_SYS_SELECT
-#ifndef I_SYS_TIME
-#include <sys/select.h>
-#endif
-#endif
+/*
+ * 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 BYTEORDER > 0xFFFF && 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
-#ifdef HOST_NOT_FOUND
-extern int h_errno;
+/*
+ * 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.)
+ */
+#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
-#ifdef I_PWD
-#include <pwd.h>
-#endif
-#ifdef I_GRP
-#include <grp.h>
-#endif
-#ifdef I_UTIME
-#include <utime.h>
-#endif
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
+static void doencodes _((SV* sv, char* s, I32 len));
+static SV* refto _((SV* sv));
+static U32 seed _((void));
-static I32 dopoptosub P((I32 startingblock));
+static bool srand_called = FALSE;
-/* Nothing. */
+/* variations on pp_null */
-PP(pp_null)
-{
- return NORMAL;
-}
+#ifdef DONT_DECLARE_STD
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+#else
+extern pid_t getpid (void);
+#endif
PP(pp_stub)
{
- dSP;
- if (GIMME != G_ARRAY) {
+ djSP;
+ if (GIMME_V == G_SCALAR)
XPUSHs(&sv_undef);
- }
RETURN;
}
/* Pushy stuff. */
-PP(pp_pushmark)
-{
- if (++markstack_ptr == markstack_max) {
- I32 oldmax = markstack_max - markstack;
- I32 newmax = oldmax * 3 / 2;
-
- Renew(markstack, newmax, I32);
- markstack_ptr = markstack + oldmax;
- markstack_max = markstack + newmax;
- }
- *markstack_ptr = stack_sp - stack_base;
- return NORMAL;
-}
-
-PP(pp_wantarray)
+PP(pp_padav)
{
- dSP;
- I32 cxix;
+ djSP; dTARGET;
+ if (op->op_private & OPpLVAL_INTRO)
+ SAVECLEARSV(curpad[op->op_targ]);
EXTEND(SP, 1);
-
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- RETPUSHUNDEF;
-
- if (cxstack[cxix].blk_gimme == G_ARRAY)
- RETPUSHYES;
- else
- RETPUSHNO;
-}
-
-PP(pp_const)
-{
- dSP;
- XPUSHs(cSVOP->op_sv);
- RETURN;
-}
-
-static void
-ucase(s,send)
-register char *s;
-register char *send;
-{
- while (s < send) {
- if (isLOWER(*s))
- *s = toupper(*s);
- s++;
+ if (op->op_flags & OPf_REF) {
+ PUSHs(TARG);
+ RETURN;
}
-}
-
-static void
-lcase(s,send)
-register char *s;
-register char *send;
-{
- while (s < send) {
- if (isUPPER(*s))
- *s = tolower(*s);
- s++;
+ 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 : &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);
}
-}
-
-PP(pp_interp)
-{
- DIE("panic: pp_interp");
-}
-
-PP(pp_gvsv)
-{
- dSP;
- EXTEND(sp,1);
- if (op->op_flags & OPf_INTRO)
- PUSHs(save_scalar(cGVOP->op_gv));
- else
- PUSHs(GvSV(cGVOP->op_gv));
- RETURN;
-}
-
-PP(pp_gv)
-{
- dSP;
- XPUSHs((SV*)cGVOP->op_gv);
- RETURN;
-}
-
-PP(pp_padsv)
-{
- dSP; dTARGET;
- XPUSHs(TARG);
- if (op->op_flags & OPf_INTRO)
- SAVECLEARSV(curpad[op->op_targ]);
RETURN;
}
-PP(pp_padav)
-{
- dSP; dTARGET;
- XPUSHs(TARG);
- if (op->op_flags & OPf_INTRO)
- SAVECLEARSV(curpad[op->op_targ]);
- if (op->op_flags & OPf_LVAL)
- RETURN;
- PUTBACK;
- return pp_rv2av();
-}
-
PP(pp_padhv)
{
- dSP; dTARGET;
+ djSP; dTARGET;
+ I32 gimme;
+
XPUSHs(TARG);
- if (op->op_flags & OPf_INTRO)
+ if (op->op_private & OPpLVAL_INTRO)
SAVECLEARSV(curpad[op->op_targ]);
- if (op->op_flags & OPf_LVAL)
+ if (op->op_flags & OPf_REF)
RETURN;
- PUTBACK;
- return pp_rv2hv();
+ 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__);
}
-PP(pp_pushre)
-{
- dSP;
- XPUSHs((SV*)op);
- RETURN;
-}
-
/* Translations. */
PP(pp_rv2gv)
{
- dSP; dTOPss;
+ djSP; dTOPss;
+
if (SvROK(sv)) {
+ wasref:
sv = SvRV(sv);
- if (SvTYPE(sv) != SVt_PVGV)
- DIE("Not a glob reference");
+ 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) {
- if (!SvOK(sv))
- DIE(no_usym, "a glob");
- sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
- }
- }
- if (op->op_flags & OPf_INTRO) {
- GP *ogp = GvGP(sv);
+ char *sym;
- SSCHECK(3);
- SSPUSHPTR(sv);
- SSPUSHPTR(ogp);
- SSPUSHINT(SAVEt_GP);
-
- if (op->op_flags & OPf_SPECIAL)
- GvGP(sv)->gp_refcnt++; /* will soon be assigned */
- else {
- GP *gp;
- Newz(602,gp, 1, GP);
- GvGP(sv) = gp;
- GvREFCNT(sv) = 1;
- GvSV(sv) = NEWSV(72,0);
- GvLINE(sv) = curcop->cop_line;
- GvEGV(sv) = sv;
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvROK(sv))
+ goto wasref;
+ }
+ if (!SvOK(sv)) {
+ if (op->op_flags & OPf_REF ||
+ op->op_private & HINT_STRICT_REFS)
+ DIE(no_usym, "a symbol");
+ if (dowarn)
+ warn(warn_uninit);
+ RETSETUNDEF;
+ }
+ sym = SvPV(sv, na);
+ if (op->op_private & HINT_STRICT_REFS)
+ DIE(no_symref, sym, "a symbol");
+ sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
}
}
+ if (op->op_private & OPpLVAL_INTRO)
+ save_gp((GV*)sv, !(op->op_flags & OPf_SPECIAL));
SETs(sv);
RETURN;
}
-PP(pp_sv2len)
-{
- dSP; dTARGET;
- dPOPss;
- PUSHi(sv_len(sv));
- RETURN;
-}
-
PP(pp_rv2sv)
{
- dSP; dTOPss;
+ 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");
+ DIE("Not a SCALAR reference");
}
}
else {
- GV *gv = sv;
+ GV *gv = (GV*)sv;
+ char *sym;
+
if (SvTYPE(gv) != SVt_PVGV) {
- if (!SvOK(sv))
- DIE(no_usym, "a scalar");
- gv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvROK(sv))
+ goto wasref;
+ }
+ if (!SvOK(sv)) {
+ if (op->op_flags & OPf_REF ||
+ op->op_private & HINT_STRICT_REFS)
+ DIE(no_usym, "a SCALAR");
+ if (dowarn)
+ warn(warn_uninit);
+ RETSETUNDEF;
+ }
+ sym = SvPV(sv, na);
+ if (op->op_private & HINT_STRICT_REFS)
+ DIE(no_symref, sym, "a SCALAR");
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
}
sv = GvSV(gv);
- if (op->op_private == OP_RV2HV &&
- (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVHV)) {
- SvREFCNT_dec(sv);
- sv = NEWSV(0,0);
- sv_upgrade(sv, SVt_RV);
- SvRV(sv) = SvREFCNT_inc(newHV());
- SvROK_on(sv);
- ++sv_rvcount;
- GvSV(gv) = sv;
- }
- else if (op->op_private == OP_RV2AV &&
- (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV)) {
- SvREFCNT_dec(sv);
- sv = NEWSV(0,0);
- sv_upgrade(sv, SVt_RV);
- SvRV(sv) = SvREFCNT_inc(newAV());
- SvROK_on(sv);
- ++sv_rvcount;
- GvSV(gv) = sv;
- }
}
- if (op->op_flags & OPf_INTRO)
- SETs(save_scalar((GV*)TOPs));
- else
- SETs(sv);
+ if (op->op_flags & OPf_MOD) {
+ if (op->op_private & OPpLVAL_INTRO)
+ sv = save_scalar((GV*)TOPs);
+ else if (op->op_private & OPpDEREF)
+ vivify_ref(sv, op->op_private & OPpDEREF);
+ }
+ SETs(sv);
RETURN;
}
PP(pp_av2arylen)
{
- dSP;
+ djSP;
AV *av = (AV*)TOPs;
SV *sv = AvARYLEN(av);
if (!sv) {
RETURN;
}
+PP(pp_pos)
+{
+ djSP; dTARGET; dPOPss;
+
+ if (op->op_flags & OPf_MOD) {
+ if (SvTYPE(TARG) < SVt_PVLV) {
+ sv_upgrade(TARG, SVt_PVLV);
+ sv_magic(TARG, Nullsv, '.', Nullch, 0);
+ }
+
+ LvTYPE(TARG) = '.';
+ LvTARG(TARG) = sv;
+ 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 + curcop->cop_arybase);
+ RETURN;
+ }
+ }
+ RETPUSHUNDEF;
+ }
+}
+
PP(pp_rv2cv)
{
- dSP;
- SV *sv;
+ djSP;
GV *gv;
HV *stash;
- /* We always try to add a non-existent subroutine in case of AUTOLOAD. */
- CV *cv = sv_2cv(TOPs, &stash, &gv, TRUE);
-
+ /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
+ /* (But not in defined().) */
+ CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL));
+ if (cv) {
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ }
+ else
+ cv = (CV*)&sv_undef;
SETs((SV*)cv);
RETURN;
}
+PP(pp_prototype)
+{
+ djSP;
+ CV *cv;
+ HV *stash;
+ GV *gv;
+ SV *ret;
+
+ ret = &sv_undef;
+ cv = sv_2cv(TOPs, &stash, &gv, FALSE);
+ if (cv && SvPOK(cv))
+ ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
+ SETs(ret);
+ RETURN;
+}
+
+PP(pp_anoncode)
+{
+ djSP;
+ CV* cv = (CV*)curpad[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)
{
- dSP; dTOPss;
+ djSP; dMARK;
+ if (GIMME != G_ARRAY) {
+ MARK[1] = *SP;
+ SP = MARK + 1;
+ }
+ EXTEND_MORTAL(SP - MARK);
+ while (++MARK <= SP)
+ *MARK = refto(*MARK);
+ RETURN;
+}
+
+static SV*
+refto(SV *sv)
+{
SV* rv;
- if (!sv)
- RETSETUNDEF;
+
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
+ if (LvTARGLEN(sv))
+ vivify_defelem(sv);
+ if (!(sv = LvTARG(sv)))
+ sv = &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) = SvREFCNT_inc(sv);
+ SvRV(rv) = sv;
SvROK_on(rv);
- ++sv_rvcount;
- SETs(rv);
- RETURN;
+ return rv;
}
PP(pp_ref)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *sv;
char *pv;
- if (MAXARG < 1) {
- sv = GvSV(defgv);
- EXTEND(SP, 1);
- }
- else
- sv = POPs;
- if (!SvROK(sv))
- RETPUSHUNDEF;
+ sv = POPs;
+
+ if (sv && SvGMAGICAL(sv))
+ mg_get(sv);
+
+ if (!sv || !SvROK(sv))
+ RETPUSHNO;
sv = SvRV(sv);
- if (SvOBJECT(sv))
- pv = HvNAME(SvSTASH(sv));
- else {
- switch (SvTYPE(sv)) {
- case SVt_NULL:
- case SVt_IV:
- case SVt_NV:
- case SVt_RV:
- case SVt_PV:
- case SVt_PVIV:
- case SVt_PVNV:
- case SVt_PVMG:
- case SVt_PVBM:
- if (SvROK(sv))
- pv = "REF";
- else
- pv = "SCALAR";
- break;
- case SVt_PVLV: pv = "LVALUE"; break;
- case SVt_PVAV: pv = "ARRAY"; break;
- case SVt_PVHV: pv = "HASH"; break;
- case SVt_PVCV: pv = "CODE"; break;
- case SVt_PVGV: pv = "GLOB"; break;
- case SVt_PVFM: pv = "FORMLINE"; break;
- default: pv = "UNKNOWN"; break;
- }
- }
+ pv = sv_reftype(sv,TRUE);
PUSHp(pv, strlen(pv));
RETURN;
}
PP(pp_bless)
{
- dSP;
- register SV* ref;
- SV *sv;
+ djSP;
HV *stash;
if (MAXARG == 1)
stash = curcop->cop_stash;
else
- stash = fetch_stash(POPs, TRUE);
-
- sv = TOPs;
- if (!SvROK(sv))
- DIE("Can't bless non-reference value");
- ref = SvRV(sv);
- SvOBJECT_on(ref);
- SvUPGRADE(ref, SVt_PVMG);
- SvSTASH(ref) = (HV*)SvREFCNT_inc(stash);
+ stash = gv_stashsv(POPs, TRUE);
+
+ (void)sv_bless(TOPs, stash);
RETURN;
}
-/* Pushy I/O. */
-
-PP(pp_backtick)
+PP(pp_gelem)
{
- dSP; dTARGET;
- FILE *fp;
- char *tmps = POPp;
- TAINT_PROPER("``");
- fp = my_popen(tmps, "r");
- if (fp) {
- sv_setpv(TARG, ""); /* note that this preserves previous buffer */
- if (GIMME == G_SCALAR) {
- while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
- /*SUPPRESS 530*/
- ;
- XPUSHs(TARG);
- }
- else {
- SV *sv;
+ GV *gv;
+ SV *sv;
+ SV *ref;
+ char *elem;
+ djSP;
- for (;;) {
- sv = NEWSV(56, 80);
- if (sv_gets(sv, fp, 0) == Nullch) {
- SvREFCNT_dec(sv);
- break;
- }
- XPUSHs(sv_2mortal(sv));
- if (SvLEN(sv) - SvCUR(sv) > 20) {
- SvLEN_set(sv, SvCUR(sv)+1);
- Renew(SvPVX(sv), SvLEN(sv), char);
- }
- }
- }
- statusvalue = my_pclose(fp);
- }
- else {
- statusvalue = -1;
- if (GIMME == G_SCALAR)
- RETPUSHUNDEF;
+ sv = POPs;
+ elem = SvPV(sv, na);
+ gv = (GV*)POPs;
+ ref = Nullsv;
+ sv = Nullsv;
+ switch (elem ? *elem : '\0')
+ {
+ case 'A':
+ if (strEQ(elem, "ARRAY"))
+ ref = (SV*)GvAV(gv);
+ break;
+ case 'C':
+ if (strEQ(elem, "CODE"))
+ ref = (SV*)GvCVu(gv);
+ break;
+ case 'F':
+ if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
+ ref = (SV*)GvIOp(gv);
+ break;
+ case 'G':
+ if (strEQ(elem, "GLOB"))
+ ref = (SV*)gv;
+ break;
+ case 'H':
+ if (strEQ(elem, "HASH"))
+ ref = (SV*)GvHV(gv);
+ break;
+ case 'I':
+ if (strEQ(elem, "IO"))
+ ref = (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"))
+ ref = GvSV(gv);
+ break;
}
-
+ if (ref)
+ sv = newRV(ref);
+ if (sv)
+ sv_2mortal(sv);
+ else
+ sv = &sv_undef;
+ XPUSHs(sv);
RETURN;
}
-OP *
-do_readline()
+/* Pattern matching */
+
+PP(pp_study)
{
- dSP; dTARGETSTACKED;
- register SV *sv;
- STRLEN tmplen;
- STRLEN offset;
- FILE *fp;
- register IO *io = GvIO(last_in_gv);
- register I32 type = op->op_type;
-
- fp = Nullfp;
- if (io) {
- fp = IoIFP(io);
- if (!fp) {
- if (IoFLAGS(io) & IOf_ARGV) {
- if (IoFLAGS(io) & IOf_START) {
- IoFLAGS(io) &= ~IOf_START;
- IoLINES(io) = 0;
- if (av_len(GvAVn(last_in_gv)) < 0) {
- SV *tmpstr = newSVpv("-", 1); /* assume stdin */
- (void)av_push(GvAVn(last_in_gv), tmpstr);
- }
- }
- fp = nextargv(last_in_gv);
- if (!fp) { /* Note: fp != IoIFP(io) */
- (void)do_close(last_in_gv, FALSE); /* now it does*/
- IoFLAGS(io) |= IOf_START;
- }
- }
- else if (type == OP_GLOB) {
- SV *tmpcmd = NEWSV(55, 0);
- SV *tmpglob = POPs;
- ENTER;
- SAVEFREESV(tmpcmd);
-#ifdef DOSISH
- sv_setpv(tmpcmd, "perlglob ");
- sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, " |");
-#else
-#ifdef CSH
- sv_setpvn(tmpcmd, cshname, cshlen);
- sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
- sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, "'|");
-#else
- sv_setpv(tmpcmd, "echo ");
- sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
-#endif /* !CSH */
-#endif /* !MSDOS */
- (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd));
- fp = IoIFP(io);
- LEAVE;
- }
- }
- else if (type == OP_GLOB)
- SP--;
- }
- if (!fp) {
- if (dowarn)
- warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
- if (GIMME == G_SCALAR)
- RETPUSHUNDEF;
- RETURN;
+ 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(unop->op_first && unop->op_first->op_type == OP_PUSHRE) {
+ PMOP *pm = (PMOP *)unop->op_first;
+ SV *rv = sv_newmortal();
+ sv = newSVrv(rv, "Regexp");
+ sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
+ RETURNX(PUSHs(rv));
}
- if (GIMME == G_ARRAY) {
- sv = sv_2mortal(NEWSV(57, 80));
- offset = 0;
+
+ if (sv == lastscream) {
+ if (SvSCREAM(sv))
+ RETPUSHYES;
}
else {
- sv = TARG;
- SvUPGRADE(sv, SVt_PV);
- tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen)
- Sv_Grow(sv, 80); /* try short-buffering it */
- if (type == OP_RCATLINE)
- offset = SvCUR(sv);
- else
- offset = 0;
- }
- for (;;) {
- if (!sv_gets(sv, fp, offset)) {
- clearerr(fp);
- if (IoFLAGS(io) & IOf_ARGV) {
- fp = nextargv(last_in_gv);
- if (fp)
- continue;
- (void)do_close(last_in_gv, FALSE);
- IoFLAGS(io) |= IOf_START;
- }
- else if (type == OP_GLOB) {
- (void)do_close(last_in_gv, FALSE);
- }
- if (GIMME == G_SCALAR)
- RETPUSHUNDEF;
- RETURN;
+ if (lastscream) {
+ SvSCREAM_off(lastscream);
+ SvREFCNT_dec(lastscream);
}
- IoLINES(io)++;
- XPUSHs(sv);
- if (tainting) {
- tainted = TRUE;
- SvTAINT(sv); /* Anything from the outside world...*/
- }
- if (type == OP_GLOB) {
- char *tmps;
+ lastscream = SvREFCNT_inc(sv);
+ }
- if (SvCUR(sv) > 0)
- SvCUR(sv)--;
- if (*SvEND(sv) == rschar)
- *SvEND(sv) = '\0';
- else
- SvCUR(sv)++;
- for (tmps = SvPVX(sv); *tmps; tmps++)
- if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
- strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
- break;
- if (*tmps && stat(SvPVX(sv), &statbuf) < 0) {
- POPs; /* Unmatched wildcard? Chuck it... */
- continue;
- }
- }
- if (GIMME == G_ARRAY) {
- if (SvLEN(sv) - SvCUR(sv) > 20) {
- SvLEN_set(sv, SvCUR(sv)+1);
- Renew(SvPVX(sv), SvLEN(sv), char);
- }
- sv = sv_2mortal(NEWSV(58, 80));
- continue;
- }
- else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
- /* try to reclaim a bit of scalar space (only on 1st alloc) */
- if (SvCUR(sv) < 60)
- SvLEN_set(sv, 80);
- else
- SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
- Renew(SvPVX(sv), SvLEN(sv), char);
- }
- RETURN;
- }
-}
-
-PP(pp_glob)
-{
- OP *result;
- ENTER;
- SAVEINT(rschar);
- SAVEINT(rslen);
-
- SAVESPTR(last_in_gv); /* We don't want this to be permanent. */
- last_in_gv = (GV*)*stack_sp--;
-
- rslen = 1;
-#ifdef DOSISH
- rschar = 0;
-#else
-#ifdef CSH
- rschar = 0;
-#else
- rschar = '\n';
-#endif /* !CSH */
-#endif /* !MSDOS */
- result = do_readline();
- LEAVE;
- return result;
-}
-
-PP(pp_readline)
-{
- last_in_gv = (GV*)(*stack_sp--);
- return do_readline();
-}
-
-PP(pp_indread)
-{
- last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*stack_sp--)), na), TRUE);
- return do_readline();
-}
-
-PP(pp_rcatline)
-{
- last_in_gv = cGVOP->op_gv;
- return do_readline();
-}
-
-PP(pp_regcmaybe)
-{
- return NORMAL;
-}
-
-PP(pp_regcomp) {
- dSP;
- register PMOP *pm = (PMOP*)cLOGOP->op_other;
- register char *t;
- I32 global;
- SV *tmpstr;
- register REGEXP *rx = pm->op_pmregexp;
- STRLEN len;
-
- global = pm->op_pmflags & PMf_GLOBAL;
- tmpstr = POPs;
- t = SvPV(tmpstr, len);
- if (!global && rx)
- regfree(rx);
- pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
- pm->op_pmregexp = regcomp(t, t + len,
- pm->op_pmflags & PMf_FOLD);
- if (!pm->op_pmregexp->prelen && curpm)
- pm = curpm;
- if (pm->op_pmflags & PMf_KEEP) {
- if (!(pm->op_pmflags & PMf_FOLD))
- scan_prefix(pm, pm->op_pmregexp->precomp,
- pm->op_pmregexp->prelen);
- pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */
- hoistmust(pm);
- cLOGOP->op_first->op_next = op->op_next;
- /* XXX delete push code */
- }
- RETURN;
-}
-
-PP(pp_match)
-{
- dSP; dTARG;
- register PMOP *pm = cPMOP;
- register char *t;
- register char *s;
- char *strend;
- SV *tmpstr;
- I32 global;
- I32 safebase;
- char *truebase;
- register REGEXP *rx = pm->op_pmregexp;
- I32 gimme = GIMME;
- STRLEN len;
-
- if (op->op_flags & OPf_STACKED)
- TARG = POPs;
- else {
- TARG = GvSV(defgv);
- EXTEND(SP,1);
- }
- s = SvPV(TARG, len);
- strend = s + len;
- if (!s)
- DIE("panic: do_match");
-
- if (pm->op_pmflags & PMf_USED) {
- if (gimme == G_ARRAY)
- RETURN;
+ s = (unsigned char*)(SvPV(sv, len));
+ pos = len;
+ if (pos <= 0)
RETPUSHNO;
- }
-
- if (!rx->prelen && curpm) {
- pm = curpm;
- rx = pm->op_pmregexp;
- }
- truebase = t = s;
- if (global = pm->op_pmflags & PMf_GLOBAL) {
- rx->startp[0] = 0;
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
- MAGIC* mg = mg_find(TARG, 'g');
- if (mg && mg->mg_ptr) {
- rx->startp[0] = mg->mg_ptr;
- rx->endp[0] = mg->mg_ptr + mg->mg_len;
- }
- }
- }
- safebase = (gimme == G_ARRAY) || global;
-
-play_it_again:
- if (global && rx->startp[0]) {
- t = s = rx->endp[0];
- if (s == rx->startp[0])
- s++, t++;
- if (s > strend)
- goto nope;
- }
- if (pm->op_pmshort) {
- if (pm->op_pmflags & PMf_SCANFIRST) {
- if (SvSCREAM(TARG)) {
- if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
- goto nope;
- else if (!(s = screaminstr(TARG, pm->op_pmshort)))
- goto nope;
- else if (pm->op_pmflags & PMf_ALL)
- goto yup;
- }
- else if (!(s = fbm_instr((unsigned char*)s,
- (unsigned char*)strend, pm->op_pmshort)))
- goto nope;
- else if (pm->op_pmflags & PMf_ALL)
- goto yup;
- if (s && rx->regback >= 0) {
- ++BmUSEFUL(pm->op_pmshort);
- s -= rx->regback;
- if (s < t)
- s = t;
- }
- else
- s = t;
- }
- else if (!multiline) {
- if (*SvPVX(pm->op_pmshort) != *s ||
- bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
- if (pm->op_pmflags & PMf_FOLD) {
- if (ibcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) )
- goto nope;
- }
- else
- goto nope;
- }
- }
- if (--BmUSEFUL(pm->op_pmshort) < 0) {
- SvREFCNT_dec(pm->op_pmshort);
- pm->op_pmshort = Nullsv; /* opt is being useless */
- }
- }
- if (!rx->nparens && !global) {
- gimme = G_SCALAR; /* accidental array context? */
- safebase = FALSE;
- }
- if (regexec(rx, s, strend, truebase, 0,
- SvSCREAM(TARG) ? TARG : Nullsv,
- safebase)) {
- curpm = pm;
- if (pm->op_pmflags & PMf_ONCE)
- pm->op_pmflags |= PMf_USED;
- goto gotcha;
- }
- else
- goto ret_no;
- /*NOTREACHED*/
-
- gotcha:
- if (gimme == G_ARRAY) {
- I32 iters, i, len;
-
- iters = rx->nparens;
- if (global && !iters)
- i = 1;
- else
- i = 0;
- EXTEND(SP, iters + i);
- for (i = !i; i <= iters; i++) {
- PUSHs(sv_newmortal());
- /*SUPPRESS 560*/
- if (s = rx->startp[i]) {
- len = rx->endp[i] - s;
- if (len > 0)
- sv_setpvn(*SP, s, len);
- }
- }
- if (global) {
- truebase = rx->subbeg;
- goto play_it_again;
- }
- RETURN;
- }
- else {
- if (global) {
- MAGIC* mg = 0;
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
- mg = mg_find(TARG, 'g');
- if (!mg) {
- sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
- mg = mg_find(TARG, 'g');
- }
- mg->mg_ptr = rx->startp[0];
- mg->mg_len = rx->endp[0] - rx->startp[0];
+ if (pos > maxscream) {
+ if (maxscream < 0) {
+ maxscream = pos + 80;
+ New(301, screamfirst, 256, I32);
+ New(302, screamnext, maxscream, I32);
}
- RETPUSHYES;
- }
-
-yup:
- ++BmUSEFUL(pm->op_pmshort);
- curpm = pm;
- if (pm->op_pmflags & PMf_ONCE)
- pm->op_pmflags |= PMf_USED;
- if (global) {
- rx->subbeg = truebase;
- rx->subend = strend;
- rx->startp[0] = s;
- rx->endp[0] = s + SvCUR(pm->op_pmshort);
- goto gotcha;
- }
- if (sawampersand) {
- char *tmps;
-
- if (rx->subbase)
- Safefree(rx->subbase);
- tmps = rx->subbase = nsavestr(t, strend-t);
- rx->subbeg = tmps;
- rx->subend = tmps + (strend-t);
- tmps = rx->startp[0] = tmps + (s - t);
- rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
- }
- RETPUSHYES;
-
-nope:
- if (pm->op_pmshort)
- ++BmUSEFUL(pm->op_pmshort);
-
-ret_no:
- if (global) {
- if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
- MAGIC* mg = mg_find(TARG, 'g');
- if (mg) {
- mg->mg_ptr = 0;
- mg->mg_len = 0;
- }
+ else {
+ maxscream = pos + pos / 4;
+ Renew(screamnext, maxscream, I32);
}
}
- if (gimme == G_ARRAY)
- RETURN;
- RETPUSHNO;
-}
-PP(pp_subst)
-{
- dSP; dTARG;
- register PMOP *pm = cPMOP;
- PMOP *rpm = pm;
- register SV *dstr;
- register char *s;
- char *strend;
- register char *m;
- char *c;
- register char *d;
- STRLEN clen;
- I32 iters = 0;
- I32 maxiters;
- register I32 i;
- bool once;
- char *orig;
- I32 safebase;
- register REGEXP *rx = pm->op_pmregexp;
- STRLEN len;
+ sfirst = screamfirst;
+ snext = screamnext;
- if (pm->op_pmflags & PMf_CONST) /* known replacement string? */
- dstr = POPs;
- if (op->op_flags & OPf_STACKED)
- TARG = POPs;
- else {
- TARG = GvSV(defgv);
- EXTEND(SP,1);
- }
- s = SvPV(TARG, len);
- if (!pm || !s)
- DIE("panic: do_subst");
-
- strend = s + len;
- maxiters = (strend - s) + 10;
-
- if (!rx->prelen && curpm) {
- pm = curpm;
- rx = pm->op_pmregexp;
- }
- safebase = ((!rx || !rx->nparens) && !sawampersand);
- orig = m = s;
- if (pm->op_pmshort) {
- if (pm->op_pmflags & PMf_SCANFIRST) {
- if (SvSCREAM(TARG)) {
- if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
- goto nope;
- else if (!(s = screaminstr(TARG, pm->op_pmshort)))
- goto nope;
- }
- else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
- pm->op_pmshort)))
- goto nope;
- if (s && rx->regback >= 0) {
- ++BmUSEFUL(pm->op_pmshort);
- s -= rx->regback;
- if (s < m)
- s = m;
- }
- else
- s = m;
- }
- else if (!multiline) {
- if (*SvPVX(pm->op_pmshort) != *s ||
- bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
- if (pm->op_pmflags & PMf_FOLD) {
- if (ibcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) )
- goto nope;
- }
- else
- goto nope;
- }
- }
- if (--BmUSEFUL(pm->op_pmshort) < 0) {
- SvREFCNT_dec(pm->op_pmshort);
- pm->op_pmshort = Nullsv; /* opt is being useless */
- }
- }
- once = !(rpm->op_pmflags & PMf_GLOBAL);
- if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */
- c = SvPV(dstr, clen);
- if (clen <= rx->minlen) {
- /* can do inplace substitution */
- if (regexec(rx, s, strend, orig, 0,
- SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
- if (rx->subbase) /* oops, no we can't */
- goto long_way;
- d = s;
- curpm = pm;
- SvSCREAM_off(TARG); /* disable possible screamer */
- if (once) {
- m = rx->startp[0];
- d = rx->endp[0];
- s = orig;
- if (m - s > strend - d) { /* faster to shorten from end */
- if (clen) {
- Copy(c, m, clen, char);
- m += clen;
- }
- i = strend - d;
- if (i > 0) {
- Move(d, m, i, char);
- m += i;
- }
- *m = '\0';
- SvCUR_set(TARG, m - s);
- SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(&sv_yes);
- RETURN;
- }
- /*SUPPRESS 560*/
- else if (i = m - s) { /* faster from front */
- d -= clen;
- m = d;
- sv_chop(TARG, d-i);
- s += i;
- while (i--)
- *--d = *--s;
- if (clen)
- Copy(c, m, clen, char);
- SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(&sv_yes);
- RETURN;
- }
- else if (clen) {
- d -= clen;
- sv_chop(TARG, d);
- Copy(c, d, clen, char);
- SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(&sv_yes);
- RETURN;
- }
- else {
- sv_chop(TARG, d);
- SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(&sv_yes);
- RETURN;
- }
- /* NOTREACHED */
- }
- do {
- if (iters++ > maxiters)
- DIE("Substitution loop");
- m = rx->startp[0];
- /*SUPPRESS 560*/
- if (i = m - s) {
- if (s != d)
- Move(s, d, i, char);
- d += i;
- }
- if (clen) {
- Copy(c, d, clen, char);
- d += clen;
- }
- s = rx->endp[0];
- } while (regexec(rx, s, strend, orig, s == m,
- Nullsv, TRUE)); /* (don't match same null twice) */
- if (s != d) {
- i = strend - s;
- SvCUR_set(TARG, d - SvPVX(TARG) + i);
- Move(s, d, i+1, char); /* include the Null */
- }
- SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(sv_2mortal(newSViv((I32)iters)));
- RETURN;
- }
- PUSHs(&sv_no);
- RETURN;
- }
- }
- else
- c = Nullch;
- if (regexec(rx, s, strend, orig, 0,
- SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
- long_way:
- dstr = NEWSV(25, sv_len(TARG));
- sv_setpvn(dstr, m, s-m);
- curpm = pm;
- if (!c) {
- register CONTEXT *cx;
- PUSHSUBST(cx);
- RETURNOP(cPMOP->op_pmreplroot);
- }
- do {
- if (iters++ > maxiters)
- DIE("Substitution loop");
- 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];
- sv_catpvn(dstr, s, m-s);
- s = rx->endp[0];
- if (clen)
- sv_catpvn(dstr, c, clen);
- if (once)
- break;
- } while (regexec(rx, s, strend, orig, s == m, Nullsv,
- safebase));
- sv_catpvn(dstr, s, strend - s);
- sv_replace(TARG, dstr);
- SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(sv_2mortal(newSViv((I32)iters)));
- RETURN;
- }
- PUSHs(&sv_no);
- RETURN;
+ if (!sfirst || !snext)
+ DIE("do_study: out of memory");
-nope:
- ++BmUSEFUL(pm->op_pmshort);
- PUSHs(&sv_no);
- RETURN;
-}
+ for (ch = 256; ch; --ch)
+ *sfirst++ = -1;
+ sfirst -= 256;
-PP(pp_substcont)
-{
- dSP;
- register PMOP *pm = (PMOP*) cLOGOP->op_other;
- register CONTEXT *cx = &cxstack[cxstack_ix];
- register SV *dstr = cx->sb_dstr;
- register char *s = cx->sb_s;
- register char *m = cx->sb_m;
- char *orig = cx->sb_orig;
- register REGEXP *rx = pm->op_pmregexp;
-
- if (cx->sb_iters++) {
- if (cx->sb_iters > cx->sb_maxiters)
- DIE("Substitution loop");
-
- sv_catsv(dstr, POPs);
- if (rx->subbase)
- Safefree(rx->subbase);
- rx->subbase = cx->sb_subbase;
-
- /* Are we done */
- if (cx->sb_once || !regexec(rx, s, cx->sb_strend, orig,
- s == m, Nullsv, cx->sb_safebase))
- {
- SV *targ = cx->sb_targ;
- sv_catpvn(dstr, s, cx->sb_strend - s);
- sv_replace(targ, dstr);
- SvPOK_only(targ);
- SvSETMAGIC(targ);
- PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
- POPSUBST(cx);
- RETURNOP(pm->op_next);
- }
- }
- if (rx->subbase && rx->subbase != orig) {
- m = s;
- s = orig;
- cx->sb_orig = orig = rx->subbase;
- s = orig + (m - s);
- cx->sb_strend = s + (cx->sb_strend - m);
+ while (--pos >= 0) {
+ ch = s[pos];
+ if (sfirst[ch] >= 0)
+ snext[pos] = sfirst[ch] - pos;
+ else
+ snext[pos] = -pos;
+ sfirst[ch] = pos;
}
- cx->sb_m = m = rx->startp[0];
- sv_catpvn(dstr, s, m-s);
- cx->sb_s = rx->endp[0];
- cx->sb_subbase = rx->subbase;
- rx->subbase = Nullch; /* so recursion works */
- RETURNOP(pm->op_pmreplstart);
+ SvSCREAM_on(sv);
+ sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
+ RETPUSHYES;
}
PP(pp_trans)
{
- dSP; dTARG;
+ djSP; dTARG;
SV *sv;
if (op->op_flags & OPf_STACKED)
sv = POPs;
else {
- sv = GvSV(defgv);
+ sv = DEFSV;
EXTEND(SP,1);
}
- TARG = NEWSV(27,0);
+ TARG = sv_newmortal();
PUSHi(do_trans(sv, op));
RETURN;
}
/* Lvalue operators. */
-PP(pp_sassign)
+PP(pp_schop)
{
- dSP; dPOPTOPssrl;
- if (tainting && tainted && (!SvRMAGICAL(lstr) || !mg_find(lstr, 't'))) {
- TAINT_NOT;
- }
- SvSetSV(rstr, lstr);
- SvSETMAGIC(rstr);
- SETs(rstr);
+ djSP; dTARGET;
+ do_chop(TARG, TOPs);
+ SETTARG;
RETURN;
}
-PP(pp_aassign)
+PP(pp_chop)
{
- dSP;
- SV **lastlelem = stack_sp;
- SV **lastrelem = stack_base + POPMARK;
- SV **firstrelem = stack_base + POPMARK + 1;
- SV **firstlelem = lastrelem + 1;
-
- register SV **relem;
- register SV **lelem;
-
- register SV *sv;
- register AV *ary;
-
- HV *hash;
- I32 i;
- int magic;
-
- delaymagic = DM_DELAY; /* catch simultaneous items */
-
- /* If there's a common identifier on both sides we have to take
- * special care that assigning the identifier on the left doesn't
- * clobber a value on the right that's used later in the list.
- */
- if (op->op_private & OPpASSIGN_COMMON) {
- for (relem = firstrelem; relem <= lastrelem; relem++) {
- /*SUPPRESS 560*/
- if (sv = *relem)
- *relem = sv_mortalcopy(sv);
- }
- }
-
- relem = firstrelem;
- lelem = firstlelem;
- ary = Null(AV*);
- hash = Null(HV*);
- while (lelem <= lastlelem) {
- sv = *lelem++;
- switch (SvTYPE(sv)) {
- case SVt_PVAV:
- ary = (AV*)sv;
- magic = SvSMAGICAL(ary) != 0;
- AvREAL_on(ary);
- AvFILL(ary) = -1;
- i = 0;
- while (relem <= lastrelem) { /* gobble up all the rest */
- sv = NEWSV(28,0);
- if (*relem)
- sv_setsv(sv,*relem);
- *(relem++) = sv;
- (void)av_store(ary,i++,sv);
- if (magic)
- mg_set(sv);
- }
- break;
- case SVt_PVHV: {
- char *tmps;
- SV *tmpstr;
-
- hash = (HV*)sv;
- magic = SvSMAGICAL(hash) != 0;
- hv_clear(hash);
-
- while (relem < lastrelem) { /* gobble up all the rest */
- STRLEN len;
- if (*relem)
- sv = *(relem++);
- else
- sv = &sv_no, relem++;
- tmps = SvPV(sv, len);
- tmpstr = NEWSV(29,0);
- if (*relem)
- sv_setsv(tmpstr,*relem); /* value */
- *(relem++) = tmpstr;
- (void)hv_store(hash,tmps,len,tmpstr,0);
- if (magic)
- mg_set(tmpstr);
- }
- }
- break;
- default:
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling) {
- if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
- DIE(no_modify);
- if (relem <= lastrelem)
- relem++;
- }
- if (SvROK(sv))
- sv_unref(sv);
- break;
- }
- if (relem <= lastrelem) {
- sv_setsv(sv, *relem);
- *(relem++) = sv;
- }
- else
- sv_setsv(sv, &sv_undef);
- SvSETMAGIC(sv);
- break;
- }
- }
- if (delaymagic & ~DM_DELAY) {
- if (delaymagic & DM_UID) {
-#ifdef HAS_SETREUID
- (void)setreuid(uid,euid);
-#else /* not HAS_SETREUID */
-#ifdef HAS_SETRUID
- if ((delaymagic & DM_UID) == DM_RUID) {
- (void)setruid(uid);
- delaymagic =~ DM_RUID;
- }
-#endif /* HAS_SETRUID */
-#ifdef HAS_SETEUID
- if ((delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(uid);
- delaymagic =~ DM_EUID;
- }
-#endif /* HAS_SETEUID */
- if (delaymagic & DM_UID) {
- if (uid != euid)
- DIE("No setreuid available");
- (void)setuid(uid);
- }
-#endif /* not HAS_SETREUID */
- uid = (int)getuid();
- euid = (int)geteuid();
- }
- if (delaymagic & DM_GID) {
-#ifdef HAS_SETREGID
- (void)setregid(gid,egid);
-#else /* not HAS_SETREGID */
-#ifdef HAS_SETRGID
- if ((delaymagic & DM_GID) == DM_RGID) {
- (void)setrgid(gid);
- delaymagic =~ DM_RGID;
- }
-#endif /* HAS_SETRGID */
-#ifdef HAS_SETEGID
- if ((delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(gid);
- delaymagic =~ DM_EGID;
- }
-#endif /* HAS_SETEGID */
- if (delaymagic & DM_GID) {
- if (gid != egid)
- DIE("No setregid available");
- (void)setgid(gid);
- }
-#endif /* not HAS_SETREGID */
- gid = (int)getgid();
- egid = (int)getegid();
- }
- tainting |= (euid != uid || egid != gid);
- }
- delaymagic = 0;
- if (GIMME == G_ARRAY) {
- if (ary || hash)
- SP = lastrelem;
- else
- SP = firstrelem + (lastlelem - firstlelem);
- RETURN;
- }
- else {
- dTARGET;
- SP = firstrelem;
- SETi(lastrelem - firstrelem + 1);
- RETURN;
- }
+ djSP; dMARK; dTARGET;
+ while (SP > MARK)
+ do_chop(TARG, POPs);
+ PUSHTARG;
+ RETURN;
}
-PP(pp_schop)
+PP(pp_schomp)
{
- dSP; dTARGET;
- SV *sv;
-
- if (MAXARG < 1)
- sv = GvSV(defgv);
- else
- sv = POPs;
- do_chop(TARG, sv);
- PUSHTARG;
+ djSP; dTARGET;
+ SETi(do_chomp(TOPs));
RETURN;
}
-PP(pp_chop)
+PP(pp_chomp)
{
- dSP; dMARK; dTARGET;
+ djSP; dMARK; dTARGET;
+ register I32 count = 0;
+
while (SP > MARK)
- do_chop(TARG, POPs);
- PUSHTARG;
+ count += do_chomp(POPs);
+ PUSHi(count);
RETURN;
}
PP(pp_defined)
{
- dSP;
+ djSP;
register SV* sv;
- if (MAXARG < 1) {
- sv = GvSV(defgv);
- EXTEND(SP, 1);
- }
- else
- sv = POPs;
+ sv = POPs;
if (!sv || !SvANY(sv))
RETPUSHNO;
switch (SvTYPE(sv)) {
case SVt_PVAV:
- if (AvMAX(sv) >= 0)
+ if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
RETPUSHYES;
break;
case SVt_PVHV:
- if (HvARRAY(sv))
+ if (HvARRAY(sv) || SvGMAGICAL(sv))
RETPUSHYES;
break;
case SVt_PVCV:
- if (CvROOT(sv))
+ if (CvROOT(sv) || CvXSUB(sv))
RETPUSHYES;
break;
default:
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
if (SvOK(sv))
RETPUSHYES;
}
PP(pp_undef)
{
- dSP;
+ djSP;
SV *sv;
- if (!op->op_private)
+ if (!op->op_private) {
+ EXTEND(SP, 1);
RETPUSHUNDEF;
+ }
sv = POPs;
if (!sv)
hv_undef((HV*)sv);
break;
case SVt_PVCV:
- sub_generation++;
- cv_clear((CV*)sv);
+ if (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))
+ sv_setsv(sv, &sv_undef);
break;
default:
- if (sv != GvSV(defgv)) {
- if (SvPOK(sv) && SvLEN(sv)) {
- SvOOK_off(sv);
- Safefree(SvPVX(sv));
- SvPV_set(sv, Nullch);
- SvLEN_set(sv, 0);
- }
- SvOK_off(sv);
- SvSETMAGIC(sv);
+ 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_study)
+PP(pp_predec)
{
- dSP; dTARGET;
- register unsigned char *s;
- register I32 pos;
- register I32 ch;
- register I32 *sfirst;
- register I32 *snext;
- I32 retval;
- STRLEN len;
-
- s = (unsigned char*)(SvPV(TARG, len));
- pos = len;
- if (lastscream)
- SvSCREAM_off(lastscream);
- lastscream = TARG;
- if (pos <= 0) {
- retval = 0;
- goto ret;
+ 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);
}
- if (pos > maxscream) {
- if (maxscream < 0) {
- maxscream = pos + 80;
- New(301, screamfirst, 256, I32);
- New(302, screamnext, maxscream, I32);
- }
- else {
- maxscream = pos + pos / 4;
- Renew(screamnext, maxscream, I32);
- }
- }
-
- sfirst = screamfirst;
- snext = 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;
-
- /* If there were any case insensitive searches, we must assume they
- * all are. This speeds up insensitive searches much more than
- * it slows down sensitive ones.
- */
- if (sawi)
- sfirst[fold[ch]] = pos;
- }
-
- SvSCREAM_on(TARG);
- retval = 1;
- ret:
- XPUSHs(sv_2mortal(newSViv((I32)retval)));
- RETURN;
-}
-
-PP(pp_preinc)
-{
- dSP;
- sv_inc(TOPs);
- SvSETMAGIC(TOPs);
- return NORMAL;
-}
-
-PP(pp_predec)
-{
- dSP;
- sv_dec(TOPs);
+ else
+ sv_dec(TOPs);
SvSETMAGIC(TOPs);
return NORMAL;
}
PP(pp_postinc)
{
- dSP; dTARGET;
+ djSP; dTARGET;
+ if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ croak(no_modify);
sv_setsv(TARG, TOPs);
- sv_inc(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);
PP(pp_postdec)
{
- dSP; dTARGET;
+ djSP; dTARGET;
+ if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ croak(no_modify);
sv_setsv(TARG, TOPs);
- sv_dec(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;
PP(pp_pow)
{
- dSP; dATARGET; dPOPTOPnnrl;
- SETn( pow( left, right) );
- RETURN;
+ djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
+ {
+ dPOPTOPnnrl;
+ SETn( pow( left, right) );
+ RETURN;
+ }
}
PP(pp_multiply)
{
- dSP; dATARGET; dPOPTOPnnrl;
- SETn( left * right );
- RETURN;
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ {
+ dPOPTOPnnrl;
+ SETn( left * right );
+ RETURN;
+ }
}
PP(pp_divide)
{
- dSP; dATARGET; dPOPnv;
- if (value == 0.0)
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ {
+ dPOPPOPnnrl;
+ double value;
+ if (right == 0.0)
DIE("Illegal division by zero");
#ifdef SLOPPYDIVIDE
- /* insure that 20./5. == 4. */
- {
- double x;
- I32 k;
- x = POPn;
- if ((double)(I32)x == x &&
- (double)(I32)value == value &&
- (k = (I32)x/(I32)value)*(I32)value == (I32)x) {
+ /* 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 = x/value;
+ value = left / right;
}
- }
+ }
#else
- value = POPn / value;
+ value = left / right;
#endif
- PUSHn( value );
- RETURN;
+ PUSHn( value );
+ RETURN;
+ }
}
PP(pp_modulo)
{
- dSP; dATARGET;
- register unsigned long tmpulong;
- register long tmplong;
- I32 value;
-
- tmpulong = (unsigned long) POPn;
- if (tmpulong == 0L)
+ djSP; dATARGET; tryAMAGICbin(mod,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");
- value = TOPn;
- if (value >= 0.0)
- value = (I32)(((unsigned long)value) % tmpulong);
- else {
- tmplong = (long)value;
- value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
+
+ 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;
}
- SETi(value);
- RETURN;
}
PP(pp_repeat)
{
- dSP; dATARGET;
+ djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
+ {
register I32 count = POPi;
if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
dMARK;
MARK++;
repeatcpy((char*)(MARK + items), (char*)MARK,
items * sizeof(SV*), count - 1);
+ SP += max;
}
- SP += max;
+ else if (count <= 0)
+ SP -= items;
}
else { /* Note: mark already snarfed by pp_list */
SV *tmpstr;
- char *tmps;
+ STRLEN len;
tmpstr = POPs;
if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
sv_unref(tmpstr);
}
SvSetSV(TARG, tmpstr);
- if (count >= 1) {
- STRLEN len;
- STRLEN tlen;
- tmpstr = NEWSV(50, 0);
- tmps = SvPV(TARG, len);
- sv_setpvn(tmpstr, tmps, len);
- tmps = SvPV(tmpstr, tlen); /* force to be string */
- SvGROW(TARG, (count * len) + 1);
- repeatcpy((char*)SvPVX(TARG), tmps, tlen, count);
- SvCUR(TARG) *= count;
+ 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';
- SvPOK_only(TARG);
- SvREFCNT_dec(tmpstr);
}
- else
- sv_setsv(TARG, &sv_no);
+ (void)SvPOK_only(TARG);
PUSHTARG;
}
RETURN;
-}
-
-PP(pp_add)
-{
- dSP; dATARGET; dPOPTOPnnrl;
- SETn( left + right );
- RETURN;
-}
-
-PP(pp_intadd)
-{
- dSP; dATARGET; dPOPTOPiirl;
- SETi( left + right );
- RETURN;
+ }
}
PP(pp_subtract)
{
- dSP; dATARGET; dPOPTOPnnrl;
- SETn( left - right );
- RETURN;
-}
-
-PP(pp_concat)
-{
- dSP; dATARGET; dPOPTOPssrl;
- SvSetSV(TARG, lstr);
- sv_catsv(TARG, rstr);
- SETTARG;
- RETURN;
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ {
+ dPOPTOPnnrl_ul;
+ SETn( left - right );
+ RETURN;
+ }
}
PP(pp_left_shift)
{
- dSP; dATARGET;
- I32 anum = POPi;
- double value = TOPn;
- SETi( U_L(value) << anum );
- RETURN;
+ djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
+ {
+ IBW shift = POPi;
+ if (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)
{
- dSP; dATARGET;
- I32 anum = POPi;
- double value = TOPn;
- SETi( U_L(value) >> anum );
- RETURN;
+ djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+ {
+ IBW shift = POPi;
+ if (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)
{
- dSP; dPOPnv;
- SETs((TOPn < value) ? &sv_yes : &sv_no);
- RETURN;
+ djSP; tryAMAGICbinSET(lt,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn < value));
+ RETURN;
+ }
}
PP(pp_gt)
{
- dSP; dPOPnv;
- SETs((TOPn > value) ? &sv_yes : &sv_no);
- RETURN;
+ djSP; tryAMAGICbinSET(gt,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn > value));
+ RETURN;
+ }
}
PP(pp_le)
{
- dSP; dPOPnv;
- SETs((TOPn <= value) ? &sv_yes : &sv_no);
- RETURN;
+ djSP; tryAMAGICbinSET(le,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn <= value));
+ RETURN;
+ }
}
PP(pp_ge)
{
- dSP; dPOPnv;
- SETs((TOPn >= value) ? &sv_yes : &sv_no);
- RETURN;
-}
-
-PP(pp_eq)
-{
- dSP; dPOPnv;
- SETs((TOPn == value) ? &sv_yes : &sv_no);
- RETURN;
+ djSP; tryAMAGICbinSET(ge,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn >= value));
+ RETURN;
+ }
}
PP(pp_ne)
{
- dSP; dPOPnv;
- SETs((TOPn != value) ? &sv_yes : &sv_no);
- RETURN;
+ djSP; tryAMAGICbinSET(ne,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn != value));
+ RETURN;
+ }
}
PP(pp_ncmp)
{
- dSP; dTARGET; dPOPTOPnnrl;
- I32 value;
+ djSP; dTARGET; tryAMAGICbin(ncmp,0);
+ {
+ dPOPTOPnnrl;
+ I32 value;
- if (left > right)
- value = 1;
- else if (left < right)
- value = -1;
- else
+ if (left == right)
value = 0;
- SETi(value);
- RETURN;
+ else if (left < right)
+ value = -1;
+ else if (left > right)
+ value = 1;
+ else {
+ SETs(&sv_undef);
+ RETURN;
+ }
+ SETi(value);
+ RETURN;
+ }
}
PP(pp_slt)
{
- dSP; dPOPTOPssrl;
- SETs( sv_cmp(lstr, rstr) < 0 ? &sv_yes : &sv_no );
- RETURN;
+ djSP; tryAMAGICbinSET(slt,0);
+ {
+ dPOPTOPssrl;
+ int cmp = ((op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp < 0));
+ RETURN;
+ }
}
PP(pp_sgt)
{
- dSP; dPOPTOPssrl;
- SETs( sv_cmp(lstr, rstr) > 0 ? &sv_yes : &sv_no );
- RETURN;
+ djSP; tryAMAGICbinSET(sgt,0);
+ {
+ dPOPTOPssrl;
+ int cmp = ((op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp > 0));
+ RETURN;
+ }
}
PP(pp_sle)
{
- dSP; dPOPTOPssrl;
- SETs( sv_cmp(lstr, rstr) <= 0 ? &sv_yes : &sv_no );
- RETURN;
+ djSP; tryAMAGICbinSET(sle,0);
+ {
+ dPOPTOPssrl;
+ int cmp = ((op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp <= 0));
+ RETURN;
+ }
}
PP(pp_sge)
{
- dSP; dPOPTOPssrl;
- SETs( sv_cmp(lstr, rstr) >= 0 ? &sv_yes : &sv_no );
- RETURN;
+ djSP; tryAMAGICbinSET(sge,0);
+ {
+ dPOPTOPssrl;
+ int cmp = ((op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp >= 0));
+ RETURN;
+ }
}
PP(pp_seq)
{
- dSP; dPOPTOPssrl;
- SETs( sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
- RETURN;
+ djSP; tryAMAGICbinSET(seq,0);
+ {
+ dPOPTOPssrl;
+ SETs(boolSV(sv_eq(left, right)));
+ RETURN;
+ }
}
PP(pp_sne)
{
- dSP; dPOPTOPssrl;
- SETs( !sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
- RETURN;
+ djSP; tryAMAGICbinSET(sne,0);
+ {
+ dPOPTOPssrl;
+ SETs(boolSV(!sv_eq(left, right)));
+ RETURN;
+ }
}
PP(pp_scmp)
{
- dSP; dTARGET;
- dPOPTOPssrl;
- SETi( sv_cmp(lstr, rstr) );
- RETURN;
+ djSP; dTARGET; tryAMAGICbin(scmp,0);
+ {
+ dPOPTOPssrl;
+ int cmp = ((op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETi( cmp );
+ RETURN;
+ }
}
PP(pp_bit_and)
{
- dSP; dATARGET; dPOPTOPssrl;
- if (SvNIOK(lstr) || SvNIOK(rstr)) {
- I32 value = SvIV(lstr);
- value = value & SvIV(rstr);
- SETi(value);
- }
- else {
- do_vop(op->op_type, TARG, lstr, rstr);
+ djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
+ {
+ dPOPTOPssrl;
+ if (SvNIOKp(left) || SvNIOKp(right)) {
+ if (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(op->op_type, TARG, left, right);
SETTARG;
+ }
+ RETURN;
}
- RETURN;
}
-PP(pp_xor)
+PP(pp_bit_xor)
{
- dSP; dATARGET; dPOPTOPssrl;
- if (SvNIOK(lstr) || SvNIOK(rstr)) {
- I32 value = SvIV(lstr);
- value = value ^ SvIV(rstr);
- SETi(value);
- }
- else {
- do_vop(op->op_type, TARG, lstr, rstr);
+ djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
+ {
+ dPOPTOPssrl;
+ if (SvNIOKp(left) || SvNIOKp(right)) {
+ if (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(op->op_type, TARG, left, right);
SETTARG;
+ }
+ RETURN;
}
- RETURN;
}
PP(pp_bit_or)
{
- dSP; dATARGET; dPOPTOPssrl;
- if (SvNIOK(lstr) || SvNIOK(rstr)) {
- I32 value = SvIV(lstr);
- value = value | SvIV(rstr);
- SETi(value);
- }
- else {
- do_vop(op->op_type, TARG, lstr, rstr);
+ djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+ {
+ dPOPTOPssrl;
+ if (SvNIOKp(left) || SvNIOKp(right)) {
+ if (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(op->op_type, TARG, left, right);
SETTARG;
+ }
+ RETURN;
}
- RETURN;
}
PP(pp_negate)
{
- dSP; dTARGET;
- SETn(-TOPn);
+ 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)
{
- *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
+#ifdef OVERLOAD
+ djSP; tryAMAGICunSET(not);
+#endif /* OVERLOAD */
+ *stack_sp = boolSV(!SvTRUE(*stack_sp));
return NORMAL;
}
PP(pp_complement)
{
- dSP; dTARGET; dTOPss;
- register I32 anum;
-
- if (SvNIOK(sv)) {
- SETi( ~SvIV(sv) );
- }
- else {
+ djSP; dTARGET; tryAMAGICun(compl);
+ {
+ dTOPss;
+ if (SvNIOKp(sv)) {
+ if (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(TARG, len);
+ tmps = SvPV_force(TARG, len);
anum = len;
#ifdef LIBERAL
for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
*tmps = ~*tmps;
SETs(TARG);
+ }
+ RETURN;
}
- RETURN;
}
-/* High falutin' math. */
+/* integer versions of some of the above */
-PP(pp_atan2)
+PP(pp_i_multiply)
{
- dSP; dTARGET; dPOPTOPnnrl;
- SETn(atan2(left, right));
- RETURN;
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ {
+ dPOPTOPiirl;
+ SETi( left * right );
+ RETURN;
+ }
}
-PP(pp_sin)
+PP(pp_i_divide)
{
- dSP; dTARGET;
- double value;
- if (MAXARG < 1)
- value = SvNVx(GvSV(defgv));
- else
- value = POPn;
- value = sin(value);
- XPUSHn(value);
- RETURN;
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ {
+ dPOPiv;
+ if (value == 0)
+ DIE("Illegal division by zero");
+ value = POPi / value;
+ PUSHi( value );
+ RETURN;
+ }
}
-PP(pp_cos)
+PP(pp_i_modulo)
{
- dSP; dTARGET;
- double value;
- if (MAXARG < 1)
- value = SvNVx(GvSV(defgv));
- else
- value = POPn;
- value = cos(value);
- XPUSHn(value);
- RETURN;
+ djSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE("Illegal modulus zero");
+ SETi( left % right );
+ RETURN;
+ }
}
-PP(pp_rand)
+PP(pp_i_add)
{
- dSP; dTARGET;
- double value;
- if (MAXARG < 1)
- value = 1.0;
- else
- value = POPn;
- if (value == 0.0)
- value = 1.0;
-#if RANDBITS == 31
- value = rand() * value / 2147483648.0;
-#else
-#if RANDBITS == 16
- value = rand() * value / 65536.0;
-#else
-#if RANDBITS == 15
- value = rand() * value / 32768.0;
-#else
- value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
-#endif
-#endif
-#endif
- XPUSHn(value);
- RETURN;
+ djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ {
+ dPOPTOPiirl;
+ SETi( left + right );
+ RETURN;
+ }
}
-PP(pp_srand)
+PP(pp_i_subtract)
{
- dSP;
- I32 anum;
- time_t when;
-
- if (MAXARG < 1) {
- (void)time(&when);
- anum = when;
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ {
+ dPOPTOPiirl;
+ SETi( left - right );
+ RETURN;
}
- else
- anum = POPi;
- (void)srand(anum);
- EXTEND(SP, 1);
- RETPUSHYES;
}
-PP(pp_exp)
+PP(pp_i_lt)
{
- dSP; dTARGET;
- double value;
- if (MAXARG < 1)
- value = SvNVx(GvSV(defgv));
- else
- value = POPn;
- value = exp(value);
- XPUSHn(value);
- RETURN;
+ djSP; tryAMAGICbinSET(lt,0);
+ {
+ dPOPTOPiirl;
+ SETs(boolSV(left < right));
+ RETURN;
+ }
}
-PP(pp_log)
+PP(pp_i_gt)
{
- dSP; dTARGET;
- double value;
- if (MAXARG < 1)
- value = SvNVx(GvSV(defgv));
- else
- value = POPn;
- if (value <= 0.0)
- DIE("Can't take log of %g", value);
- value = log(value);
- XPUSHn(value);
- RETURN;
+ djSP; tryAMAGICbinSET(gt,0);
+ {
+ dPOPTOPiirl;
+ SETs(boolSV(left > right));
+ RETURN;
+ }
}
-PP(pp_sqrt)
+PP(pp_i_le)
{
- dSP; dTARGET;
- double value;
- if (MAXARG < 1)
- value = SvNVx(GvSV(defgv));
- else
- value = POPn;
- if (value < 0.0)
- DIE("Can't take sqrt of %g", value);
- value = sqrt(value);
- XPUSHn(value);
+ 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;
}
-PP(pp_int)
+/* 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;
+ }
+}
+
+PP(pp_rand)
{
- dSP; dTARGET;
+ djSP; dTARGET;
double value;
if (MAXARG < 1)
- value = SvNVx(GvSV(defgv));
+ value = 1.0;
else
value = POPn;
- if (value >= 0.0)
- (void)modf(value, &value);
- else {
- (void)modf(-value, &value);
- value = -value;
+ if (value == 0.0)
+ value = 1.0;
+ if (!srand_called) {
+ (void)srand((unsigned)seed());
+ srand_called = TRUE;
}
+#if RANDBITS == 31
+ value = rand() * value / 2147483648.0;
+#else
+#if RANDBITS == 16
+ value = rand() * value / 65536.0;
+#else
+#if RANDBITS == 15
+ value = rand() * value / 32768.0;
+#else
+ value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
+#endif
+#endif
+#endif
XPUSHn(value);
RETURN;
}
-PP(pp_abs)
+PP(pp_srand)
{
- dSP; dTARGET;
- double value;
+ djSP;
+ UV anum;
if (MAXARG < 1)
- value = SvNVx(GvSV(defgv));
+ anum = seed();
else
- value = POPn;
+ anum = POPu;
+ (void)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)stack_sp;
+#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
+ u += SEED_C5 * (U32)(UV)&when;
+#endif
+ return u;
+}
- if (value < 0.0)
- value = -value;
+PP(pp_exp)
+{
+ djSP; dTARGET; tryAMAGICun(exp);
+ {
+ double value;
+ value = POPn;
+ value = exp(value);
+ XPUSHn(value);
+ RETURN;
+ }
+}
- XPUSHn(value);
+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)
{
- dSP; dTARGET;
+ djSP; dTARGET;
char *tmps;
I32 argtype;
- if (MAXARG < 1)
- tmps = SvPVx(GvSV(defgv), na);
- else
- tmps = POPp;
- XPUSHi( scan_hex(tmps, 99, &argtype) );
+ tmps = POPp;
+ XPUSHu(scan_hex(tmps, 99, &argtype));
RETURN;
}
PP(pp_oct)
{
- dSP; dTARGET;
- I32 value;
+ djSP; dTARGET;
+ UV value;
I32 argtype;
char *tmps;
- if (MAXARG < 1)
- tmps = SvPVx(GvSV(defgv), na);
- else
- tmps = POPp;
- while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
+ tmps = POPp;
+ while (*tmps && isSPACE(*tmps))
+ tmps++;
+ if (*tmps == '0')
tmps++;
if (*tmps == 'x')
- value = (I32)scan_hex(++tmps, 99, &argtype);
+ value = scan_hex(++tmps, 99, &argtype);
else
- value = (I32)scan_oct(tmps, 99, &argtype);
- XPUSHi(value);
+ value = scan_oct(tmps, 99, &argtype);
+ XPUSHu(value);
RETURN;
}
PP(pp_length)
{
- dSP; dTARGET;
- if (MAXARG < 1) {
- XPUSHi( sv_len(GvSV(defgv)) );
- }
- else
- SETi( sv_len(TOPs) );
+ djSP; dTARGET;
+ SETi( sv_len(TOPs) );
RETURN;
}
PP(pp_substr)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *sv;
I32 len;
STRLEN curlen;
I32 pos;
I32 rem;
- I32 lvalue = op->op_flags & OPf_LVAL;
+ I32 fail;
+ I32 lvalue = op->op_flags & OPf_MOD;
char *tmps;
+ I32 arybase = curcop->cop_arybase;
if (MAXARG > 2)
len = POPi;
- pos = POPi - arybase;
+ pos = POPi;
sv = POPs;
- tmps = SvPV(sv, curlen); /* force conversion to string */
- if (pos < 0)
- pos += curlen + arybase;
- if (pos < 0 || pos > curlen) {
- if (dowarn)
+ 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 (dowarn || lvalue)
warn("substr outside of string");
RETPUSHUNDEF;
}
else {
- if (MAXARG < 3)
- len = curlen;
- if (len < 0)
- len = 0;
tmps += pos;
- rem = curlen - pos; /* rem=how many bytes left*/
- if (rem > len)
- rem = len;
sv_setpvn(TARG, tmps, rem);
if (lvalue) { /* it's an lvalue! */
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- DIE(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
+ if (!SvGMAGICAL(sv)) {
+ if (SvROK(sv)) {
+ SvPV_force(sv,na);
+ if (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) = 's';
+
+ LvTYPE(TARG) = 'x';
LvTARG(TARG) = sv;
- LvTARGOFF(TARG) = tmps - SvPV(sv, na);
+ LvTARGOFF(TARG) = pos;
LvTARGLEN(TARG) = rem;
}
}
PP(pp_vec)
{
- dSP; dTARGET;
+ djSP; dTARGET;
register I32 size = POPi;
register I32 offset = POPi;
register SV *src = POPs;
- I32 lvalue = op->op_flags & OPf_LVAL;
+ I32 lvalue = op->op_flags & OPf_MOD;
STRLEN srclen;
unsigned char *s = (unsigned char*)SvPV(src, srclen);
unsigned long retnum;
len = (offset + size + 7) / 8;
if (offset < 0 || size < 1)
retnum = 0;
- else if (!lvalue && len > srclen)
- 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';
+ LvTARG(TARG) = src;
+ LvTARGOFF(TARG) = offset;
+ LvTARGLEN(TARG) = size;
+ }
if (len > srclen) {
- SvGROW(src, len);
- (void)memzero(SvPVX(src) + srclen, len - srclen);
- SvCUR_set(src, len);
+ 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);
+ }
+ }
}
- s = (unsigned char*)SvPV(src, na);
- if (size < 8)
+ else if (size < 8)
retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
else {
offset >>= 3;
((unsigned long) s[offset + 1] << 16) +
(s[offset + 2] << 8) + s[offset+3];
}
-
- if (lvalue) { /* it's an lvalue! */
- if (SvTHINKFIRST(src)) {
- if (SvREADONLY(src) && curcop != &compiling)
- DIE(no_modify);
- if (SvROK(src))
- sv_unref(src);
- }
- LvTYPE(TARG) = 'v';
- LvTARG(TARG) = src;
- LvTARGOFF(TARG) = offset;
- LvTARGLEN(TARG) = size;
- }
}
- sv_setiv(TARG, (I32)retnum);
+ sv_setiv(TARG, (IV)retnum);
PUSHs(TARG);
RETURN;
}
PP(pp_index)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *big;
SV *little;
I32 offset;
char *tmps;
char *tmps2;
STRLEN biglen;
+ I32 arybase = curcop->cop_arybase;
if (MAXARG < 3)
offset = 0;
PP(pp_rindex)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *big;
SV *little;
STRLEN blen;
I32 retval;
char *tmps;
char *tmps2;
+ I32 arybase = curcop->cop_arybase;
- if (MAXARG == 3)
+ if (MAXARG >= 3)
offstr = POPs;
little = POPs;
big = POPs;
PP(pp_sprintf)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ djSP; dMARK; dORIGMARK; dTARGET;
+#ifdef USE_LOCALE_NUMERIC
+ if (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;
}
-static void
-doparseform(sv)
-SV *sv;
+PP(pp_ord)
{
- STRLEN len;
- register char *s = SvPV(sv, len);
- register char *send = s + len;
- register char *base;
- register I32 skipspaces = 0;
- bool noblank;
- bool repeat;
- bool postspace = FALSE;
- U16 *fops;
- register U16 *fpc;
- U16 *linepc;
- register I32 arg;
- bool ischop;
-
- New(804, fops, send - s, U16); /* Almost certainly too long... */
- fpc = fops;
-
- if (s < send) {
- linepc = fpc;
- *fpc++ = FF_LINEMARK;
- noblank = repeat = FALSE;
- base = s;
- }
-
- while (s <= send) {
- switch (*s++) {
- default:
- skipspaces = 0;
- continue;
-
- case '~':
- if (*s == '~') {
- repeat = TRUE;
- *s = ' ';
- }
- noblank = TRUE;
- s[-1] = ' ';
- /* FALL THROUGH */
- case ' ': case '\t':
- skipspaces++;
- continue;
-
- case '\n': case 0:
- arg = s - base;
- skipspaces++;
- arg -= skipspaces;
- if (arg) {
- if (postspace) {
- *fpc++ = FF_SPACE;
- postspace = FALSE;
- }
- *fpc++ = FF_LITERAL;
- *fpc++ = arg;
- }
- if (s <= send)
- skipspaces--;
- if (skipspaces) {
- *fpc++ = FF_SKIP;
- *fpc++ = skipspaces;
- }
- skipspaces = 0;
- if (s <= send)
- *fpc++ = FF_NEWLINE;
- if (noblank) {
- *fpc++ = FF_BLANK;
- if (repeat)
- arg = fpc - linepc + 1;
- else
- arg = 0;
- *fpc++ = arg;
- }
- if (s < send) {
- linepc = fpc;
- *fpc++ = FF_LINEMARK;
- noblank = repeat = FALSE;
- base = s;
- }
- else
- s++;
- continue;
+ djSP; dTARGET;
+ I32 value;
+ char *tmps;
- case '@':
- case '^':
- ischop = s[-1] == '^';
+#ifndef I286
+ tmps = POPp;
+ value = (I32) (*tmps & 255);
+#else
+ I32 anum;
+ tmps = POPp;
+ anum = (I32) *tmps;
+ value = (I32) (anum & 255);
+#endif
+ XPUSHi(value);
+ RETURN;
+}
- if (postspace) {
- *fpc++ = FF_SPACE;
- postspace = FALSE;
- }
- arg = (s - base) - 1;
- if (arg) {
- *fpc++ = FF_LITERAL;
- *fpc++ = arg;
- }
+PP(pp_chr)
+{
+ djSP; dTARGET;
+ char *tmps;
- base = s - 1;
- *fpc++ = FF_FETCH;
- if (*s == '*') {
- s++;
- *fpc++ = 0;
- *fpc++ = FF_LINEGLOB;
- }
- else if (*s == '#' || (*s == '.' && s[1] == '#')) {
- arg = ischop ? 512 : 0;
- base = s - 1;
- while (*s == '#')
- s++;
- if (*s == '.') {
- char *f;
- s++;
- f = s;
- while (*s == '#')
- s++;
- arg |= 256 + (s - f);
- }
- *fpc++ = s - base; /* fieldsize for FETCH */
- *fpc++ = FF_DECIMAL;
- *fpc++ = arg;
- }
- else {
- I32 prespace = 0;
- bool ismore = FALSE;
+ (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;
+}
- if (*s == '>') {
- while (*++s == '>') ;
- prespace = FF_SPACE;
- }
- else if (*s == '|') {
- while (*++s == '|') ;
- prespace = FF_HALFSPACE;
- postspace = TRUE;
- }
- else {
- if (*s == '<')
- while (*++s == '<') ;
- postspace = TRUE;
- }
- if (*s == '.' && s[1] == '.' && s[2] == '.') {
- s += 3;
- ismore = TRUE;
- }
- *fpc++ = s - base; /* fieldsize for FETCH */
+PP(pp_crypt)
+{
+ djSP; dTARGET; dPOPTOPssrl;
+#ifdef HAS_CRYPT
+ char *tmps = SvPV(left, na);
+#ifdef FCRYPT
+ sv_setpv(TARG, fcrypt(tmps, SvPV(right, na)));
+#else
+ sv_setpv(TARG, crypt(tmps, SvPV(right, na)));
+#endif
+#else
+ DIE(
+ "The crypt() function is unimplemented due to excessive paranoia.");
+#endif
+ SETs(TARG);
+ RETURN;
+}
- *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
+PP(pp_ucfirst)
+{
+ djSP;
+ SV *sv = TOPs;
+ register char *s;
- if (prespace)
- *fpc++ = prespace;
- *fpc++ = FF_ITEM;
- if (ismore)
- *fpc++ = FF_MORE;
- if (ischop)
- *fpc++ = FF_CHOP;
- }
- base = s;
- skipspaces = 0;
- continue;
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPV_force(sv, na);
+ if (*s) {
+ if (op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toUPPER_LC(*s);
}
+ else
+ *s = toUPPER(*s);
}
- *fpc++ = FF_END;
-
- arg = fpc - fops;
- SvGROW(sv, SvCUR(sv) + arg * sizeof(U16) + 4);
- s = SvPVX(sv) + SvCUR(sv);
- s += 2 + (SvCUR(sv) & 1);
-
- Copy(fops, s, arg, U16);
- Safefree(fops);
+ RETURN;
}
-PP(pp_formline)
+PP(pp_lcfirst)
{
- dSP; dMARK; dORIGMARK;
- register SV *form = *++MARK;
- register U16 *fpc;
- register char *t;
- register char *f;
- register char *s;
- register char *send;
- register I32 arg;
- register SV *sv;
- I32 itemsize;
- I32 fieldsize;
- I32 lines = 0;
- bool chopspace = (strchr(chopset, ' ') != Nullch);
- char *chophere;
- char *linemark;
- char *formmark;
- SV **markmark;
- double value;
- bool gotsome;
- STRLEN len;
-
- if (!SvCOMPILED(form)) {
- SvREADONLY_off(form);
- doparseform(form);
- }
-
- SvUPGRADE(formtarget, SVt_PV);
- SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
- t = SvPV(formtarget, len);
- t += len;
- f = SvPV(form, len);
-
- s = f + len;
- s += 2 + (len & 1);
-
- fpc = (U16*)s;
-
- for (;;) {
- DEBUG_f( {
- char *name = "???";
- arg = -1;
- switch (*fpc) {
- case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
- case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
- case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
- case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
- case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
-
- case FF_CHECKNL: name = "CHECKNL"; break;
- case FF_CHECKCHOP: name = "CHECKCHOP"; break;
- case FF_SPACE: name = "SPACE"; break;
- case FF_HALFSPACE: name = "HALFSPACE"; break;
- case FF_ITEM: name = "ITEM"; break;
- case FF_CHOP: name = "CHOP"; break;
- case FF_LINEGLOB: name = "LINEGLOB"; break;
- case FF_NEWLINE: name = "NEWLINE"; break;
- case FF_MORE: name = "MORE"; break;
- case FF_LINEMARK: name = "LINEMARK"; break;
- case FF_END: name = "END"; break;
- }
- if (arg >= 0)
- fprintf(stderr, "%-16s%d\n", name, arg);
- else
- fprintf(stderr, "%-16s\n", name);
- } )
- switch (*fpc++) {
- case FF_LINEMARK:
- linemark = t;
- formmark = f;
- markmark = MARK;
- lines++;
- gotsome = FALSE;
- break;
-
- case FF_LITERAL:
- arg = *fpc++;
- while (arg--)
- *t++ = *f++;
- break;
-
- case FF_SKIP:
- f += *fpc++;
- break;
-
- case FF_FETCH:
- arg = *fpc++;
- f += arg;
- fieldsize = arg;
-
- if (MARK < SP)
- sv = *++MARK;
- else {
- sv = &sv_no;
- if (dowarn)
- warn("Not enough format arguments");
- }
- break;
-
- case FF_CHECKNL:
- s = SvPV(sv, len);
- itemsize = len;
- if (itemsize > fieldsize)
- itemsize = fieldsize;
- send = chophere = s + itemsize;
- while (s < send) {
- if (*s & ~31)
- gotsome = TRUE;
- else if (*s == '\n')
- break;
- s++;
- }
- itemsize = s - SvPVX(sv);
- break;
-
- case FF_CHECKCHOP:
- s = SvPV(sv, len);
- itemsize = len;
- if (itemsize <= fieldsize) {
- send = chophere = s + itemsize;
- while (s < send) {
- if (*s == '\r') {
- itemsize = s - SvPVX(sv);
- break;
- }
- if (*s++ & ~31)
- gotsome = TRUE;
- }
- }
- else {
- itemsize = fieldsize;
- send = chophere = s + itemsize;
- while (s < send || (s == send && isSPACE(*s))) {
- if (isSPACE(*s)) {
- if (chopspace)
- chophere = s;
- if (*s == '\r')
- break;
- }
- else {
- if (*s & ~31)
- gotsome = TRUE;
- if (strchr(chopset, *s))
- chophere = s + 1;
- }
- s++;
- }
- itemsize = chophere - SvPVX(sv);
- }
- break;
-
- case FF_SPACE:
- arg = fieldsize - itemsize;
- if (arg) {
- fieldsize -= arg;
- while (arg-- > 0)
- *t++ = ' ';
- }
- break;
-
- case FF_HALFSPACE:
- arg = fieldsize - itemsize;
- if (arg) {
- arg /= 2;
- fieldsize -= arg;
- while (arg-- > 0)
- *t++ = ' ';
- }
- break;
-
- case FF_ITEM:
- arg = itemsize;
- s = SvPVX(sv);
- while (arg--) {
- if ((*t++ = *s++) < ' ')
- t[-1] = ' ';
- }
- break;
-
- case FF_CHOP:
- s = chophere;
- if (chopspace) {
- while (*s && isSPACE(*s))
- s++;
- }
- sv_chop(sv,s);
- break;
-
- case FF_LINEGLOB:
- s = SvPV(sv, len);
- itemsize = len;
- if (itemsize) {
- gotsome = TRUE;
- send = s + itemsize;
- while (s < send) {
- if (*s++ == '\n') {
- if (s == send)
- itemsize--;
- else
- lines++;
- }
- }
- SvCUR_set(formtarget, t - SvPVX(formtarget));
- sv_catpvn(formtarget, SvPVX(sv), itemsize);
- SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
- t = SvPVX(formtarget) + SvCUR(formtarget);
- }
- break;
-
- case FF_DECIMAL:
- /* If the field is marked with ^ and the value is undefined,
- blank it out. */
- arg = *fpc++;
- if ((arg & 512) && !SvOK(sv)) {
- arg = fieldsize;
- while (arg--)
- *t++ = ' ';
- break;
- }
- gotsome = TRUE;
- value = SvNV(sv);
- if (arg & 256) {
- sprintf(t, "%#*.*f", fieldsize, arg & 255, value);
- } else {
- sprintf(t, "%*.0f", fieldsize, value);
- }
- t += fieldsize;
- break;
-
- case FF_NEWLINE:
- f++;
- while (t-- > linemark && *t == ' ') ;
- t++;
- *t++ = '\n';
- break;
-
- case FF_BLANK:
- arg = *fpc++;
- if (gotsome) {
- if (arg) { /* repeat until fields exhausted? */
- fpc -= arg;
- f = formmark;
- MARK = markmark;
- if (lines == 200) {
- arg = t - linemark;
- if (strnEQ(linemark, linemark - arg, arg))
- DIE("Runaway format");
- }
- arg = t - SvPVX(formtarget);
- SvGROW(formtarget,
- (t - SvPVX(formtarget)) + (f - formmark) + 1);
- t = SvPVX(formtarget) + arg;
- }
- }
- else {
- t = linemark;
- lines--;
- }
- break;
-
- case FF_MORE:
- if (SvCUROK(sv)) {
- arg = fieldsize - itemsize;
- if (arg) {
- fieldsize -= arg;
- while (arg-- > 0)
- *t++ = ' ';
- }
- s = t - 3;
- if (strnEQ(s," ",3)) {
- while (s > SvPVX(formtarget) && isSPACE(s[-1]))
- s--;
- }
- *s++ = '.';
- *s++ = '.';
- *s++ = '.';
- }
- break;
-
- case FF_END:
- *t = '\0';
- SvCUR_set(formtarget, t - SvPVX(formtarget));
- FmLINES(formtarget) += lines;
- SP = ORIGMARK;
- RETPUSHYES;
- }
- }
-}
-
-PP(pp_ord)
-{
- dSP; dTARGET;
- I32 value;
- char *tmps;
- I32 anum;
-
- if (MAXARG < 1)
- tmps = SvPVx(GvSV(defgv), na);
- else
- tmps = POPp;
-#ifndef I286
- value = (I32) (*tmps & 255);
-#else
- anum = (I32) *tmps;
- value = (I32) (anum & 255);
-#endif
- XPUSHi(value);
- RETURN;
-}
-
-PP(pp_chr)
-{
- dSP; dTARGET;
- char *tmps;
-
- if (SvTYPE(TARG) == SVt_NULL) {
- sv_upgrade(TARG,SVt_PV);
- SvGROW(TARG,1);
- }
- SvCUR_set(TARG, 1);
- tmps = SvPVX(TARG);
- if (MAXARG < 1)
- *tmps = SvIVx(GvSV(defgv));
- else
- *tmps = POPi;
- SvPOK_only(TARG);
- XPUSHs(TARG);
- RETURN;
-}
-
-PP(pp_crypt)
-{
- dSP; dTARGET; dPOPTOPssrl;
-#ifdef HAS_CRYPT
- char *tmps = SvPV(lstr, na);
-#ifdef FCRYPT
- sv_setpv(TARG, fcrypt(tmps, SvPV(rstr, na)));
-#else
- sv_setpv(TARG, crypt(tmps, SvPV(rstr, na)));
-#endif
-#else
- DIE(
- "The crypt() function is unimplemented due to excessive paranoia.");
-#endif
- SETs(TARG);
- RETURN;
-}
-
-PP(pp_ucfirst)
-{
- dSP;
- SV *sv = TOPs;
+ djSP;
+ SV *sv = TOPs;
register char *s;
if (!SvPADTMP(sv)) {
sv = TARG;
SETs(sv);
}
- s = SvPV(sv, na);
- if (isascii(*s) && islower(*s))
- *s = toupper(*s);
-
- RETURN;
-}
-
-PP(pp_lcfirst)
-{
- dSP;
- SV *sv = TOPs;
- register char *s;
-
- if (!SvPADTMP(sv)) {
- dTARGET;
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
+ s = SvPV_force(sv, na);
+ if (*s) {
+ if (op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toLOWER_LC(*s);
+ }
+ else
+ *s = toLOWER(*s);
}
- s = SvPV(sv, na);
- if (isascii(*s) && isupper(*s))
- *s = tolower(*s);
SETs(sv);
RETURN;
PP(pp_uc)
{
- dSP;
+ djSP;
SV *sv = TOPs;
register char *s;
- register char *send;
STRLEN len;
if (!SvPADTMP(sv)) {
sv = TARG;
SETs(sv);
}
- s = SvPV(sv, len);
- send = s + len;
- while (s < send) {
- if (isascii(*s) && islower(*s))
- *s = toupper(*s);
- s++;
+
+ s = SvPV_force(sv, len);
+ if (len) {
+ register char *send = s + len;
+
+ if (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)
{
- dSP;
+ djSP;
SV *sv = TOPs;
register char *s;
- register char *send;
STRLEN len;
if (!SvPADTMP(sv)) {
sv = TARG;
SETs(sv);
}
- s = SvPV(sv, len);
- send = s + len;
- while (s < send) {
- if (isascii(*s) && isupper(*s))
- *s = tolower(*s);
- s++;
- }
- RETURN;
-}
-
-/* Arrays. */
-
-PP(pp_rv2av)
-{
- dSP; dPOPss;
- AV *av;
+ s = SvPV_force(sv, len);
+ if (len) {
+ register char *send = s + len;
- if (SvROK(sv)) {
- av = (AV*)SvRV(sv);
- if (SvTYPE(av) != SVt_PVAV)
- DIE("Not an array reference");
- if (op->op_flags & OPf_LVAL) {
- if (op->op_flags & OPf_INTRO)
- av = (AV*)save_svref((SV**)sv);
- PUSHs((SV*)av);
- RETURN;
- }
- }
- else {
- if (SvTYPE(sv) == SVt_PVAV) {
- av = (AV*)sv;
- if (op->op_flags & OPf_LVAL) {
- PUSHs((SV*)av);
- RETURN;
- }
+ if (op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ for (; s < send; s++)
+ *s = toLOWER_LC(*s);
}
else {
- if (SvTYPE(sv) != SVt_PVGV) {
- if (!SvOK(sv))
- DIE(no_usym, "an array");
- sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
- }
- av = GvAVn(sv);
- if (op->op_flags & OPf_LVAL) {
- if (op->op_flags & OPf_INTRO)
- av = save_ary(sv);
- PUSHs((SV*)av);
- RETURN;
- }
+ for (; s < send; s++)
+ *s = toLOWER(*s);
}
}
-
- if (GIMME == G_ARRAY) {
- I32 maxarg = AvFILL(av) + 1;
- EXTEND(SP, maxarg);
- Copy(AvARRAY(av), SP+1, maxarg, SV*);
- SP += maxarg;
- }
- else {
- dTARGET;
- I32 maxarg = AvFILL(av) + 1;
- PUSHi(maxarg);
- }
- RETURN;
-}
-
-PP(pp_aelemfast)
-{
- dSP;
- AV *av = GvAV((GV*)cSVOP->op_sv);
- SV** svp = av_fetch(av, op->op_private - arybase, op->op_flags & OPf_LVAL);
- PUSHs(svp ? *svp : &sv_undef);
RETURN;
}
-PP(pp_aelem)
+PP(pp_quotemeta)
{
- dSP;
- SV** svp;
- I32 elem = POPi - arybase;
- AV *av = (AV*)POPs;
+ djSP; dTARGET;
+ SV *sv = TOPs;
+ STRLEN len;
+ register char *s = SvPV(sv,len);
+ register char *d;
- if (op->op_flags & OPf_LVAL) {
- svp = av_fetch(av, elem, TRUE);
- if (!svp || *svp == &sv_undef)
- DIE(no_aelem, elem);
- if (op->op_flags & OPf_INTRO)
- save_svref(svp);
- else if (!SvOK(*svp)) {
- if (op->op_private == OP_RV2HV) {
- SvREFCNT_dec(*svp);
- *svp = NEWSV(0,0);
- sv_upgrade(*svp, SVt_RV);
- SvRV(*svp) = SvREFCNT_inc(newHV());
- SvROK_on(*svp);
- ++sv_rvcount;
- }
- else if (op->op_private == OP_RV2AV) {
- SvREFCNT_dec(*svp);
- *svp = NEWSV(0,0);
- sv_upgrade(*svp, SVt_RV);
- SvRV(*svp) = SvREFCNT_inc(newAV());
- SvROK_on(*svp);
- ++sv_rvcount;
- }
+ 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
- svp = av_fetch(av, elem, FALSE);
- PUSHs(svp ? *svp : &sv_undef);
+ sv_setpvn(TARG, s, len);
+ SETs(TARG);
RETURN;
}
+/* Arrays. */
+
PP(pp_aslice)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
register SV** svp;
register AV* av = (AV*)POPs;
- register I32 lval = op->op_flags & OPf_LVAL;
- I32 is_something_there = lval;
+ register I32 lval = op->op_flags & OPf_MOD;
+ I32 arybase = curcop->cop_arybase;
+ I32 elem;
- while (++MARK <= SP) {
- I32 elem = SvIVx(*MARK);
-
- if (lval) {
- svp = av_fetch(av, elem, TRUE);
- if (!svp || *svp == &sv_undef)
- DIE(no_aelem, elem);
- if (op->op_flags & OPf_INTRO)
- save_svref(svp);
+ if (SvTYPE(av) == SVt_PVAV) {
+ if (lval && 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);
}
- else {
- svp = av_fetch(av, elem, FALSE);
- if (!is_something_there && svp && SvOK(*svp))
- is_something_there = TRUE;
+ while (++MARK <= SP) {
+ elem = SvIVx(*MARK);
+
+ if (elem > 0)
+ elem -= arybase;
+ svp = av_fetch(av, elem, lval);
+ if (lval) {
+ if (!svp || *svp == &sv_undef)
+ DIE(no_aelem, elem);
+ if (op->op_private & OPpLVAL_INTRO)
+ save_svref(svp);
+ }
+ *MARK = svp ? *svp : &sv_undef;
}
- *MARK = svp ? *svp : &sv_undef;
}
- if (!is_something_there)
- SP = ORIGMARK;
+ if (GIMME != G_ARRAY) {
+ MARK = ORIGMARK;
+ *++MARK = *SP;
+ SP = MARK;
+ }
RETURN;
}
PP(pp_each)
{
- dSP; dTARGET;
+ djSP; dTARGET;
HV *hash = (HV*)POPs;
- HE *entry = hv_iternext(hash);
- I32 i;
- char *tmps;
+ 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) {
- tmps = hv_iterkey(entry, &i);
- if (!i)
- tmps = "";
- PUSHs(sv_2mortal(newSVpv(tmps, i)));
- if (GIMME == G_ARRAY) {
- sv_setsv(TARG, hv_iterval(hash, 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)
+ else if (gimme == G_SCALAR)
RETPUSHUNDEF;
RETURN;
PP(pp_delete)
{
- dSP;
+ djSP;
+ I32 gimme = GIMME_V;
+ I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
SV *sv;
- SV *tmpsv = POPs;
- HV *hv = (HV*)POPs;
- char *tmps;
- STRLEN len;
- if (!hv) {
- DIE("Not an associative array reference");
- }
- tmps = SvPV(tmpsv, len);
- sv = hv_delete(hv, tmps, len);
- if (!sv)
- RETPUSHUNDEF;
- PUSHs(sv);
- RETURN;
-}
-
-PP(pp_rv2hv)
-{
-
- dSP; dTOPss;
-
HV *hv;
- if (SvTYPE(sv) == SVt_RV) {
- hv = (HV*)SvRV(sv);
- if (SvTYPE(hv) != SVt_PVHV)
- DIE("Not an associative array reference");
- if (op->op_flags & OPf_LVAL) {
- if (op->op_flags & OPf_INTRO)
- hv = (HV*)save_svref((SV**)sv);
- SETs((SV*)hv);
- RETURN;
- }
- }
- else {
- if (SvTYPE(sv) == SVt_PVHV) {
- hv = (HV*)sv;
- if (op->op_flags & OPf_LVAL) {
- SETs((SV*)hv);
- RETURN;
- }
+ if (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 if (hvtype == SVt_PVAV)
+ sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
+ else
+ DIE("Not a HASH reference");
+ *MARK = sv ? sv : &sv_undef;
}
- else {
- if (SvTYPE(sv) != SVt_PVGV) {
- if (!SvOK(sv))
- DIE(no_usym, "a hash");
- sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
- }
- hv = GvHVn(sv);
- if (op->op_flags & OPf_LVAL) {
- if (op->op_flags & OPf_INTRO)
- hv = save_hash(sv);
- SETs((SV*)hv);
- RETURN;
- }
+ if (discard)
+ SP = ORIGMARK;
+ else if (gimme == G_SCALAR) {
+ MARK = ORIGMARK;
+ *++MARK = *SP;
+ SP = MARK;
}
}
-
- if (GIMME == G_ARRAY) { /* array wanted */
- *stack_sp = (SV*)hv;
- return do_kv(ARGS);
- }
else {
- dTARGET;
- if (HvFILL(hv)) {
- sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1);
- sv_setpv(TARG, buf);
- }
+ 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)
+ sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
else
- sv_setiv(TARG, 0);
- SETTARG;
- RETURN;
+ DIE("Not a HASH reference");
+ if (!sv)
+ sv = &sv_undef;
+ if (!discard)
+ PUSHs(sv);
}
+ RETURN;
}
-PP(pp_helem)
+PP(pp_exists)
{
- dSP;
- SV** svp;
- SV *keysv = POPs;
- STRLEN keylen;
- char *key = SvPV(keysv, keylen);
+ djSP;
+ SV *tmpsv = POPs;
HV *hv = (HV*)POPs;
-
- if (op->op_flags & OPf_LVAL) {
- svp = hv_fetch(hv, key, keylen, TRUE);
- if (!svp || *svp == &sv_undef)
- DIE(no_helem, key);
- if (op->op_flags & OPf_INTRO)
- save_svref(svp);
- else if (!SvOK(*svp)) {
- if (op->op_private == OP_RV2HV) {
- SvREFCNT_dec(*svp);
- *svp = NEWSV(0,0);
- sv_upgrade(*svp, SVt_RV);
- SvRV(*svp) = SvREFCNT_inc(newHV());
- SvROK_on(*svp);
- ++sv_rvcount;
- }
- else if (op->op_private == OP_RV2AV) {
- SvREFCNT_dec(*svp);
- *svp = NEWSV(0,0);
- sv_upgrade(*svp, SVt_RV);
- SvRV(*svp) = SvREFCNT_inc(newAV());
- SvROK_on(*svp);
- ++sv_rvcount;
- }
- }
+ 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");
}
- else
- svp = hv_fetch(hv, key, keylen, FALSE);
- PUSHs(svp ? *svp : &sv_undef);
- RETURN;
+ RETPUSHNO;
}
PP(pp_hslice)
{
- dSP; dMARK; dORIGMARK;
- register SV **svp;
+ djSP; dMARK; dORIGMARK;
+ register HE *he;
register HV *hv = (HV*)POPs;
- register I32 lval = op->op_flags & OPf_LVAL;
- I32 is_something_there = lval;
-
- while (++MARK <= SP) {
- STRLEN keylen;
- char *key = SvPV(*MARK, keylen);
+ register I32 lval = op->op_flags & OPf_MOD;
+ I32 realhv = (SvTYPE(hv) == SVt_PVHV);
- if (lval) {
- svp = hv_fetch(hv, key, keylen, TRUE);
- if (!svp || *svp == &sv_undef)
- DIE(no_helem, key);
- if (op->op_flags & OPf_INTRO)
- save_svref(svp);
- }
- else {
- svp = hv_fetch(hv, key, keylen, FALSE);
- if (!is_something_there && svp && SvOK(*svp))
- is_something_there = TRUE;
+ if (realhv || SvTYPE(hv) == SVt_PVAV) {
+ while (++MARK <= SP) {
+ SV *keysv = *MARK;
+ SV **svp;
+ if (realhv) {
+ 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 (!he || HeVAL(he) == &sv_undef)
+ DIE(no_helem, SvPV(keysv, na));
+ if (op->op_private & OPpLVAL_INTRO)
+ save_svref(&HeVAL(he));
+ }
+ *MARK = he ? HeVAL(he) : &sv_undef;
}
- *MARK = svp ? *svp : &sv_undef;
}
- if (!is_something_there)
- SP = ORIGMARK;
+ if (GIMME != G_ARRAY) {
+ MARK = ORIGMARK;
+ *++MARK = *SP;
+ SP = MARK;
+ }
RETURN;
}
-/* Explosives and implosives. */
+/* List operators. */
-PP(pp_unpack)
+PP(pp_list)
{
- dSP;
- dPOPPOPssrl;
- SV *sv;
- STRLEN llen;
- STRLEN rlen;
- register char *pat = SvPV(lstr, llen);
- register char *s = SvPV(rstr, rlen);
- char *strend = s + rlen;
- char *strbeg = s;
- register char *patend = pat + llen;
- I32 datumtype;
- register I32 len;
- register I32 bits;
+ djSP; dMARK;
+ if (GIMME != G_ARRAY) {
+ if (++MARK <= SP)
+ *MARK = *SP; /* unwanted list, return last item */
+ else
+ *MARK = &sv_undef;
+ SP = MARK;
+ }
+ RETURN;
+}
- /* These must not be in registers: */
- I16 ashort;
- int aint;
- I32 along;
-#ifdef QUAD
- quad aquad;
-#endif
- U16 aushort;
- unsigned int auint;
- U32 aulong;
-#ifdef QUAD
- unsigned quad auquad;
-#endif
- char *aptr;
- float afloat;
- double adouble;
- I32 checksum = 0;
- register U32 culong;
- double cdouble;
- static char* bitcount = 0;
+PP(pp_lslice)
+{
+ djSP;
+ SV **lastrelem = stack_sp;
+ SV **lastlelem = stack_base + POPMARK;
+ SV **firstlelem = stack_base + POPMARK + 1;
+ register SV **firstrelem = lastlelem + 1;
+ I32 arybase = curcop->cop_arybase;
+ I32 lval = op->op_flags & OPf_MOD;
+ I32 is_something_there = lval;
- if (GIMME != G_ARRAY) { /* arrange to do first one only */
- /*SUPPRESS 530*/
- for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
- if (strchr("aAbBhH", *patend) || *pat == '%') {
- patend++;
- while (isDIGIT(*patend) || *patend == '*')
- patend++;
- }
+ register I32 max = lastrelem - lastlelem;
+ register SV **lelem;
+ register I32 ix;
+
+ if (GIMME != G_ARRAY) {
+ ix = SvIVx(*lastlelem);
+ if (ix < 0)
+ ix += max;
else
- patend++;
+ ix -= arybase;
+ if (ix < 0 || ix >= max)
+ *firstlelem = &sv_undef;
+ else
+ *firstlelem = firstrelem[ix];
+ SP = firstlelem;
+ RETURN;
}
- while (pat < patend) {
- reparse:
- datumtype = *pat++;
- if (pat >= patend)
- len = 1;
- else if (*pat == '*') {
- len = strend - strbeg; /* long enough */
- pat++;
+
+ 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 = &sv_undef;
+ else if (!(*lelem = firstrelem[ix]))
+ *lelem = &sv_undef;
}
- else if (isDIGIT(*pat)) {
- len = *pat++ - '0';
- while (isDIGIT(*pat))
- len = (len * 10) + (*pat++ - '0');
+ else {
+ ix -= arybase;
+ if (ix >= max || !(*lelem = firstrelem[ix]))
+ *lelem = &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 (dowarn)
+ warn("Odd number of elements in hash list");
+ (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 -= curcop->cop_arybase;
+ if (offset < 0)
+ DIE(no_aelem, i);
+ if (++MARK < SP) {
+ length = SvIVx(*MARK++);
+ if (length < 0)
+ length = 0;
}
else
- len = (datumtype != '@');
- switch(datumtype) {
- default:
- 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++ = hexdigit[bits & 15];
- }
- }
- else {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 1)
- bits <<= 4;
- else
- bits = *s++;
- *pat++ = 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);
- while (len-- > 0) {
- aint = *s++;
- if (aint >= 128) /* fake up signed chars */
- aint -= 256;
- sv = NEWSV(36, 0);
- sv_setiv(sv, (I32)aint);
- PUSHs(sv_2mortal(sv));
+ 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--) {
+ if (!SvIMMORTAL(*dst))
+ sv_2mortal(*dst); /* free them eventualy */
+ dst++;
}
}
- break;
- case 'C':
- if (len > strend - s)
- len = strend - s;
- if (checksum) {
- uchar_checksum:
- while (len-- > 0) {
- auint = *s++ & 255;
- culong += auint;
- }
+ MARK += length - 1;
+ }
+ else {
+ *MARK = AvARRAY(ary)[offset+length-1];
+ if (AvREAL(ary)) {
+ if (!SvIMMORTAL(*MARK))
+ sv_2mortal(*MARK);
+ for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
+ SvREFCNT_dec(*dst++); /* free them now */
}
- else {
- EXTEND(SP, len);
- while (len-- > 0) {
- auint = *s++ & 255;
- sv = NEWSV(37, 0);
- sv_setiv(sv, (I32)auint);
- PUSHs(sv_2mortal(sv));
- }
+ }
+ 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--;
}
- break;
- case 's':
- along = (strend - s) / sizeof(I16);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &ashort, 1, I16);
- s += sizeof(I16);
- culong += ashort;
- }
+ 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*);
}
- else {
- EXTEND(SP, len);
- while (len-- > 0) {
- Copy(s, &ashort, 1, I16);
- s += sizeof(I16);
- sv = NEWSV(38, 0);
- sv_setiv(sv, (I32)ashort);
- PUSHs(sv_2mortal(sv));
- }
+ dst = &AvARRAY(ary)[AvFILLp(ary)+1];
+ /* avoid later double free */
+ }
+ i = -diff;
+ while (i)
+ dst[--i] = &sv_undef;
+
+ if (newlen) {
+ for (src = tmparyval, dst = AvARRAY(ary) + offset;
+ newlen; newlen--) {
+ *dst = NEWSV(46, 0);
+ sv_setsv(*dst++, *src++);
}
- break;
- case 'v':
- case 'n':
- case 'S':
- along = (strend - s) / sizeof(U16);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &aushort, 1, U16);
- s += sizeof(U16);
-#ifdef HAS_NTOHS
- if (datumtype == 'n')
- aushort = ntohs(aushort);
-#endif
-#ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
-#endif
- culong += aushort;
+ 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 {
- EXTEND(SP, len);
- while (len-- > 0) {
- Copy(s, &aushort, 1, U16);
- s += sizeof(U16);
- sv = NEWSV(39, 0);
-#ifdef HAS_NTOHS
- if (datumtype == 'n')
- aushort = ntohs(aushort);
-#endif
-#ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
-#endif
- sv_setiv(sv, (I32)aushort);
- PUSHs(sv_2mortal(sv));
+ 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--;
+ }
}
}
- 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;
+ }
+
+ 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--) {
+ if (!SvIMMORTAL(*dst))
+ sv_2mortal(*dst); /* free them eventualy */
+ dst++;
+ }
}
+ Safefree(tmparyval);
}
- else {
- EXTEND(SP, len);
- while (len-- > 0) {
- Copy(s, &aint, 1, int);
- s += sizeof(int);
- sv = NEWSV(40, 0);
- sv_setiv(sv, (I32)aint);
- PUSHs(sv_2mortal(sv));
- }
+ MARK += length - 1;
+ }
+ else if (length--) {
+ *MARK = tmparyval[length];
+ if (AvREAL(ary)) {
+ if (!SvIMMORTAL(*MARK))
+ sv_2mortal(*MARK);
+ while (length-- > 0)
+ SvREFCNT_dec(tmparyval[length]);
}
- 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);
- while (len-- > 0) {
- Copy(s, &auint, 1, unsigned int);
- s += sizeof(unsigned int);
- sv = NEWSV(41, 0);
- sv_setiv(sv, (I32)auint);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'l':
- along = (strend - s) / sizeof(I32);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &along, 1, I32);
- s += sizeof(I32);
- if (checksum > 32)
- cdouble += (double)along;
- else
- culong += along;
- }
- }
- else {
- EXTEND(SP, len);
- while (len-- > 0) {
- Copy(s, &along, 1, I32);
- s += sizeof(I32);
- sv = NEWSV(42, 0);
- sv_setiv(sv, (I32)along);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'V':
- case 'N':
- case 'L':
- along = (strend - s) / sizeof(U32);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &aulong, 1, U32);
- s += sizeof(U32);
-#ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = 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);
- while (len-- > 0) {
- Copy(s, &aulong, 1, U32);
- s += sizeof(U32);
- sv = NEWSV(43, 0);
-#ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = ntohl(aulong);
-#endif
-#ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
-#endif
- sv_setnv(sv, (double)aulong);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'p':
- along = (strend - s) / sizeof(char*);
- if (len > along)
- len = along;
- EXTEND(SP, 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 '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 QUAD
- case 'q':
- EXTEND(SP, len);
- while (len-- > 0) {
- if (s + sizeof(quad) > strend)
- aquad = 0;
- else {
- Copy(s, &aquad, 1, quad);
- s += sizeof(quad);
- }
- sv = NEWSV(42, 0);
- sv_setnv(sv, (double)aquad);
- PUSHs(sv_2mortal(sv));
- }
- break;
- case 'Q':
- EXTEND(SP, len);
- while (len-- > 0) {
- if (s + sizeof(unsigned quad) > strend)
- auquad = 0;
- else {
- Copy(s, &auquad, 1, unsigned quad);
- s += sizeof(unsigned quad);
- }
- sv = NEWSV(43, 0);
- 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);
- 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);
- 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':
- along = (strend - s) * 3 / 4;
- sv = NEWSV(42, along);
- while (s < strend && *s > ' ' && *s < 'a') {
- I32 a, b, c, d;
- char hunk[4];
-
- hunk[3] = '\0';
- len = (*s++ - ' ') & 077;
- while (len > 0) {
- if (s < strend && *s >= ' ')
- a = (*s++ - ' ') & 077;
- else
- a = 0;
- if (s < strend && *s >= ' ')
- b = (*s++ - ' ') & 077;
- else
- b = 0;
- if (s < strend && *s >= ' ')
- c = (*s++ - ' ') & 077;
- else
- c = 0;
- if (s < strend && *s >= ' ')
- d = (*s++ - ' ') & 077;
- 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;
+ Safefree(tmparyval);
}
- if (checksum) {
- sv = NEWSV(42, 0);
- if (strchr("fFdD", datumtype) ||
- (checksum > 32 && strchr("iIlLN", datumtype)) ) {
- double modf();
- double trouble;
+ else
+ *MARK = &sv_undef;
+ }
+ SP = MARK;
+ RETURN;
+}
- 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) {
- along = (1 << checksum) - 1;
- culong &= (U32)along;
- }
- sv_setnv(sv, (double)culong);
- }
- XPUSHs(sv_2mortal(sv));
- checksum = 0;
+PP(pp_push)
+{
+ djSP; dMARK; dORIGMARK; dTARGET;
+ register AV *ary = (AV*)*++MARK;
+ register SV *sv = &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;
}
-static void
-doencodes(sv, s, len)
-register SV *sv;
-register char *s;
-register I32 len;
+PP(pp_pop)
{
- char hunk[5];
+ djSP;
+ AV *av = (AV*)POPs;
+ SV *sv = av_pop(av);
+ if (!SvIMMORTAL(sv) && AvREAL(av))
+ (void)sv_2mortal(sv);
+ PUSHs(sv);
+ RETURN;
+}
- *hunk = len + ' ';
- sv_catpvn(sv, hunk, 1);
- hunk[4] = '\0';
- while (len > 0) {
- hunk[0] = ' ' + (077 & (*s >> 2));
- hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
- hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
- hunk[3] = ' ' + (077 & (s[2] & 077));
- sv_catpvn(sv, hunk, 4);
- s += 3;
- len -= 3;
+PP(pp_shift)
+{
+ djSP;
+ AV *av = (AV*)POPs;
+ SV *sv = av_shift(av);
+ EXTEND(SP, 1);
+ if (!sv)
+ RETPUSHUNDEF;
+ if (!SvIMMORTAL(sv) && 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;
+ PUTBACK;
+ ENTER;
+ perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
+ LEAVE;
+ SPAGAIN;
}
- for (s = SvPVX(sv); *s; s++) {
- if (*s == ' ')
- *s = '`';
+ else {
+ av_unshift(ary, SP - MARK);
+ while (MARK < SP) {
+ sv = NEWSV(27, 0);
+ sv_setsv(sv, *++MARK);
+ (void)av_store(ary, i++, sv);
+ }
}
- sv_catpvn(sv, "\n", 1);
+ SP = ORIGMARK;
+ PUSHi( AvFILL(ary) + 1 );
+ RETURN;
}
-PP(pp_pack)
+PP(pp_reverse)
{
- dSP; 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;
+ 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, &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 *New = newSVpv("0000000000", 10);
+
+ sv_catsv(New, sv);
+ SvREFCNT_dec(sv); /* free old sv */
+ sv = New;
+ 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. */
+
+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;
- SV *fromstr;
- /*SUPPRESS 442*/
- static char null10[] = {0,0,0,0,0,0,0,0,0,0};
- static char *space10 = " ";
+ register I32 len;
+ register I32 bits;
/* These must not be in registers: */
- char achar;
I16 ashort;
int aint;
- unsigned int auint;
I32 along;
+#ifdef HAS_QUAD
+ Quad_t aquad;
+#endif
+ U16 aushort;
+ unsigned int auint;
U32 aulong;
-#ifdef QUAD
- quad aquad;
- unsigned quad auquad;
+#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;
- items = SP - MARK;
- MARK++;
- sv_setpvn(cat, "", 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) {
-#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
- datumtype = *pat++;
- if (*pat == '*') {
- len = strchr("@Xxu", datumtype) ? 0 : items;
+ 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 = (len * 10) + (*pat++ - '0');
}
else
- len = 1;
+ len = (datumtype != '@');
switch(datumtype) {
default:
+ croak("Invalid type in unpack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && dowarn)
+ warn("Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
- DIE("%% may only be used in unpack");
+ if (len == 1 && pat[-1] != '1')
+ len = 16;
+ checksum = len;
+ culong = 0;
+ cdouble = 0;
+ if (pat < patend)
+ goto reparse;
+ break;
case '@':
- len -= SvCUR(cat);
- if (len > 0)
- goto grow;
- len = -len;
- if (len > 0)
- goto shrink;
+ if (len > strend - strbeg)
+ DIE("@ outside of string");
+ s = strbeg + len;
break;
case 'X':
- shrink:
- if (SvCUR(cat) < len)
+ if (len > s - strbeg)
DIE("X outside of string");
- SvCUR(cat) -= len;
- *SvEND(cat) = '\0';
+ s -= len;
break;
case 'x':
- grow:
- while (len >= 10) {
- sv_catpvn(cat, null10, 10);
- len -= 10;
- }
- sv_catpvn(cat, null10, len);
+ if (len > strend - s)
+ DIE("x outside of string");
+ s += 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;
+ 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]++;
}
- sv_catpvn(cat, space10, len);
}
- else {
- while (len >= 10) {
- sv_catpvn(cat, null10, 10);
- len -= 10;
+ 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;
+ }
}
- sv_catpvn(cat, null10, len);
}
+ break;
}
- 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;
+ sv = NEWSV(35, len + 1);
+ SvCUR_set(sv, len);
+ SvPOK_on(sv);
+ aptr = pat; /* borrow register */
+ pat = SvPVX(sv);
+ if (datumtype == 'b') {
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;
- }
- }
+ for (len = 0; len < aint; len++) {
+ if (len & 7) /*SUPPRESS 595*/
+ bits >>= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + (bits & 1);
}
- if (aint & 7) {
- if (datumtype == 'B')
- items <<= 7 - (aint & 7);
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7)
+ bits <<= 1;
else
- items >>= 7 - (aint & 7);
- *aptr++ = items & 0xff;
+ bits = *s++;
+ *pat++ = '0' + ((bits & 128) != 0);
}
- pat = SvPVX(cat) + SvCUR(cat);
- while (aptr <= pat)
- *aptr++ = '\0';
-
- pat = savepat;
- items = saveitems;
}
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ XPUSHs(sv_2mortal(sv));
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;
+ 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;
- 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;
- }
- }
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits >>= 4;
+ else
+ bits = *s++;
+ *pat++ = hexdigit[bits & 15];
}
- 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;
- }
- }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits <<= 4;
+ else
+ bits = *s++;
+ *pat++ = hexdigit[(bits >> 4) & 15];
}
- if (aint & 1)
- *aptr++ = items & 0xff;
- pat = SvPVX(cat) + SvCUR(cat);
- while (aptr <= pat)
- *aptr++ = '\0';
-
- pat = savepat;
- items = saveitems;
}
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ XPUSHs(sv_2mortal(sv));
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));
+ 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;
+ }
}
- break;
- case 'd':
- case 'D':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- adouble = (double)SvNV(fromstr);
- sv_catpvn(cat, (char *)&adouble, sizeof (double));
+ 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 'n':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (I16)SvIV(fromstr);
-#ifdef HAS_HTONS
- ashort = htons(ashort);
-#endif
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ case 'C':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ uchar_checksum:
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ culong += auint;
+ }
}
- break;
- case 'v':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (I16)SvIV(fromstr);
-#ifdef HAS_HTOVS
- ashort = htovs(ashort);
-#endif
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ 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':
case 's':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (I16)SvIV(fromstr);
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
- }
- break;
- case 'I':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- auint = U_I(SvNV(fromstr));
- sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
+ along = (strend - s) / SIZE16;
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ COPY16(s, &ashort);
+ s += SIZE16;
+ culong += ashort;
+ }
}
- break;
- case 'i':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aint = SvIV(fromstr);
- sv_catpvn(cat, (char*)&aint, sizeof(int));
+ 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 'N':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
-#ifdef HAS_HTONL
- aulong = htonl(aulong);
-#endif
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
- }
- break;
- case 'V':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
-#ifdef HAS_HTOVL
- aulong = htovl(aulong);
+ 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 = ntohs(aushort);
#endif
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
- }
- break;
- case 'L':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
- }
- break;
- case 'l':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- along = SvIV(fromstr);
- sv_catpvn(cat, (char*)&along, sizeof(I32));
- }
- break;
-#ifdef QUAD
- case 'Q':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- auquad = (unsigned quad)SvNV(fromstr);
- sv_catpvn(cat, (char*)&auquad, sizeof(unsigned quad));
+#ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+#endif
+ culong += aushort;
+ }
}
- break;
- case 'q':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aquad = (quad)SvNV(fromstr);
- sv_catpvn(cat, (char*)&aquad, sizeof(quad));
+ 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 = ntohs(aushort);
+#endif
+#ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+#endif
+ sv_setiv(sv, (IV)aushort);
+ PUSHs(sv_2mortal(sv));
+ }
}
break;
-#endif /* QUAD */
- case 'P':
- len = 1; /* assume SV is correct length */
- /* FALL THROUGH */
- case 'p':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aptr = SvPV(fromstr, na);
- sv_catpvn(cat, (char*)&aptr, sizeof(char*));
+ 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;
+ }
}
- 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;
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ Copy(s, &aint, 1, int);
+ s += sizeof(int);
+ sv = NEWSV(40, 0);
+ sv_setiv(sv, (IV)aint);
+ PUSHs(sv_2mortal(sv));
+ }
}
break;
- }
- }
- SvSETMAGIC(cat);
- SP = ORIGMARK;
- PUSHs(cat);
- RETURN;
-}
-#undef NEXTFROM
-
-PP(pp_split)
-{
- dSP; 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 = (PMOP*)POPs;
- 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;
- register REGEXP *rx = pm->op_pmregexp;
- I32 gimme = GIMME;
-
- if (!pm || !s)
- DIE("panic: do_split");
- if (pm->op_pmreplroot)
- ary = GvAVn((GV*)pm->op_pmreplroot);
- else if (gimme != G_ARRAY)
- ary = GvAVn(defgv);
- else
- ary = Nullav;
- if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
- realarray = 1;
- if (!AvREAL(ary)) {
- AvREAL_on(ary);
- for (i = AvFILL(ary); i >= 0; i--)
- AvARRAY(ary)[i] = Nullsv; /* don't free mere refs */
- }
- av_fill(ary,0); /* force allocation */
- av_fill(ary,-1);
- /* temporarily switch stacks */
- oldstack = stack;
- SWITCHSTACK(stack, ary);
- }
- base = SP - stack_base + 1;
- orig = s;
- if (pm->op_pmflags & PMf_SKIPWHITE) {
- while (isSPACE(*s))
- s++;
- }
- if (!limit)
- limit = maxiters + 2;
- if (strEQ("\\s+", rx->precomp)) {
- while (--limit) {
- /*SUPPRESS 530*/
- for (m = s; m < strend && !isSPACE(*m); m++) ;
- if (m >= strend)
- break;
- dstr = NEWSV(30, m-s);
- sv_setpvn(dstr, s, m-s);
- if (!realarray)
- sv_2mortal(dstr);
- XPUSHs(dstr);
- /*SUPPRESS 530*/
- for (s = m + 1; s < strend && 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 (!realarray)
- sv_2mortal(dstr);
- XPUSHs(dstr);
- s = m;
- }
- }
- else if (pm->op_pmshort) {
- i = SvCUR(pm->op_pmshort);
- if (i == 1) {
- I32 fold = (pm->op_pmflags & PMf_FOLD);
- i = *SvPVX(pm->op_pmshort);
- if (fold && isUPPER(i))
- i = tolower(i);
- while (--limit) {
- if (fold) {
- for ( m = s;
- m < strend && *m != i &&
- (!isUPPER(*m) || tolower(*m) != i);
- m++) /*SUPPRESS 530*/
- ;
+ 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 /*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 (!realarray)
- sv_2mortal(dstr);
- XPUSHs(dstr);
- s = m + 1;
- }
- }
- else {
-#ifndef lint
- while (s < strend && --limit &&
- (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
- pm->op_pmshort)) )
-#endif
- {
- dstr = NEWSV(31, m-s);
- sv_setpvn(dstr, s, m-s);
- if (!realarray)
- sv_2mortal(dstr);
- XPUSHs(dstr);
- s = m + i;
}
- }
- }
- else {
- maxiters += (strend - s) * rx->nparens;
- while (s < strend && --limit &&
- regexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) {
- if (rx->subbase
- && rx->subbase != orig) {
- m = s;
- s = orig;
- orig = rx->subbase;
- s = orig + (m - s);
- strend = s + (strend - m);
+ 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));
+ }
}
- m = rx->startp[0];
- dstr = NEWSV(32, m-s);
- sv_setpvn(dstr, s, m-s);
- if (!realarray)
- sv_2mortal(dstr);
- XPUSHs(dstr);
- if (rx->nparens) {
- for (i = 1; i <= rx->nparens; i++) {
- s = rx->startp[i];
- m = rx->endp[i];
- dstr = NEWSV(33, m-s);
- sv_setpvn(dstr, s, m-s);
- if (!realarray)
- sv_2mortal(dstr);
- XPUSHs(dstr);
+ 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;
}
}
- s = rx->endp[0];
- }
- }
- iters = (SP - stack_base) - base;
- if (iters > maxiters)
- DIE("Split loop");
- if (s < strend || origlimit) { /* keep field after final delim? */
- dstr = NEWSV(34, strend-s);
- sv_setpvn(dstr, s, strend-s);
- if (!realarray)
- sv_2mortal(dstr);
- XPUSHs(dstr);
- iters++;
- }
- else {
- while (iters > 0 && SvCUR(TOPs) == 0)
- iters--, SP--;
- }
- if (realarray) {
- SWITCHSTACK(ary, oldstack);
- if (gimme == G_ARRAY) {
- EXTEND(SP, iters);
- Copy(AvARRAY(ary), SP + 1, iters, SV*);
- SP += iters;
- RETURN;
- }
- }
- else {
- if (gimme == G_ARRAY)
- RETURN;
- }
- SP = stack_base + base;
- GETTARGET;
- PUSHi(iters);
- RETURN;
-}
-
-PP(pp_join)
-{
- dSP; dMARK; dTARGET;
- MARK++;
- do_join(TARG, *MARK, MARK, SP);
- SP = MARK;
- SETs(TARG);
- RETURN;
-}
-
-/* List operators. */
-
-PP(pp_list)
-{
- dSP; dMARK;
- if (GIMME != G_ARRAY) {
- if (++MARK <= SP)
- *MARK = *SP; /* unwanted list, return last item */
- else
- *MARK = &sv_undef;
- SP = MARK;
- }
- RETURN;
-}
-
-PP(pp_lslice)
-{
- dSP;
- SV **lastrelem = stack_sp;
- SV **lastlelem = stack_base + POPMARK;
- SV **firstlelem = stack_base + POPMARK + 1;
- register SV **firstrelem = lastlelem + 1;
- I32 lval = op->op_flags & OPf_LVAL;
- I32 is_something_there = lval;
-
- register I32 max = lastrelem - lastlelem;
- register SV **lelem;
- register I32 ix;
-
- if (GIMME != G_ARRAY) {
- ix = SvIVx(*lastlelem) - arybase;
- if (ix < 0 || ix >= max)
- *firstlelem = &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) - arybase;
- if (ix < 0) {
- ix += max;
- if (ix < 0)
- *lelem = &sv_undef;
- else if (!(*lelem = firstrelem[ix]))
- *lelem = &sv_undef;
- }
- else if (ix >= max || !(*lelem = firstrelem[ix]))
- *lelem = &sv_undef;
- if (!is_something_there && SvOK(*lelem))
- is_something_there = TRUE;
- }
- if (is_something_there)
- SP = lastlelem;
- else
- SP = firstlelem - 1;
- RETURN;
-}
-
-PP(pp_anonlist)
-{
- dSP; dMARK;
- I32 items = SP - MARK;
- SP = MARK;
- XPUSHs((SV*)av_make(items, MARK+1));
- RETURN;
-}
-
-PP(pp_anonhash)
-{
- dSP; dMARK; dORIGMARK;
- HV* hv = newHV();
- SvREFCNT(hv) = 0;
- while (MARK < SP) {
- SV* key = *++MARK;
- char *tmps;
- SV *val = NEWSV(46, 0);
- if (MARK < SP)
- sv_setsv(val, *++MARK);
- tmps = SvPVX(key);
- (void)hv_store(hv,tmps,SvCUROK(key),val,0);
- }
- SP = ORIGMARK;
- SvOK_on(hv);
- XPUSHs((SV*)hv);
- RETURN;
-}
-
-PP(pp_splice)
-{
- dSP; 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;
-
- SP++;
-
- if (++MARK < SP) {
- offset = SvIVx(*MARK);
- if (offset < 0)
- offset += AvFILL(ary) + 1;
- else
- offset -= arybase;
- if (++MARK < SP) {
- length = SvIVx(*MARK++);
- if (length < 0)
- length = 0;
- }
- else
- length = AvMAX(ary) + 1; /* close enough to infinity */
- }
- else {
- offset = 0;
- length = AvMAX(ary) + 1;
- }
- if (offset < 0) {
- length += offset;
- offset = 0;
- if (length < 0)
- length = 0;
- }
- if (offset > AvFILL(ary) + 1)
- offset = AvFILL(ary) + 1;
- after = AvFILL(ary) + 1 - (offset + length);
- if (after < 0) { /* not that much array */
- length += after; /* offset+length now in array */
- after = 0;
- if (!AvALLOC(ary)) {
- av_fill(ary, 0);
- av_fill(ary, -1);
- }
- }
-
- /* At this point, MARK .. SP-1 is our new LIST */
-
- newlen = SP - MARK;
- diff = newlen - length;
-
- 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)) {
- for (i = length, dst = MARK; i; i--)
- sv_2mortal(*dst++); /* free them eventualy */
- }
- 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 */
- }
- }
- AvFILL(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--;
- }
- Zero(AvARRAY(ary), -diff, SV*);
- 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*);
- }
- Zero(&AvARRAY(ary)[AvFILL(ary)+1], -diff, SV*);
- /* avoid later double free */
- }
- 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;
- AvFILL(ary) += diff;
- }
else {
- if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */
- av_store(ary, AvFILL(ary) + diff, Nullsv);
- else
- AvFILL(ary) += diff;
- dst = AvARRAY(ary) + AvFILL(ary);
- for (i = diff; i > 0; i--) {
- if (*dst) /* stuff was hanging around */
- SvREFCNT_dec(*dst); /* after $#foo */
- dst--;
- }
- if (after) {
- dst = AvARRAY(ary) + AvFILL(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)) {
- for (i = length, dst = MARK; i; i--)
- sv_2mortal(*dst++); /* free them eventualy */
- }
- 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 = &sv_undef;
- }
- SP = MARK;
- RETURN;
-}
-
-PP(pp_push)
-{
- dSP; dMARK; dORIGMARK; dTARGET;
- register AV *ary = (AV*)*++MARK;
- register SV *sv = &sv_undef;
-
- for (++MARK; MARK <= SP; MARK++) {
- sv = NEWSV(51, 0);
- if (*MARK)
- sv_setsv(sv, *MARK);
- (void)av_push(ary, sv);
- }
- SP = ORIGMARK;
- PUSHi( AvFILL(ary) + 1 );
- RETURN;
-}
-
-PP(pp_pop)
-{
- dSP;
- AV *av = (AV*)POPs;
- SV *sv = av_pop(av);
- if (!sv)
- RETPUSHUNDEF;
- if (AvREAL(av))
- (void)sv_2mortal(sv);
- PUSHs(sv);
- RETURN;
-}
-
-PP(pp_shift)
-{
- dSP;
- 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)
-{
- dSP; dMARK; dORIGMARK; dTARGET;
- register AV *ary = (AV*)*++MARK;
- register SV *sv;
- register I32 i = 0;
-
- 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_grepstart)
-{
- dSP;
- SV *src;
-
- if (stack_base + *markstack_ptr == sp) {
- POPMARK;
- RETURNOP(op->op_next->op_next);
- }
- stack_sp = stack_base + *markstack_ptr + 1;
- pp_pushmark(); /* push dst */
- pp_pushmark(); /* push src */
- ENTER; /* enter outer scope */
-
- SAVETMPS;
- SAVESPTR(GvSV(defgv));
-
- ENTER; /* enter inner scope */
- SAVESPTR(curpm);
-
- if (src = stack_base[*markstack_ptr]) {
- SvTEMP_off(src);
- GvSV(defgv) = src;
- }
- else
- GvSV(defgv) = sv_newmortal();
-
- RETURNOP(((LOGOP*)op->op_next)->op_other);
-}
-
-PP(pp_grepwhile)
-{
- dSP;
-
- if (SvTRUEx(POPs))
- stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr];
- ++*markstack_ptr;
- LEAVE; /* exit inner scope */
-
- /* All done yet? */
- if (stack_base + *markstack_ptr > sp) {
- I32 items;
-
- LEAVE; /* exit outer scope */
- POPMARK; /* pop src */
- items = --*markstack_ptr - markstack_ptr[-1];
- POPMARK; /* pop dst */
- SP = stack_base + POPMARK; /* pop original mark */
- if (GIMME != G_ARRAY) {
- dTARGET;
- XPUSHi(items);
- RETURN;
- }
- SP += items;
- RETURN;
- }
- else {
- SV *src;
-
- ENTER; /* enter inner scope */
- SAVESPTR(curpm);
-
- if (src = stack_base[*markstack_ptr]) {
- SvTEMP_off(src);
- GvSV(defgv) = src;
- }
- else
- GvSV(defgv) = sv_newmortal();
-
- RETURNOP(cLOGOP->op_other);
- }
-}
-
-static int sortcmp();
-static int sortcv();
-
-PP(pp_sort)
-{
- dSP; dMARK; dORIGMARK;
- register SV **up;
- SV **myorigmark = ORIGMARK;
- register I32 max;
- register I32 i;
- HV *stash;
- SV *sortcvvar;
- GV *gv;
- CV *cv;
-
- if (GIMME != G_ARRAY) {
- SP = MARK;
- RETPUSHUNDEF;
- }
-
- if (op->op_flags & OPf_STACKED) {
- if (op->op_flags & OPf_SPECIAL) {
- OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
- kid = kUNOP->op_first; /* pass rv2gv */
- kid = kUNOP->op_first; /* pass leave */
- sortcop = kid->op_next;
- stash = curcop->cop_stash;
- }
- else {
- cv = sv_2cv(*++MARK, &stash, &gv, 0);
- if (!(cv && CvROOT(cv))) {
- if (gv) {
- SV *tmpstr = sv_newmortal();
- gv_efullname(tmpstr, gv);
- if (CvUSERSUB(cv))
- DIE("Usersub \"%s\" called in sort", SvPVX(tmpstr));
- DIE("Undefined sort subroutine \"%s\" called",
- SvPVX(tmpstr));
- }
- if (cv) {
- if (CvUSERSUB(cv))
- DIE("Usersub called in sort");
- DIE("Undefined subroutine in sort");
- }
- DIE("Not a subroutine reference in sort");
- }
- sortcop = CvSTART(cv);
- SAVESPTR(CvROOT(cv)->op_ppaddr);
- CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
- }
- }
- else {
- sortcop = Nullop;
- stash = curcop->cop_stash;
- }
-
- up = myorigmark + 1;
- while (MARK < SP) { /* This may or may not shift down one here. */
- /*SUPPRESS 560*/
- if (*up = *++MARK) { /* Weed out nulls. */
- if (!SvPOK(*up))
- (void)sv_2pv(*up, &na);
- else
- SvTEMP_off(*up);
- up++;
- }
- }
- max = --up - myorigmark;
- if (max > 1) {
- if (sortcop) {
- AV *oldstack;
-
- ENTER;
- SAVETMPS;
- SAVESPTR(op);
-
- oldstack = stack;
- if (!sortstack) {
- sortstack = newAV();
- av_store(sortstack, 32, Nullsv);
- av_clear(sortstack);
- AvREAL_off(sortstack);
- }
- SWITCHSTACK(stack, sortstack);
- if (sortstash != stash) {
- firstgv = gv_fetchpv("a", TRUE);
- secondgv = gv_fetchpv("b", TRUE);
- sortstash = stash;
- }
-
- SAVESPTR(GvSV(firstgv));
- SAVESPTR(GvSV(secondgv));
-
- qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv);
-
- SWITCHSTACK(sortstack, oldstack);
-
- LEAVE;
- }
- else {
- MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
- qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp);
- }
- }
- SP = ORIGMARK + max;
- RETURN;
-}
-
-PP(pp_reverse)
-{
- dSP; 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, &sv_no, MARK, SP);
- else
- sv_setsv(TARG, *SP);
- up = SvPV(TARG, len);
- if (len > 1) {
- down = SvPVX(TARG) + len - 1;
- while (down > up) {
- tmp = *up;
- *up++ = *down;
- *down-- = tmp;
- }
- SvPOK_only(TARG);
- }
- SP = MARK + 1;
- SETTARG;
- }
- RETURN;
-}
-
-/* Range stuff. */
-
-PP(pp_range)
-{
- if (GIMME == G_ARRAY)
- return cCONDOP->op_true;
- return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
-}
-
-PP(pp_flip)
-{
- dSP;
-
- if (GIMME == G_ARRAY) {
- RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
- }
- else {
- dTOPss;
- SV *targ = PAD_SV(op->op_targ);
-
- if ((op->op_private & OPpFLIP_LINENUM)
- ? last_in_gv && SvIV(sv) == IoLINES(GvIO(last_in_gv))
- : SvTRUE(sv) ) {
- sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
- if (op->op_flags & OPf_SPECIAL) {
- sv_setiv(targ, 1);
- RETURN;
- }
- else {
- sv_setiv(targ, 0);
- sp--;
- RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
- }
- }
- sv_setpv(TARG, "");
- SETs(targ);
- RETURN;
- }
-}
-
-PP(pp_flop)
-{
- dSP;
-
- if (GIMME == G_ARRAY) {
- dPOPPOPssrl;
- register I32 i;
- register SV *sv;
- I32 max;
-
- if (SvNIOK(lstr) || !SvPOK(lstr) ||
- (looks_like_number(lstr) && *SvPVX(lstr) != '0') ) {
- i = SvIV(lstr);
- max = SvIV(rstr);
- if (max > i)
- EXTEND(SP, max - i + 1);
- while (i <= max) {
- sv = sv_mortalcopy(&sv_no);
- sv_setiv(sv,i++);
- PUSHs(sv);
- }
- }
- else {
- SV *final = sv_mortalcopy(rstr);
- STRLEN len;
- char *tmps = SvPV(final, len);
-
- sv = sv_mortalcopy(lstr);
- while (!SvNIOK(sv) && SvCUR(sv) <= len &&
- strNE(SvPVX(sv),tmps) ) {
- XPUSHs(sv);
- sv = sv_2mortal(newSVsv(sv));
- sv_inc(sv);
- }
- if (strEQ(SvPVX(sv),tmps))
- XPUSHs(sv);
- }
- }
- else {
- dTOPss;
- SV *targ = PAD_SV(cUNOP->op_first->op_targ);
- sv_inc(targ);
- if ((op->op_private & OPpFLIP_LINENUM)
- ? last_in_gv && SvIV(sv) == IoLINES(GvIO(last_in_gv))
- : SvTRUE(sv) ) {
- sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
- sv_catpv(targ, "E0");
- }
- SETs(targ);
- }
-
- RETURN;
-}
-
-/* Control. */
-
-static I32
-dopoptolabel(label)
-char *label;
-{
- register I32 i;
- register CONTEXT *cx;
-
- for (i = cxstack_ix; i >= 0; i--) {
- cx = &cxstack[i];
- switch (cx->cx_type) {
- case CXt_SUBST:
- if (dowarn)
- warn("Exiting substitution via %s", op_name[op->op_type]);
- break;
- case CXt_SUB:
- if (dowarn)
- warn("Exiting subroutine via %s", op_name[op->op_type]);
- break;
- case CXt_EVAL:
- if (dowarn)
- warn("Exiting eval via %s", op_name[op->op_type]);
- break;
- case CXt_LOOP:
- if (!cx->blk_loop.label ||
- strNE(label, cx->blk_loop.label) ) {
- DEBUG_l(deb("(Skipping label #%d %s)\n",
- i, cx->blk_loop.label));
- continue;
- }
- DEBUG_l( deb("(Found label #%d %s)\n", i, label));
- return i;
- }
- }
-}
-
-static I32
-dopoptosub(startingblock)
-I32 startingblock;
-{
- I32 i;
- register CONTEXT *cx;
- for (i = startingblock; i >= 0; i--) {
- cx = &cxstack[i];
- switch (cx->cx_type) {
- default:
- continue;
- case CXt_EVAL:
- case CXt_SUB:
- DEBUG_l( deb("(Found sub #%d)\n", i));
- return i;
- }
- }
- return i;
-}
-
-I32
-dopoptoeval(startingblock)
-I32 startingblock;
-{
- I32 i;
- register CONTEXT *cx;
- for (i = startingblock; i >= 0; i--) {
- cx = &cxstack[i];
- switch (cx->cx_type) {
- default:
- continue;
- case CXt_EVAL:
- DEBUG_l( deb("(Found eval #%d)\n", i));
- return i;
- }
- }
- return i;
-}
-
-static I32
-dopoptoloop(startingblock)
-I32 startingblock;
-{
- I32 i;
- register CONTEXT *cx;
- for (i = startingblock; i >= 0; i--) {
- cx = &cxstack[i];
- switch (cx->cx_type) {
- case CXt_SUBST:
- if (dowarn)
- warn("Exiting substitition via %s", op_name[op->op_type]);
- break;
- case CXt_SUB:
- if (dowarn)
- warn("Exiting subroutine via %s", op_name[op->op_type]);
- break;
- case CXt_EVAL:
- if (dowarn)
- warn("Exiting eval via %s", op_name[op->op_type]);
- break;
- case CXt_LOOP:
- DEBUG_l( deb("(Found loop #%d)\n", i));
- return i;
- }
- }
- return i;
-}
-
-static void
-dounwind(cxix)
-I32 cxix;
-{
- register CONTEXT *cx;
- SV **newsp;
- I32 optype;
-
- while (cxstack_ix > cxix) {
- cx = &cxstack[cxstack_ix--];
- DEBUG_l(fprintf(stderr, "Unwinding block %d, type %s\n", cxstack_ix+1,
- block_type[cx->cx_type]));
- /* Note: we don't need to restore the base context info till the end. */
- switch (cx->cx_type) {
- case CXt_SUB:
- POPSUB(cx);
- break;
- case CXt_EVAL:
- POPEVAL(cx);
- break;
- case CXt_LOOP:
- POPLOOP(cx);
- break;
- case CXt_SUBST:
- break;
- }
- }
-}
-
-#ifdef STANDARD_C
-OP *
-die(char* pat, ...)
-#else
-/*VARARGS0*/
-OP *
-die(pat, va_alist)
- char *pat;
- va_dcl
-#endif
-{
- va_list args;
- char *tmps;
- char *message;
- OP *retop;
-
-#ifdef STANDARD_C
- va_start(args, pat);
-#else
- va_start(args);
-#endif
- message = mess(pat, &args);
- va_end(args);
- restartop = die_where(message);
- if (stack != mainstack)
- longjmp(top_env, 3);
- return restartop;
-}
-
-OP *
-die_where(message)
-char *message;
-{
- if (in_eval) {
- I32 cxix;
- register CONTEXT *cx;
- I32 gimme;
- SV **newsp;
-
- sv_setpv(GvSV(gv_fetchpv("@",TRUE)),message);
- cxix = dopoptoeval(cxstack_ix);
- if (cxix >= 0) {
- I32 optype;
-
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- POPBLOCK(cx);
- if (cx->cx_type != CXt_EVAL) {
- fprintf(stderr, "panic: die %s", message);
- my_exit(1);
- }
- POPEVAL(cx);
-
- if (gimme == G_SCALAR)
- *++newsp = &sv_undef;
- stack_sp = newsp;
-
- LEAVE;
- if (optype == OP_REQUIRE)
- DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE)), na));
- return pop_return();
- }
- }
- fputs(message, stderr);
- (void)fflush(stderr);
- if (e_fp)
- (void)UNLINK(e_tmpname);
- statusvalue >>= 8;
- my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
- return 0;
-}
-
-PP(pp_and)
-{
- dSP;
- if (!SvTRUE(TOPs))
- RETURN;
- else {
- --SP;
- RETURNOP(cLOGOP->op_other);
- }
-}
-
-PP(pp_or)
-{
- dSP;
- if (SvTRUE(TOPs))
- RETURN;
- else {
- --SP;
- RETURNOP(cLOGOP->op_other);
- }
-}
-
-PP(pp_cond_expr)
-{
- dSP;
- if (SvTRUEx(POPs))
- RETURNOP(cCONDOP->op_true);
- else
- RETURNOP(cCONDOP->op_false);
-}
-
-PP(pp_andassign)
-{
- dSP;
- if (!SvTRUE(TOPs))
- RETURN;
- else
- RETURNOP(cLOGOP->op_other);
-}
-
-PP(pp_orassign)
-{
- dSP;
- if (SvTRUE(TOPs))
- RETURN;
- else
- RETURNOP(cLOGOP->op_other);
-}
-
-PP(pp_method)
-{
- dSP; dPOPss;
- SV* ob;
- GV* gv;
-
- EXTEND(sp,2);
-
- gv = 0;
- if (SvROK(sv))
- ob = SvRV(sv);
- else {
- GV* iogv;
- IO* io;
-
- if (!SvOK(sv) ||
- !(iogv = gv_fetchpv(SvPVX(sv), FALSE)) ||
- !(ob=(SV*)GvIO(iogv)))
- {
- char *name = SvPVX(((SVOP*)cLOGOP->op_other)->op_sv);
- char tmpbuf[256];
- char* packname = SvPV(sv, na);
- HV *stash;
- if (!isALPHA(*packname))
-DIE("Can't call method \"%s\" without a package or object reference", name);
- if (!(stash = fetch_stash(sv, FALSE)))
- DIE("Can't call method \"%s\" in empty package \"%s\"",
- name, packname);
- gv = gv_fetchmethod(stash,name);
- if (!gv)
- DIE("Can't locate object method \"%s\" via package \"%s\"",
- name, packname);
- PUSHs(gv);
- PUSHs(sv);
- RETURN;
- }
- }
-
- if (!ob || !SvOBJECT(ob)) {
- char *name = SvPVX(((SVOP*)cLOGOP->op_other)->op_sv);
- DIE("Can't call method \"%s\" on unblessed reference", name);
- }
-
- if (!gv) { /* nothing cached */
- char *name = SvPVX(((SVOP*)cLOGOP->op_other)->op_sv);
- gv = gv_fetchmethod(SvSTASH(ob),name);
- if (!gv)
- DIE("Can't locate object method \"%s\" via package \"%s\"",
- name, HvNAME(SvSTASH(ob)));
- }
-
- PUSHs(gv);
- PUSHs(sv);
- RETURN;
-}
-
-PP(pp_entersubr)
-{
- dSP; dMARK;
- SV *sv = *++MARK;
- GV *gv;
- HV *stash;
- register CV *cv;
- register I32 items = SP - MARK;
- I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
- register CONTEXT *cx;
-
- if (!sv)
- DIE("Not a subroutine reference");
- switch (SvTYPE(sv)) {
- default:
- if (!SvROK(sv)) {
- if (!SvOK(sv))
- DIE(no_usym, "a subroutine");
- gv = gv_fetchpv(SvPV(sv, na), FALSE);
- if (!gv)
- cv = 0;
- else
- cv = GvCV(gv);
- break;
- }
- /* FALL THROUGH */
- case SVt_RV:
- cv = (CV*)SvRV(sv);
- if (SvTYPE(cv) == SVt_PVCV)
- break;
- /* FALL THROUGH */
- case SVt_PVHV:
- case SVt_PVAV:
- DIE("Not a subroutine reference");
- case SVt_PVCV:
- cv = (CV*)sv;
- break;
- case SVt_PVGV:
- if (!(cv = GvCV((GV*)sv)))
- cv = sv_2cv(sv, &stash, &gv, TRUE);
- break;
- }
-
- ENTER;
- SAVETMPS;
-
- retry:
- if (!cv)
- DIE("Not a subroutine reference");
-
- if (!CvROOT(cv) && !CvUSERSUB(cv)) {
- if (gv = CvGV(cv)) {
- SV *tmpstr = sv_newmortal();
- GV *ngv;
- gv_efullname(tmpstr, gv);
- ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD");
- if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */
- gv = ngv;
- sv_setsv(GvSV(gv), tmpstr);
- goto retry;
- }
- else
- DIE("Undefined subroutine &%s called",SvPVX(tmpstr));
- }
- DIE("Undefined subroutine called");
- }
-
- if ((op->op_private & OPpSUBR_DB) && !CvUSERSUB(cv)) {
- sv = GvSV(DBsub);
- save_item(sv);
- gv = CvGV(cv);
- gv_efullname(sv,gv);
- cv = GvCV(DBsub);
- if (!cv)
- DIE("No DBsub routine");
- }
-
- if (CvUSERSUB(cv)) {
- items = (*CvUSERSUB(cv))(CvUSERINDEX(cv), MARK - stack_base, items);
- sp = stack_base + items;
- LEAVE;
- RETURN;
- }
- else {
- I32 gimme = GIMME;
- AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
- push_return(op->op_next);
- PUSHBLOCK(cx, CXt_SUB, MARK - 1);
- PUSHSUB(cx);
- CvDEPTH(cv)++;
- if (CvDEPTH(cv) >= 2) { /* save temporaries on recursion? */
- if (CvDEPTH(cv) == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv)));
- if (CvDEPTH(cv) > AvFILL(padlist)) {
- AV *newpad = newAV();
- I32 ix = AvFILL((AV*)svp[1]);
- svp = AvARRAY(svp[0]);
- while (ix > 0) {
- if (svp[ix]) {
- char *name = SvPVX(svp[ix]); /* XXX */
- if (*name == '@')
- av_store(newpad, ix--, (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix--, (SV*)newHV());
- else
- av_store(newpad, ix--, NEWSV(0,0));
- }
- else
- av_store(newpad, ix--, NEWSV(0,0));
- }
- if (hasargs) {
- AV* av = newAV();
- av_store(av, 0, Nullsv);
- av_store(newpad, 0, (SV*)av);
- SvOK_on(av);
- AvREAL_off(av);
- }
- av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILL(padlist) = CvDEPTH(cv);
- svp = AvARRAY(padlist);
- }
- }
- SAVESPTR(curpad);
- curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
- if (hasargs) {
- AV* av = (AV*)curpad[0];
- SV** ary;
-
- cx->blk_sub.savearray = GvAV(defgv);
- cx->blk_sub.argarray = av;
- GvAV(defgv) = cx->blk_sub.argarray;
- ++MARK;
-
- if (items >= AvMAX(av)) {
- ary = AvALLOC(av);
- if (AvARRAY(av) != ary) {
- AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPVX(av) = (char*)ary;
- }
- if (items >= AvMAX(av)) {
- AvMAX(av) = items - 1;
- Renew(ary,items+1,SV*);
- AvALLOC(av) = ary;
- SvPVX(av) = (char*)ary;
- }
- }
- Copy(MARK,AvARRAY(av),items,SV*);
- AvFILL(av) = items - 1;
- while (items--) {
- if (*MARK)
- SvTEMP_off(*MARK);
- MARK++;
- }
- }
- RETURNOP(CvSTART(cv));
- }
-}
-
-PP(pp_leavesubr)
-{
- dSP;
- SV **mark;
- SV **newsp;
- I32 gimme;
- register CONTEXT *cx;
-
- POPBLOCK(cx);
- POPSUB(cx);
-
- if (gimme == G_SCALAR) {
- MARK = newsp + 1;
- if (MARK <= SP)
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- else {
- MEXTEND(mark,0);
- *MARK = &sv_undef;
- }
- SP = MARK;
- }
- else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
- *mark = sv_mortalcopy(*mark);
- /* in case LEAVE wipes old return values */
- }
-
- LEAVE;
- PUTBACK;
- return pop_return();
-}
-
-PP(pp_done)
-{
- return pop_return();
-}
-
-PP(pp_caller)
-{
- dSP;
- register I32 cxix = dopoptosub(cxstack_ix);
- I32 nextcxix;
- register CONTEXT *cx;
- SV *sv;
- I32 count = 0;
-
- if (MAXARG)
- count = POPi;
- EXTEND(SP, 6);
- for (;;) {
- if (cxix < 0) {
- if (GIMME != G_ARRAY)
- RETPUSHUNDEF;
- RETURN;
- }
- nextcxix = dopoptosub(cxix - 1);
- if (DBsub && nextcxix >= 0 &&
- cxstack[nextcxix].blk_sub.cv == GvCV(DBsub))
- count++;
- if (!count--)
- break;
- cxix = nextcxix;
- }
- cx = &cxstack[cxix];
- if (GIMME != G_ARRAY) {
- dTARGET;
-
- sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash));
- PUSHs(TARG);
- RETURN;
- }
-
- PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0)));
- PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
- if (!MAXARG)
- RETURN;
- if (cx->cx_type == CXt_SUB) {
- sv = NEWSV(49, 0);
- gv_efullname(sv, CvGV(cx->blk_sub.cv));
- PUSHs(sv_2mortal(sv));
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
- }
- else {
- PUSHs(sv_2mortal(newSVpv("(eval)",0)));
- PUSHs(sv_2mortal(newSViv(0)));
- }
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme)));
- if (cx->blk_sub.hasargs && curstash == debstash) {
- AV *ary = cx->blk_sub.argarray;
-
- if (!dbargs) {
- GV* tmpgv;
- dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE)));
- SvMULTI_on(tmpgv);
- AvREAL_off(dbargs);
- }
- if (AvMAX(dbargs) < AvFILL(ary))
- av_store(dbargs, AvFILL(ary), Nullsv);
- Copy(AvARRAY(ary), AvARRAY(dbargs), AvFILL(ary)+1, SV*);
- AvFILL(dbargs) = AvFILL(ary);
- }
- RETURN;
-}
-
-static I32
-sortcv(str1, str2)
-SV **str1;
-SV **str2;
-{
- I32 oldscopeix = scopestack_ix;
- I32 result;
- GvSV(firstgv) = *str1;
- GvSV(secondgv) = *str2;
- stack_sp = stack_base;
- op = sortcop;
- run();
- result = SvIVx(AvARRAY(stack)[1]);
- while (scopestack_ix > oldscopeix) {
- LEAVE;
- }
- return result;
-}
-
-static I32
-sortcmp(strp1, strp2)
-SV **strp1;
-SV **strp2;
-{
- register SV *str1 = *strp1;
- register SV *str2 = *strp2;
- I32 retval;
-
- if (SvCUR(str1) < SvCUR(str2)) {
- /*SUPPRESS 560*/
- if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1)))
- return retval;
- else
- return -1;
- }
- /*SUPPRESS 560*/
- else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2)))
- return retval;
- else if (SvCUR(str1) == SvCUR(str2))
- return 0;
- else
- return 1;
-}
-
-PP(pp_warn)
-{
- dSP; dMARK;
- char *tmps;
- if (SP - MARK != 1) {
- dTARGET;
- do_join(TARG, &sv_no, MARK, SP);
- tmps = SvPV(TARG, na);
- SP = MARK + 1;
- }
- else {
- tmps = SvPV(TOPs, na);
- }
- if (!tmps || !*tmps) {
- SV *error = GvSV(gv_fetchpv("@", TRUE));
- SvUPGRADE(error, SVt_PV);
- if (SvPOK(error) && SvCUR(error))
- sv_catpv(error, "\t...caught");
- tmps = SvPV(error, na);
- }
- if (!tmps || !*tmps)
- tmps = "Warning: something's wrong";
- warn("%s", tmps);
- RETSETYES;
-}
-
-PP(pp_die)
-{
- dSP; dMARK;
- char *tmps;
- if (SP - MARK != 1) {
- dTARGET;
- do_join(TARG, &sv_no, MARK, SP);
- tmps = SvPV(TARG, na);
- SP = MARK + 1;
- }
- else {
- tmps = SvPV(TOPs, na);
- }
- if (!tmps || !*tmps) {
- SV *error = GvSV(gv_fetchpv("@", TRUE));
- SvUPGRADE(error, SVt_PV);
- if (SvPOK(error) && SvCUR(error))
- sv_catpv(error, "\t...propagated");
- tmps = SvPV(error, na);
- }
- if (!tmps || !*tmps)
- tmps = "Died";
- DIE("%s", tmps);
-}
-
-PP(pp_reset)
-{
- dSP;
- double value;
- char *tmps;
-
- if (MAXARG < 1)
- tmps = "";
- else
- tmps = POPp;
- sv_reset(tmps, curcop->cop_stash);
- PUSHs(&sv_yes);
- RETURN;
-}
-
-PP(pp_lineseq)
-{
- return NORMAL;
-}
-
-PP(pp_nextstate)
-{
- curcop = (COP*)op;
- TAINT_NOT; /* Each statement is presumed innocent */
- stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
- FREE_TMPS();
- return NORMAL;
-}
-
-PP(pp_dbstate)
-{
- curcop = (COP*)op;
- TAINT_NOT; /* Each statement is presumed innocent */
- stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
- FREE_TMPS();
-
- if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
- {
- SV **sp;
- register CV *cv;
- register CONTEXT *cx;
- I32 gimme = GIMME;
- I32 hasargs;
- GV *gv;
-
- ENTER;
- SAVETMPS;
-
- SAVEI32(debug);
- debug = 0;
- hasargs = 0;
- gv = DBgv;
- cv = GvCV(gv);
- sp = stack_sp;
- *++sp = Nullsv;
-
- if (!cv)
- DIE("No DB::DB routine defined");
-
- if (CvDEPTH(cv) >= 1) /* don't do recursive DB::DB call */
- return NORMAL;
- push_return(op->op_next);
- PUSHBLOCK(cx, CXt_SUB, sp - 1);
- PUSHSUB(cx);
- CvDEPTH(cv)++;
- SAVESPTR(curpad);
- curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
- RETURNOP(CvSTART(cv));
- }
- else
- return NORMAL;
-}
-
-PP(pp_unstack)
-{
- I32 oldsave;
- TAINT_NOT; /* Each statement is presumed innocent */
- stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
- FREE_TMPS();
- oldsave = scopestack[scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
- return NORMAL;
-}
-
-PP(pp_enter)
-{
- dSP;
- register CONTEXT *cx;
- I32 gimme = GIMME;
- ENTER;
-
- SAVETMPS;
- PUSHBLOCK(cx, CXt_BLOCK, sp);
-
- RETURN;
-}
-
-PP(pp_leave)
-{
- dSP;
- register CONTEXT *cx;
- register SV **mark;
- SV **newsp;
- I32 gimme;
-
- POPBLOCK(cx);
-
- if (GIMME == G_SCALAR) {
- MARK = newsp + 1;
- if (MARK <= SP)
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- else {
- MEXTEND(mark,0);
- *MARK = &sv_undef;
- }
- SP = MARK;
- }
- else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
- *mark = sv_mortalcopy(*mark);
- /* in case LEAVE wipes old return values */
- }
-
- LEAVE;
-
- RETURN;
-}
-
-PP(pp_scope)
-{
- return NORMAL;
-}
-
-PP(pp_enteriter)
-{
- dSP; dMARK;
- register CONTEXT *cx;
- SV **svp = &GvSV((GV*)POPs);
- I32 gimme = GIMME;
-
- ENTER;
- SAVETMPS;
- ENTER;
-
- PUSHBLOCK(cx, CXt_LOOP, SP);
- PUSHLOOP(cx, svp, MARK);
- cx->blk_loop.iterary = stack;
- cx->blk_loop.iterix = MARK - stack_base;
-
- RETURN;
-}
-
-PP(pp_iter)
-{
- dSP;
- register CONTEXT *cx;
- SV *sv;
-
- EXTEND(sp, 1);
- cx = &cxstack[cxstack_ix];
- if (cx->cx_type != CXt_LOOP)
- DIE("panic: pp_iter");
-
- if (cx->blk_loop.iterix >= cx->blk_oldsp)
- RETPUSHNO;
-
- if (sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix]) {
- SvTEMP_off(sv);
- *cx->blk_loop.itervar = sv;
- }
- else
- *cx->blk_loop.itervar = &sv_undef;
-
- RETPUSHYES;
-}
-
-PP(pp_enterloop)
-{
- dSP;
- register CONTEXT *cx;
- I32 gimme = GIMME;
-
- ENTER;
- SAVETMPS;
- ENTER;
-
- PUSHBLOCK(cx, CXt_LOOP, SP);
- PUSHLOOP(cx, 0, SP);
-
- RETURN;
-}
-
-PP(pp_leaveloop)
-{
- dSP;
- register CONTEXT *cx;
- I32 gimme;
- SV **newsp;
- SV **mark;
-
- POPBLOCK(cx);
- mark = newsp;
- POPLOOP(cx);
- if (gimme == G_SCALAR) {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
- else
- *++newsp = &sv_undef;
- }
- else {
- while (mark < SP)
- *++newsp = sv_mortalcopy(*++mark);
- }
- sp = newsp;
- LEAVE;
- LEAVE;
-
- RETURN;
-}
-
-PP(pp_return)
-{
- dSP; dMARK;
- I32 cxix;
- register CONTEXT *cx;
- I32 gimme;
- SV **newsp;
- I32 optype = 0;
-
- if (stack == sortstack) {
- AvARRAY(stack)[1] = *SP;
- return 0;
- }
-
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- DIE("Can't return outside a subroutine");
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- POPBLOCK(cx);
- switch (cx->cx_type) {
- case CXt_SUB:
- POPSUB(cx);
- break;
- case CXt_EVAL:
- POPEVAL(cx);
- break;
- default:
- DIE("panic: return");
- break;
- }
-
- if (gimme == G_SCALAR) {
- if (MARK < SP)
- *++newsp = sv_mortalcopy(*SP);
- else
- *++newsp = &sv_undef;
- if (optype == OP_REQUIRE && !SvTRUE(*newsp))
- DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE)), na));
- }
- else {
- if (optype == OP_REQUIRE && MARK == SP)
- DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE)), na));
- while (MARK < SP)
- *++newsp = sv_mortalcopy(*++MARK);
- }
- stack_sp = newsp;
-
- LEAVE;
- return pop_return();
-}
-
-PP(pp_last)
-{
- dSP;
- I32 cxix;
- register CONTEXT *cx;
- I32 gimme;
- I32 optype;
- OP *nextop;
- SV **newsp;
- SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
- /* XXX The sp is probably not right yet... */
-
- if (op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- DIE("Can't \"last\" outside a block");
- }
- else {
- cxix = dopoptolabel(cPVOP->op_pv);
- if (cxix < 0)
- DIE("Label not found for \"last %s\"", cPVOP->op_pv);
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- POPBLOCK(cx);
- switch (cx->cx_type) {
- case CXt_LOOP:
- POPLOOP(cx);
- nextop = cx->blk_loop.last_op->op_next;
- LEAVE;
- break;
- case CXt_EVAL:
- POPEVAL(cx);
- nextop = pop_return();
- break;
- case CXt_SUB:
- POPSUB(cx);
- nextop = pop_return();
- break;
- default:
- DIE("panic: last");
- break;
- }
-
- if (gimme == G_SCALAR) {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
- else
- *++newsp = &sv_undef;
- }
- else {
- while (mark < SP)
- *++newsp = sv_mortalcopy(*++mark);
- }
- sp = newsp;
-
- LEAVE;
- RETURNOP(nextop);
-}
-
-PP(pp_next)
-{
- dSP;
- I32 cxix;
- register CONTEXT *cx;
- I32 oldsave;
-
- if (op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- DIE("Can't \"next\" outside a block");
- }
- else {
- cxix = dopoptolabel(cPVOP->op_pv);
- if (cxix < 0)
- DIE("Label not found for \"next %s\"", cPVOP->op_pv);
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- TOPBLOCK(cx);
- oldsave = scopestack[scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
- return cx->blk_loop.next_op;
-}
-
-PP(pp_redo)
-{
- dSP;
- I32 cxix;
- register CONTEXT *cx;
- I32 oldsave;
-
- if (op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- DIE("Can't \"redo\" outside a block");
- }
- else {
- cxix = dopoptolabel(cPVOP->op_pv);
- if (cxix < 0)
- DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
- }
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- TOPBLOCK(cx);
- oldsave = scopestack[scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
- return cx->blk_loop.redo_op;
-}
-
-static OP* lastgotoprobe;
-
-OP *
-dofindlabel(op,label,opstack)
-OP *op;
-char *label;
-OP **opstack;
-{
- OP *kid;
- OP **ops = opstack;
-
- if (op->op_type == OP_LEAVE ||
- op->op_type == OP_SCOPE ||
- op->op_type == OP_LEAVELOOP ||
- op->op_type == OP_LEAVETRY)
- *ops++ = cUNOP->op_first;
- *ops = 0;
- if (op->op_flags & OPf_KIDS) {
- /* First try all the kids at this level, since that's likeliest. */
- for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
- if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
- kCOP->cop_label && strEQ(kCOP->cop_label, label))
- return kid;
- }
- for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
- if (kid == lastgotoprobe)
- continue;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
- if (ops > opstack &&
- (ops[-1]->op_type == OP_NEXTSTATE ||
- ops[-1]->op_type == OP_DBSTATE))
- *ops = kid;
- else
- *ops++ = kid;
- }
- if (op = dofindlabel(kid,label,ops))
- return op;
- }
- }
- *ops = 0;
- return 0;
-}
-
-PP(pp_dump)
-{
- return pp_goto(ARGS);
- /*NOTREACHED*/
-}
-
-PP(pp_goto)
-{
- dSP;
- OP *retop = 0;
- I32 ix;
- register CONTEXT *cx;
- I32 entering = 0;
- OP *enterops[64];
- char *label;
-
- label = 0;
- if (op->op_flags & OPf_STACKED) {
- SV *sv = POPs;
-
- /* This egregious kludge implements goto &subroutine */
- if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
- I32 cxix;
- register CONTEXT *cx;
- CV* cv = (CV*)SvRV(sv);
- SV** mark;
- I32 items = 0;
- I32 oldsave;
-
- /* First do some returnish stuff. */
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- DIE("Can't goto subroutine outside a subroutine");
- if (cxix < cxstack_ix)
- dounwind(cxix);
- TOPBLOCK(cx);
- mark = ++stack_sp;
- *stack_sp = (SV*)cv;
- if (cx->blk_sub.hasargs) { /* put @_ back onto stack */
- items = AvFILL(cx->blk_sub.argarray) + 1;
- Copy(AvARRAY(cx->blk_sub.argarray), ++stack_sp, items, SV*);
- stack_sp += items;
- GvAV(defgv) = cx->blk_sub.savearray;
- }
- if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) {
- if (CvDELETED(cx->blk_sub.cv))
- SvREFCNT_dec(cx->blk_sub.cv);
- }
- oldsave = scopestack[scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
-
- /* Now do some callish stuff. */
- if (CvUSERSUB(cv)) {
- items = (*CvUSERSUB(cv))(CvUSERINDEX(cv),
- mark - stack_base, items);
- sp = stack_base + items;
- LEAVE;
- return pop_return();
- }
- else {
- AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
- cx->blk_sub.cv = cv;
- cx->blk_sub.olddepth = CvDEPTH(cv);
- CvDEPTH(cv)++;
- if (CvDEPTH(cv) >= 2) { /* save temporaries on recursion? */
- if (CvDEPTH(cv) == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",
- GvENAME(CvGV(cv)));
- if (CvDEPTH(cv) > AvFILL(padlist)) {
- AV *newpad = newAV();
- I32 ix = AvFILL((AV*)svp[1]);
- svp = AvARRAY(svp[0]);
- while (ix > 0) {
- if (svp[ix]) {
- char *name = SvPVX(svp[ix]); /* XXX */
- if (*name == '@')
- av_store(newpad, ix--, (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix--, (SV*)newHV());
- else
- av_store(newpad, ix--, NEWSV(0,0));
- }
- else
- av_store(newpad, ix--, NEWSV(0,0));
- }
- if (cx->blk_sub.hasargs) {
- AV* av = newAV();
- av_store(av, 0, Nullsv);
- av_store(newpad, 0, (SV*)av);
- SvOK_on(av);
- AvREAL_off(av);
- }
- av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILL(padlist) = CvDEPTH(cv);
- svp = AvARRAY(padlist);
- }
- }
- SAVESPTR(curpad);
- curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
- if (cx->blk_sub.hasargs) {
- AV* av = (AV*)curpad[0];
- SV** ary;
-
- cx->blk_sub.savearray = GvAV(defgv);
- cx->blk_sub.argarray = av;
- GvAV(defgv) = cx->blk_sub.argarray;
- ++mark;
-
- if (items >= AvMAX(av)) {
- ary = AvALLOC(av);
- if (AvARRAY(av) != ary) {
- AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPVX(av) = (char*)ary;
- }
- if (items >= AvMAX(av)) {
- AvMAX(av) = items - 1;
- Renew(ary,items+1,SV*);
- AvALLOC(av) = ary;
- SvPVX(av) = (char*)ary;
- }
- }
- Copy(mark,AvARRAY(av),items,SV*);
- AvFILL(av) = items - 1;
- while (items--) {
- if (*mark)
- SvTEMP_off(*mark);
- mark++;
- }
- }
- RETURNOP(CvSTART(cv));
- }
- }
- else
- label = SvPV(sv,na);
- }
- else if (op->op_flags & OPf_SPECIAL) {
- if (op->op_type != OP_DUMP)
- DIE("goto must have label");
- }
- else
- label = cPVOP->op_pv;
-
- if (label && *label) {
- OP *gotoprobe;
-
- /* find label */
-
- lastgotoprobe = 0;
- *enterops = 0;
- for (ix = cxstack_ix; ix >= 0; ix--) {
- cx = &cxstack[ix];
- switch (cx->cx_type) {
- case CXt_SUB:
- gotoprobe = CvROOT(cx->blk_sub.cv);
- break;
- case CXt_EVAL:
- gotoprobe = eval_root; /* XXX not good for nested eval */
- break;
- case CXt_LOOP:
- gotoprobe = cx->blk_oldcop->op_sibling;
- break;
- case CXt_SUBST:
- continue;
- case CXt_BLOCK:
- if (ix)
- gotoprobe = cx->blk_oldcop->op_sibling;
- else
- gotoprobe = main_root;
- break;
- default:
- if (ix)
- DIE("panic: goto");
- else
- gotoprobe = main_root;
- break;
- }
- retop = dofindlabel(gotoprobe, label, enterops);
- if (retop)
- break;
- lastgotoprobe = gotoprobe;
- }
- if (!retop)
- DIE("Can't find label %s", label);
-
- /* pop unwanted frames */
-
- if (ix < cxstack_ix) {
- I32 oldsave;
-
- if (ix < 0)
- ix = 0;
- dounwind(ix);
- TOPBLOCK(cx);
- oldsave = scopestack[scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
- }
-
- /* push wanted frames */
-
- if (*enterops) {
- OP *oldop = op;
- for (ix = 0 + (gotoprobe == main_root); enterops[ix]; ix++) {
- op = enterops[ix];
- (*op->op_ppaddr)();
- }
- op = oldop;
- }
- }
-
- if (op->op_type == OP_DUMP) {
- restartop = retop;
- do_undump = TRUE;
-
- my_unexec();
-
- restartop = 0; /* hmm, must be GNU unexec().. */
- do_undump = FALSE;
- }
-
- RETURNOP(retop);
-}
-
-PP(pp_exit)
-{
- dSP;
- I32 anum;
-
- if (MAXARG < 1)
- anum = 0;
- else
- anum = SvIVx(POPs);
- my_exit(anum);
- PUSHs(&sv_undef);
- RETURN;
-}
-
-PP(pp_nswitch)
-{
- dSP;
- double value = SvNVx(GvSV(cCOP->cop_gv));
- register I32 match = (I32)value;
-
- if (value < 0.0) {
- if (((double)match) > value)
- --match; /* was fractional--truncate other way */
- }
- match -= cCOP->uop.scop.scop_offset;
- if (match < 0)
- match = 0;
- else if (match > cCOP->uop.scop.scop_max)
- match = cCOP->uop.scop.scop_max;
- op = cCOP->uop.scop.scop_next[match];
- RETURNOP(op);
-}
-
-PP(pp_cswitch)
-{
- dSP;
- register I32 match;
-
- if (multiline)
- op = op->op_next; /* can't assume anything */
- else {
- match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
- match -= cCOP->uop.scop.scop_offset;
- if (match < 0)
- match = 0;
- else if (match > cCOP->uop.scop.scop_max)
- match = cCOP->uop.scop.scop_max;
- op = cCOP->uop.scop.scop_next[match];
- }
- RETURNOP(op);
-}
-
-/* I/O. */
-
-PP(pp_open)
-{
- dSP; dTARGET;
- GV *gv;
- SV *sv;
- char *tmps;
- STRLEN len;
-
- if (MAXARG > 1)
- sv = POPs;
- else
- sv = GvSV(TOPs);
- gv = (GV*)POPs;
- tmps = SvPV(sv, len);
- if (do_open(gv, tmps, len)) {
- IoLINES(GvIO(gv)) = 0;
- PUSHi( (I32)forkprocess );
- }
- else if (forkprocess == 0) /* we are a new child */
- PUSHi(0);
- else
- RETPUSHUNDEF;
- RETURN;
-}
-
-PP(pp_close)
-{
- dSP;
- GV *gv;
-
- if (MAXARG == 0)
- gv = defoutgv;
- else
- gv = (GV*)POPs;
- EXTEND(SP, 1);
- PUSHs( do_close(gv, TRUE) ? &sv_yes : &sv_no );
- RETURN;
-}
-
-PP(pp_pipe_op)
-{
- dSP;
-#ifdef HAS_PIPE
- GV *rgv;
- GV *wgv;
- register IO *rstio;
- register IO *wstio;
- int fd[2];
-
- wgv = (GV*)POPs;
- rgv = (GV*)POPs;
-
- if (!rgv || !wgv)
- goto badexit;
-
- rstio = GvIOn(rgv);
- wstio = GvIOn(wgv);
-
- if (IoIFP(rstio))
- do_close(rgv, FALSE);
- if (IoIFP(wstio))
- do_close(wgv, FALSE);
-
- if (pipe(fd) < 0)
- goto badexit;
-
- IoIFP(rstio) = fdopen(fd[0], "r");
- IoOFP(wstio) = fdopen(fd[1], "w");
- IoIFP(wstio) = IoOFP(wstio);
- IoTYPE(rstio) = '<';
- IoTYPE(wstio) = '>';
-
- if (!IoIFP(rstio) || !IoOFP(wstio)) {
- if (IoIFP(rstio)) fclose(IoIFP(rstio));
- else close(fd[0]);
- if (IoOFP(wstio)) fclose(IoOFP(wstio));
- else close(fd[1]);
- goto badexit;
- }
-
- RETPUSHYES;
-
-badexit:
- RETPUSHUNDEF;
-#else
- DIE(no_func, "pipe");
-#endif
-}
-
-PP(pp_fileno)
-{
- dSP; dTARGET;
- GV *gv;
- IO *io;
- FILE *fp;
- if (MAXARG < 1)
- RETPUSHUNDEF;
- gv = (GV*)POPs;
- if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
- RETPUSHUNDEF;
- PUSHi(fileno(fp));
- RETURN;
-}
-
-PP(pp_umask)
-{
- dSP; dTARGET;
- int anum;
-
-#ifdef HAS_UMASK
- if (MAXARG < 1) {
- anum = umask(0);
- (void)umask(anum);
- }
- else
- anum = umask(POPi);
- TAINT_PROPER("umask");
- XPUSHi(anum);
-#else
- DIE(no_func, "Unsupported function umask");
-#endif
- RETURN;
-}
-
-PP(pp_binmode)
-{
- dSP;
- GV *gv;
- IO *io;
- FILE *fp;
-
- if (MAXARG < 1)
- RETPUSHUNDEF;
-
- gv = (GV*)POPs;
-
- EXTEND(SP, 1);
- if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
- RETSETUNDEF;
-
-#ifdef DOSISH
-#ifdef atarist
- if (!fflush(fp) && (fp->_flag |= _IOBIN))
- RETPUSHYES;
- else
- RETPUSHUNDEF;
-#else
- if (setmode(fileno(fp), OP_BINARY) != -1)
- RETPUSHYES;
- else
- RETPUSHUNDEF;
-#endif
-#else
- RETPUSHYES;
-#endif
-}
-
-PP(pp_tie)
-{
- dSP;
- SV *varsv;
- HV* stash;
- GV *gv;
- BINOP myop;
- SV *sv;
- SV **mark = stack_base + *markstack_ptr + 1; /* reuse in entersubr */
-
- varsv = mark[0];
-
- stash = fetch_stash(mark[1], FALSE);
- if (!stash || !(gv = gv_fetchmethod(stash, "new")) || !GvCV(gv))
- DIE("Can't tie to package %s", SvPV(mark[1],na));
-
- Zero(&myop, 1, BINOP);
- myop.op_last = (OP *) &myop;
- myop.op_next = Nullop;
- myop.op_flags = OPf_STACKED;
-
- ENTER;
- SAVESPTR(op);
- op = (OP *) &myop;
-
- mark[0] = gv;
- PUTBACK;
-
- if (op = pp_entersubr())
- run();
- SPAGAIN;
-
- sv = TOPs;
- if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV)
- sv_magic(varsv, sv, 'P', 0, 0);
- else
- sv_magic(varsv, sv, 'p', 0, -1);
- LEAVE;
- SPAGAIN;
- RETURN;
-}
-
-PP(pp_untie)
-{
- dSP;
- if (SvTYPE(TOPs) == SVt_PVHV || SvTYPE(TOPs) == SVt_PVAV)
- sv_unmagic(TOPs, 'P');
- else
- sv_unmagic(TOPs, 'p');
- RETSETYES;
-}
-
-PP(pp_dbmopen)
-{
- dSP;
- HV *hv;
- dPOPPOPssrl;
- HV* stash;
- GV *gv;
- BINOP myop;
- SV *sv;
-
- hv = (HV*)POPs;
-
- sv = sv_mortalcopy(&sv_no);
- sv_setpv(sv, "Any_DBM_File");
- stash = fetch_stash(sv, FALSE);
- if (!stash || !(gv = gv_fetchmethod(stash, "new")) || !GvCV(gv))
- DIE("No dbm on this machine");
-
- Zero(&myop, 1, BINOP);
- myop.op_last = (OP *) &myop;
- myop.op_next = Nullop;
- myop.op_flags = OPf_STACKED;
-
- ENTER;
- SAVESPTR(op);
- op = (OP *) &myop;
- PUTBACK;
- pp_pushmark();
-
- EXTEND(sp, 5);
- PUSHs(gv);
- PUSHs(sv);
- PUSHs(lstr);
- if (SvIV(rstr))
- PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
- else
- PUSHs(sv_2mortal(newSViv(O_RDWR)));
- PUSHs(rstr);
- PUTBACK;
-
- if (op = pp_entersubr())
- run();
- LEAVE;
- SPAGAIN;
-
- sv = TOPs;
- sv_magic((SV*)hv, sv, 'P', 0, 0);
- RETURN;
-}
-
-PP(pp_dbmclose)
-{
- return pp_untie(ARGS);
-}
-
-PP(pp_sselect)
-{
- dSP; dTARGET;
-#ifdef HAS_SELECT
- register I32 i;
- register I32 j;
- register char *s;
- register SV *sv;
- double value;
- I32 maxlen = 0;
- I32 nfound;
- struct timeval timebuf;
- struct timeval *tbuf = &timebuf;
- I32 growsize;
- char *fd_sets[4];
-#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
- I32 masksize;
- I32 offset;
- I32 k;
-
-# if BYTEORDER & 0xf0000
-# define ORDERBYTE (0x88888888 - BYTEORDER)
-# else
-# define ORDERBYTE (0x4444 - BYTEORDER)
-# endif
-
-#endif
-
- SP -= 4;
- for (i = 1; i <= 3; i++) {
- if (!SvPOK(SP[i]))
- continue;
- j = SvCUR(SP[i]);
- if (maxlen < j)
- maxlen = j;
- }
-
-#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
- growsize = maxlen; /* little endians can use vecs directly */
-#else
-#ifdef NFDBITS
-
-#ifndef NBBY
-#define NBBY 8
-#endif
-
- masksize = NFDBITS / NBBY;
-#else
- masksize = sizeof(long); /* documented int, everyone seems to use long */
-#endif
- growsize = maxlen + (masksize - (maxlen % masksize));
- Zero(&fd_sets[0], 4, char*);
-#endif
-
- sv = SP[4];
- if (SvOK(sv)) {
- value = SvNV(sv);
- if (value < 0.0)
- value = 0.0;
- timebuf.tv_sec = (long)value;
- value -= (double)timebuf.tv_sec;
- timebuf.tv_usec = (long)(value * 1000000.0);
- }
- else
- tbuf = Null(struct timeval*);
-
- for (i = 1; i <= 3; i++) {
- sv = SP[i];
- if (!SvPOK(sv)) {
- fd_sets[i] = 0;
- continue;
- }
- j = SvLEN(sv);
- if (j < growsize) {
- Sv_Grow(sv, growsize);
- s = SvPV(sv, na) + j;
- while (++j <= growsize) {
- *s++ = '\0';
- }
- }
-#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
- s = SvPVX(sv);
- New(403, fd_sets[i], growsize, char);
- for (offset = 0; offset < growsize; offset += masksize) {
- for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
- fd_sets[i][j+offset] = s[(k % masksize) + offset];
- }
-#else
- fd_sets[i] = SvPVX(sv);
-#endif
- }
-
- nfound = select(
- maxlen * 8,
- fd_sets[1],
- fd_sets[2],
- fd_sets[3],
- tbuf);
-#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
- for (i = 1; i <= 3; i++) {
- if (fd_sets[i]) {
- sv = SP[i];
- s = SvPVX(sv);
- for (offset = 0; offset < growsize; offset += masksize) {
- for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
- s[(k % masksize) + offset] = fd_sets[i][j+offset];
- }
- Safefree(fd_sets[i]);
- }
- }
-#endif
-
- PUSHi(nfound);
- if (GIMME == G_ARRAY && tbuf) {
- value = (double)(timebuf.tv_sec) +
- (double)(timebuf.tv_usec) / 1000000.0;
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setnv(sv, value);
- }
- RETURN;
-#else
- DIE("select not implemented");
-#endif
-}
-
-PP(pp_select)
-{
- dSP; dTARGET;
- GV *oldgv = defoutgv;
- if (op->op_private > 0) {
- defoutgv = (GV*)POPs;
- if (!GvIO(defoutgv))
- GvIO(defoutgv) = newIO();
- curoutgv = defoutgv;
- }
- gv_efullname(TARG, oldgv);
- XPUSHTARG;
- RETURN;
-}
-
-PP(pp_getc)
-{
- dSP; dTARGET;
- GV *gv;
-
- if (MAXARG <= 0)
- gv = stdingv;
- else
- gv = (GV*)POPs;
- if (!gv)
- gv = argvgv;
- if (!gv || do_eof(gv)) /* make sure we have fp with something */
- RETPUSHUNDEF;
- TAINT_IF(1);
- sv_setpv(TARG, " ");
- *SvPVX(TARG) = getc(IoIFP(GvIO(gv))); /* should never be EOF */
- PUSHTARG;
- RETURN;
-}
-
-PP(pp_read)
-{
- return pp_sysread(ARGS);
-}
-
-static OP *
-doform(cv,gv,retop)
-CV *cv;
-GV *gv;
-OP *retop;
-{
- register CONTEXT *cx;
- I32 gimme = GIMME;
- ENTER;
- SAVETMPS;
-
- push_return(retop);
- PUSHBLOCK(cx, CXt_SUB, stack_sp);
- PUSHFORMAT(cx);
- defoutgv = gv; /* locally select filehandle so $% et al work */
- return CvSTART(cv);
-}
-
-PP(pp_enterwrite)
-{
- dSP;
- register GV *gv;
- register IO *io;
- GV *fgv;
- FILE *fp;
- CV *cv;
-
- if (MAXARG == 0)
- gv = defoutgv;
- else {
- gv = (GV*)POPs;
- if (!gv)
- gv = defoutgv;
- }
- EXTEND(SP, 1);
- io = GvIO(gv);
- if (!io) {
- RETPUSHNO;
- }
- curoutgv = gv;
- if (IoFMT_GV(io))
- fgv = IoFMT_GV(io);
- else
- fgv = gv;
-
- cv = GvFORM(fgv);
-
- if (!cv) {
- if (fgv) {
- SV *tmpstr = sv_newmortal();
- gv_efullname(tmpstr, gv);
- DIE("Undefined format \"%s\" called",SvPVX(tmpstr));
- }
- DIE("Not a format reference");
- }
-
- return doform(cv,gv,op->op_next);
-}
-
-PP(pp_leavewrite)
-{
- dSP;
- GV *gv = cxstack[cxstack_ix].blk_sub.gv;
- register IO *io = GvIO(gv);
- FILE *ofp = IoOFP(io);
- FILE *fp;
- SV **mark;
- SV **newsp;
- I32 gimme;
- register CONTEXT *cx;
-
- DEBUG_f(fprintf(stderr,"left=%ld, todo=%ld\n",
- (long)IoLINES_LEFT(io), (long)FmLINES(formtarget)));
- if (IoLINES_LEFT(io) < FmLINES(formtarget) &&
- formtarget != toptarget)
- {
- if (!IoTOP_GV(io)) {
- GV *topgv;
- char tmpbuf[256];
-
- if (!IoTOP_NAME(io)) {
- if (!IoFMT_NAME(io))
- IoFMT_NAME(io) = savestr(GvNAME(gv));
- sprintf(tmpbuf, "%s_TOP", IoFMT_NAME(io));
- topgv = gv_fetchpv(tmpbuf,FALSE);
- if (topgv && GvFORM(topgv))
- IoTOP_NAME(io) = savestr(tmpbuf);
- else
- IoTOP_NAME(io) = savestr("top");
- }
- topgv = gv_fetchpv(IoTOP_NAME(io),FALSE);
- if (!topgv || !GvFORM(topgv)) {
- IoLINES_LEFT(io) = 100000000;
- goto forget_top;
- }
- IoTOP_GV(io) = topgv;
- }
- if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
- fwrite(SvPVX(formfeed), SvCUR(formfeed), 1, ofp);
- IoLINES_LEFT(io) = IoPAGE_LEN(io);
- IoPAGE(io)++;
- formtarget = toptarget;
- return doform(GvFORM(IoTOP_GV(io)),gv,op);
- }
-
- forget_top:
- POPBLOCK(cx);
- POPFORMAT(cx);
- LEAVE;
-
- fp = IoOFP(io);
- if (!fp) {
- if (dowarn) {
- if (IoIFP(io))
- warn("Filehandle only opened for input");
- else
- warn("Write on closed filehandle");
- }
- PUSHs(&sv_no);
- }
- else {
- if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) {
- if (dowarn)
- warn("page overflow");
- }
- if (!fwrite(SvPVX(formtarget), 1, SvCUR(formtarget), ofp) ||
- ferror(fp))
- PUSHs(&sv_no);
- else {
- FmLINES(formtarget) = 0;
- SvCUR_set(formtarget, 0);
- if (IoFLAGS(io) & IOf_FLUSH)
- (void)fflush(fp);
- PUSHs(&sv_yes);
- }
- }
- formtarget = bodytarget;
- PUTBACK;
- return pop_return();
-}
-
-PP(pp_prtf)
-{
- dSP; dMARK; dORIGMARK;
- GV *gv;
- IO *io;
- FILE *fp;
- SV *sv = NEWSV(0,0);
-
- if (op->op_flags & OPf_STACKED)
- gv = (GV*)*++MARK;
- else
- gv = defoutgv;
- if (!(io = GvIO(gv))) {
- if (dowarn)
- warn("Filehandle never opened");
- errno = EBADF;
- goto just_say_no;
- }
- else if (!(fp = IoOFP(io))) {
- if (dowarn) {
- if (IoIFP(io))
- warn("Filehandle opened only for input");
- else
- warn("printf on closed filehandle");
- }
- errno = EBADF;
- goto just_say_no;
- }
- else {
- do_sprintf(sv, SP - MARK, MARK + 1);
- if (!do_print(sv, fp))
- goto just_say_no;
-
- if (IoFLAGS(io) & IOf_FLUSH)
- if (fflush(fp) == EOF)
- goto just_say_no;
- }
- SvREFCNT_dec(sv);
- SP = ORIGMARK;
- PUSHs(&sv_yes);
- RETURN;
-
- just_say_no:
- SvREFCNT_dec(sv);
- SP = ORIGMARK;
- PUSHs(&sv_undef);
- RETURN;
-}
-
-PP(pp_print)
-{
- dSP; dMARK; dORIGMARK;
- GV *gv;
- IO *io;
- register FILE *fp;
-
- if (op->op_flags & OPf_STACKED)
- gv = (GV*)*++MARK;
- else
- gv = defoutgv;
- if (!(io = GvIO(gv))) {
- if (dowarn)
- warn("Filehandle never opened");
- errno = EBADF;
- goto just_say_no;
- }
- else if (!(fp = IoOFP(io))) {
- if (dowarn) {
- if (IoIFP(io))
- warn("Filehandle opened only for input");
- else
- warn("print on closed filehandle");
- }
- errno = EBADF;
- goto just_say_no;
- }
- else {
- MARK++;
- if (ofslen) {
- while (MARK <= SP) {
- if (!do_print(*MARK, fp))
- break;
- MARK++;
- if (MARK <= SP) {
- if (fwrite(ofs, 1, ofslen, fp) == 0 || ferror(fp)) {
- MARK--;
- break;
- }
- }
- }
- }
- else {
- while (MARK <= SP) {
- if (!do_print(*MARK, fp))
- break;
- MARK++;
- }
- }
- if (MARK <= SP)
- goto just_say_no;
- else {
- if (orslen)
- if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp))
- goto just_say_no;
-
- if (IoFLAGS(io) & IOf_FLUSH)
- if (fflush(fp) == EOF)
- goto just_say_no;
- }
- }
- SP = ORIGMARK;
- PUSHs(&sv_yes);
- RETURN;
-
- just_say_no:
- SP = ORIGMARK;
- PUSHs(&sv_undef);
- RETURN;
-}
-
-PP(pp_sysread)
-{
- dSP; dMARK; dORIGMARK; dTARGET;
- int offset;
- GV *gv;
- IO *io;
- char *buffer;
- int length;
- int bufsize;
- SV *bufstr;
- STRLEN blen;
-
- gv = (GV*)*++MARK;
- if (!gv)
- goto say_undef;
- bufstr = *++MARK;
- buffer = SvPV(bufstr, blen);
- length = SvIVx(*++MARK);
- if (SvTHINKFIRST(bufstr)) {
- if (SvREADONLY(bufstr) && curcop != &compiling)
- DIE(no_modify);
- if (SvROK(bufstr))
- sv_unref(bufstr);
- }
- errno = 0;
- if (MARK < SP)
- offset = SvIVx(*++MARK);
- else
- offset = 0;
- if (MARK < SP)
- warn("Too many args on read");
- io = GvIO(gv);
- if (!io || !IoIFP(io))
- goto say_undef;
-#ifdef HAS_SOCKET
- if (op->op_type == OP_RECV) {
- bufsize = sizeof buf;
- SvGROW(bufstr, length+1), (buffer = SvPV(bufstr, blen)); /* sneaky */
- length = recvfrom(fileno(IoIFP(io)), buffer, length, offset,
- buf, &bufsize);
- if (length < 0)
- RETPUSHUNDEF;
- SvCUR_set(bufstr, length);
- *SvEND(bufstr) = '\0';
- SvPOK_only(bufstr);
- SP = ORIGMARK;
- sv_setpvn(TARG, buf, bufsize);
- PUSHs(TARG);
- RETURN;
- }
-#else
- if (op->op_type == OP_RECV)
- DIE(no_sock_func, "recv");
-#endif
- SvGROW(bufstr, length+offset+1), (buffer = SvPV(bufstr, blen)); /* sneaky */
- if (op->op_type == OP_SYSREAD) {
- length = read(fileno(IoIFP(io)), buffer+offset, length);
- }
- else
-#ifdef HAS_SOCKET
- if (IoTYPE(io) == 's') {
- bufsize = sizeof buf;
- length = recvfrom(fileno(IoIFP(io)), buffer+offset, length, 0,
- buf, &bufsize);
- }
- else
-#endif
- length = fread(buffer+offset, 1, length, IoIFP(io));
- if (length < 0)
- goto say_undef;
- SvCUR_set(bufstr, length+offset);
- *SvEND(bufstr) = '\0';
- SvPOK_only(bufstr);
- SP = ORIGMARK;
- PUSHi(length);
- RETURN;
-
- say_undef:
- SP = ORIGMARK;
- RETPUSHUNDEF;
-}
-
-PP(pp_syswrite)
-{
- return pp_send(ARGS);
-}
-
-PP(pp_send)
-{
- dSP; dMARK; dORIGMARK; dTARGET;
- GV *gv;
- IO *io;
- int offset;
- SV *bufstr;
- char *buffer;
- int length;
- STRLEN blen;
-
- gv = (GV*)*++MARK;
- if (!gv)
- goto say_undef;
- bufstr = *++MARK;
- buffer = SvPV(bufstr, blen);
- length = SvIVx(*++MARK);
- errno = 0;
- io = GvIO(gv);
- if (!io || !IoIFP(io)) {
- length = -1;
- if (dowarn) {
- if (op->op_type == OP_SYSWRITE)
- warn("Syswrite on closed filehandle");
- else
- warn("Send on closed socket");
- }
- }
- else if (op->op_type == OP_SYSWRITE) {
- if (MARK < SP)
- offset = SvIVx(*++MARK);
- else
- offset = 0;
- if (MARK < SP)
- warn("Too many args on syswrite");
- length = write(fileno(IoIFP(io)), buffer+offset, length);
- }
-#ifdef HAS_SOCKET
- else if (SP >= MARK) {
- STRLEN mlen;
- if (SP > MARK)
- warn("Too many args on send");
- buffer = SvPVx(*++MARK, mlen);
- length = sendto(fileno(IoIFP(io)), buffer, blen, length, buffer, mlen);
- }
- else
- length = send(fileno(IoIFP(io)), buffer, blen, length);
-#else
- else
- DIE(no_sock_func, "send");
-#endif
- if (length < 0)
- goto say_undef;
- SP = ORIGMARK;
- PUSHi(length);
- RETURN;
-
- say_undef:
- SP = ORIGMARK;
- RETPUSHUNDEF;
-}
-
-PP(pp_recv)
-{
- return pp_sysread(ARGS);
-}
-
-PP(pp_eof)
-{
- dSP;
- GV *gv;
-
- if (MAXARG <= 0)
- gv = last_in_gv;
- else
- gv = last_in_gv = (GV*)POPs;
- PUSHs(!gv || do_eof(gv) ? &sv_yes : &sv_no);
- RETURN;
-}
-
-PP(pp_tell)
-{
- dSP; dTARGET;
- GV *gv;
-
- if (MAXARG <= 0)
- gv = last_in_gv;
- else
- gv = last_in_gv = (GV*)POPs;
- PUSHi( do_tell(gv) );
- RETURN;
-}
-
-PP(pp_seek)
-{
- dSP;
- GV *gv;
- int whence = POPi;
- long offset = POPl;
-
- gv = last_in_gv = (GV*)POPs;
- PUSHs( do_seek(gv, offset, whence) ? &sv_yes : &sv_no );
- RETURN;
-}
-
-PP(pp_truncate)
-{
- dSP;
- off_t len = (off_t)POPn;
- int result = 1;
- GV *tmpgv;
-
- errno = 0;
-#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE)
-#ifdef HAS_TRUNCATE
- if (op->op_flags & OPf_SPECIAL) {
- tmpgv = gv_fetchpv(POPp,FALSE);
- if (!tmpgv || !GvIO(tmpgv) || !IoIFP(GvIO(tmpgv)) ||
- ftruncate(fileno(IoIFP(GvIO(tmpgv))), len) < 0)
- result = 0;
- }
- else if (truncate(POPp, len) < 0)
- result = 0;
-#else
- if (op->op_flags & OPf_SPECIAL) {
- tmpgv = gv_fetchpv(POPp,FALSE);
- if (!tmpgv || !GvIO(tmpgv) || !IoIFP(GvIO(tmpgv)) ||
- chsize(fileno(IoIFP(GvIO(tmpgv))), len) < 0)
- result = 0;
- }
- else {
- int tmpfd;
-
- if ((tmpfd = open(POPp, 0)) < 0)
- result = 0;
- else {
- if (chsize(tmpfd, len) < 0)
- result = 0;
- close(tmpfd);
- }
- }
-#endif
-
- if (result)
- RETPUSHYES;
- if (!errno)
- errno = EBADF;
- RETPUSHUNDEF;
-#else
- DIE("truncate not implemented");
-#endif
-}
-
-PP(pp_fcntl)
-{
- return pp_ioctl(ARGS);
-}
-
-PP(pp_ioctl)
-{
- dSP; dTARGET;
- SV *argstr = POPs;
- unsigned int func = U_I(POPn);
- int optype = op->op_type;
- char *s;
- int retval;
- GV *gv = (GV*)POPs;
- IO *io = GvIOn(gv);
-
- if (!io || !argstr || !IoIFP(io)) {
- errno = EBADF; /* well, sort of... */
- RETPUSHUNDEF;
- }
-
- if (SvPOK(argstr) || !SvNIOK(argstr)) {
- STRLEN len = 0;
- if (!SvPOK(argstr))
- s = SvPV(argstr, len);
- retval = IOCPARM_LEN(func);
- if (len < retval) {
- Sv_Grow(argstr, retval+1);
- SvCUR_set(argstr, retval);
- }
-
- s = SvPVX(argstr);
- s[SvCUR(argstr)] = 17; /* a little sanity check here */
- }
- else {
- retval = SvIV(argstr);
-#ifdef DOSISH
- s = (char*)(long)retval; /* ouch */
-#else
- s = (char*)retval; /* ouch */
-#endif
- }
-
- TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
-
- if (optype == OP_IOCTL)
- retval = ioctl(fileno(IoIFP(io)), func, s);
- else
-#ifdef DOSISH
- DIE("fcntl is not implemented");
-#else
-# ifdef HAS_FCNTL
- retval = fcntl(fileno(IoIFP(io)), func, s);
-# else
- DIE("fcntl is not implemented");
-# endif
-#endif
-
- if (SvPOK(argstr)) {
- if (s[SvCUR(argstr)] != 17)
- DIE("Possible memory corruption: %s overflowed 3rd argument",
- op_name[optype]);
- s[SvCUR(argstr)] = 0; /* put our null back */
- }
-
- if (retval == -1)
- RETPUSHUNDEF;
- if (retval != 0) {
- PUSHi(retval);
- }
- else {
- PUSHp("0 but true", 10);
- }
- RETURN;
-}
-
-PP(pp_flock)
-{
- dSP; dTARGET;
- I32 value;
- int argtype;
- GV *gv;
- FILE *fp;
-#ifdef HAS_FLOCK
- argtype = POPi;
- if (MAXARG <= 0)
- gv = last_in_gv;
- else
- gv = (GV*)POPs;
- if (gv && GvIO(gv))
- fp = IoIFP(GvIO(gv));
- else
- fp = Nullfp;
- if (fp) {
- value = (I32)(flock(fileno(fp), argtype) >= 0);
- }
- else
- value = 0;
- PUSHi(value);
- RETURN;
-#else
- DIE(no_func, "flock()");
-#endif
-}
-
-/* Sockets. */
-
-PP(pp_socket)
-{
- dSP;
-#ifdef HAS_SOCKET
- GV *gv;
- register IO *io;
- int protocol = POPi;
- int type = POPi;
- int domain = POPi;
- int fd;
-
- gv = (GV*)POPs;
-
- if (!gv) {
- errno = EBADF;
- RETPUSHUNDEF;
- }
-
- io = GvIOn(gv);
- if (IoIFP(io))
- do_close(gv, FALSE);
-
- TAINT_PROPER("socket");
- fd = socket(domain, type, protocol);
- if (fd < 0)
- RETPUSHUNDEF;
- IoIFP(io) = fdopen(fd, "r"); /* stdio gets confused about sockets */
- IoOFP(io) = fdopen(fd, "w");
- IoTYPE(io) = 's';
- if (!IoIFP(io) || !IoOFP(io)) {
- if (IoIFP(io)) fclose(IoIFP(io));
- if (IoOFP(io)) fclose(IoOFP(io));
- if (!IoIFP(io) && !IoOFP(io)) close(fd);
- RETPUSHUNDEF;
- }
-
- RETPUSHYES;
-#else
- DIE(no_sock_func, "socket");
-#endif
-}
-
-PP(pp_sockpair)
-{
- dSP;
-#ifdef HAS_SOCKETPAIR
- GV *gv1;
- GV *gv2;
- register IO *io1;
- register IO *io2;
- int protocol = POPi;
- int type = POPi;
- int domain = POPi;
- int fd[2];
-
- gv2 = (GV*)POPs;
- gv1 = (GV*)POPs;
- if (!gv1 || !gv2)
- RETPUSHUNDEF;
-
- io1 = GvIOn(gv1);
- io2 = GvIOn(gv2);
- if (IoIFP(io1))
- do_close(gv1, FALSE);
- if (IoIFP(io2))
- do_close(gv2, FALSE);
-
- TAINT_PROPER("socketpair");
- if (socketpair(domain, type, protocol, fd) < 0)
- RETPUSHUNDEF;
- IoIFP(io1) = fdopen(fd[0], "r");
- IoOFP(io1) = fdopen(fd[0], "w");
- IoTYPE(io1) = 's';
- IoIFP(io2) = fdopen(fd[1], "r");
- IoOFP(io2) = fdopen(fd[1], "w");
- IoTYPE(io2) = 's';
- if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
- if (IoIFP(io1)) fclose(IoIFP(io1));
- if (IoOFP(io1)) fclose(IoOFP(io1));
- if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]);
- if (IoIFP(io2)) fclose(IoIFP(io2));
- if (IoOFP(io2)) fclose(IoOFP(io2));
- if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]);
- RETPUSHUNDEF;
- }
-
- RETPUSHYES;
-#else
- DIE(no_sock_func, "socketpair");
-#endif
-}
-
-PP(pp_bind)
-{
- dSP;
-#ifdef HAS_SOCKET
- SV *addrstr = POPs;
- char *addr;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
- STRLEN len;
-
- if (!io || !IoIFP(io))
- goto nuts;
-
- addr = SvPV(addrstr, len);
- TAINT_PROPER("bind");
- if (bind(fileno(IoIFP(io)), addr, len) >= 0)
- RETPUSHYES;
- else
- RETPUSHUNDEF;
-
-nuts:
- if (dowarn)
- warn("bind() on closed fd");
- errno = EBADF;
- RETPUSHUNDEF;
-#else
- DIE(no_sock_func, "bind");
-#endif
-}
-
-PP(pp_connect)
-{
- dSP;
-#ifdef HAS_SOCKET
- SV *addrstr = POPs;
- char *addr;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
- STRLEN len;
-
- if (!io || !IoIFP(io))
- goto nuts;
-
- addr = SvPV(addrstr, len);
- TAINT_PROPER("connect");
- if (connect(fileno(IoIFP(io)), addr, len) >= 0)
- RETPUSHYES;
- else
- RETPUSHUNDEF;
-
-nuts:
- if (dowarn)
- warn("connect() on closed fd");
- errno = EBADF;
- RETPUSHUNDEF;
-#else
- DIE(no_sock_func, "connect");
-#endif
-}
-
-PP(pp_listen)
-{
- dSP;
-#ifdef HAS_SOCKET
- int backlog = POPi;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io || !IoIFP(io))
- goto nuts;
-
- if (listen(fileno(IoIFP(io)), backlog) >= 0)
- RETPUSHYES;
- else
- RETPUSHUNDEF;
-
-nuts:
- if (dowarn)
- warn("listen() on closed fd");
- errno = EBADF;
- RETPUSHUNDEF;
-#else
- DIE(no_sock_func, "listen");
-#endif
-}
-
-PP(pp_accept)
-{
- dSP; dTARGET;
-#ifdef HAS_SOCKET
- GV *ngv;
- GV *ggv;
- register IO *nstio;
- register IO *gstio;
- int len = sizeof buf;
- int fd;
-
- ggv = (GV*)POPs;
- ngv = (GV*)POPs;
-
- if (!ngv)
- goto badexit;
- if (!ggv)
- goto nuts;
-
- gstio = GvIO(ggv);
- if (!gstio || !IoIFP(gstio))
- goto nuts;
-
- nstio = GvIOn(ngv);
- if (IoIFP(nstio))
- do_close(ngv, FALSE);
-
- fd = accept(fileno(IoIFP(gstio)), (struct sockaddr *)buf, &len);
- if (fd < 0)
- goto badexit;
- IoIFP(nstio) = fdopen(fd, "r");
- IoOFP(nstio) = fdopen(fd, "w");
- IoTYPE(nstio) = 's';
- if (!IoIFP(nstio) || !IoOFP(nstio)) {
- if (IoIFP(nstio)) fclose(IoIFP(nstio));
- if (IoOFP(nstio)) fclose(IoOFP(nstio));
- if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd);
- goto badexit;
- }
-
- PUSHp(buf, len);
- RETURN;
-
-nuts:
- if (dowarn)
- warn("accept() on closed fd");
- errno = EBADF;
-
-badexit:
- RETPUSHUNDEF;
-
-#else
- DIE(no_sock_func, "accept");
-#endif
-}
-
-PP(pp_shutdown)
-{
- dSP; dTARGET;
-#ifdef HAS_SOCKET
- int how = POPi;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io || !IoIFP(io))
- goto nuts;
-
- PUSHi( shutdown(fileno(IoIFP(io)), how) >= 0 );
- RETURN;
-
-nuts:
- if (dowarn)
- warn("shutdown() on closed fd");
- errno = EBADF;
- RETPUSHUNDEF;
-#else
- DIE(no_sock_func, "shutdown");
-#endif
-}
-
-PP(pp_gsockopt)
-{
-#ifdef HAS_SOCKET
- return pp_ssockopt(ARGS);
-#else
- DIE(no_sock_func, "getsockopt");
-#endif
-}
-
-PP(pp_ssockopt)
-{
- dSP;
-#ifdef HAS_SOCKET
- int optype = op->op_type;
- SV *sv;
- int fd;
- unsigned int optname;
- unsigned int lvl;
- GV *gv;
- register IO *io;
-
- if (optype == OP_GSOCKOPT)
- sv = sv_2mortal(NEWSV(22, 257));
- else
- sv = POPs;
- optname = (unsigned int) POPi;
- lvl = (unsigned int) POPi;
-
- gv = (GV*)POPs;
- io = GvIOn(gv);
- if (!io || !IoIFP(io))
- goto nuts;
-
- fd = fileno(IoIFP(io));
- switch (optype) {
- case OP_GSOCKOPT:
- SvCUR_set(sv, 256);
- SvPOK_only(sv);
- if (getsockopt(fd, lvl, optname, SvPVX(sv), (int*)&SvCUR(sv)) < 0)
- goto nuts2;
- PUSHs(sv);
- break;
- case OP_SSOCKOPT:
- if (setsockopt(fd, lvl, optname, SvPVX(sv), SvCUR(sv)) < 0)
- goto nuts2;
- PUSHs(&sv_yes);
- break;
- }
- RETURN;
-
-nuts:
- if (dowarn)
- warn("[gs]etsockopt() on closed fd");
- errno = EBADF;
-nuts2:
- RETPUSHUNDEF;
-
-#else
- DIE(no_sock_func, "setsockopt");
-#endif
-}
-
-PP(pp_getsockname)
-{
-#ifdef HAS_SOCKET
- return pp_getpeername(ARGS);
-#else
- DIE(no_sock_func, "getsockname");
-#endif
-}
-
-PP(pp_getpeername)
-{
- dSP;
-#ifdef HAS_SOCKET
- int optype = op->op_type;
- SV *sv;
- int fd;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io || !IoIFP(io))
- goto nuts;
-
- sv = sv_2mortal(NEWSV(22, 257));
- SvCUR_set(sv, 256);
- SvPOK_on(sv);
- fd = fileno(IoIFP(io));
- switch (optype) {
- case OP_GETSOCKNAME:
- if (getsockname(fd, SvPVX(sv), (int*)&SvCUR(sv)) < 0)
- goto nuts2;
- break;
- case OP_GETPEERNAME:
- if (getpeername(fd, SvPVX(sv), (int*)&SvCUR(sv)) < 0)
- goto nuts2;
- break;
- }
- PUSHs(sv);
- RETURN;
-
-nuts:
- if (dowarn)
- warn("get{sock, peer}name() on closed fd");
- errno = EBADF;
-nuts2:
- RETPUSHUNDEF;
-
-#else
- DIE(no_sock_func, "getpeername");
-#endif
-}
-
-/* Stat calls. */
-
-PP(pp_lstat)
-{
- return pp_stat(ARGS);
-}
-
-PP(pp_stat)
-{
- dSP;
- GV *tmpgv;
- I32 max = 13;
-
- if (op->op_flags & OPf_SPECIAL) {
- tmpgv = cGVOP->op_gv;
- if (tmpgv != defgv) {
- laststype = OP_STAT;
- statgv = tmpgv;
- sv_setpv(statname, "");
- if (!GvIO(tmpgv) || !IoIFP(GvIO(tmpgv)) ||
- fstat(fileno(IoIFP(GvIO(tmpgv))), &statcache) < 0) {
- max = 0;
- laststatval = -1;
- }
- }
- else if (laststatval < 0)
- max = 0;
- }
- else {
- sv_setpv(statname, POPp);
- statgv = Nullgv;
-#ifdef HAS_LSTAT
- laststype = op->op_type;
- if (op->op_type == OP_LSTAT)
- laststatval = lstat(SvPV(statname, na), &statcache);
- else
-#endif
- laststatval = stat(SvPV(statname, na), &statcache);
- if (laststatval < 0) {
- if (dowarn && strchr(SvPV(statname, na), '\n'))
- warn(warn_nl, "stat");
- max = 0;
- }
- }
-
- EXTEND(SP, 13);
- if (GIMME != G_ARRAY) {
- if (max)
- RETPUSHYES;
- else
- RETPUSHUNDEF;
- }
- if (max) {
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
-#ifdef STATBLOCKS
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
-#else
- PUSHs(sv_2mortal(newSVpv("", 0)));
- PUSHs(sv_2mortal(newSVpv("", 0)));
-#endif
- }
- RETURN;
-}
-
-PP(pp_ftrread)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IRUSR, 0, &statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftrwrite)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IWUSR, 0, &statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftrexec)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IXUSR, 0, &statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_fteread)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IRUSR, 1, &statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftewrite)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IWUSR, 1, &statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_fteexec)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (cando(S_IXUSR, 1, &statcache))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftis)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- RETPUSHYES;
-}
-
-PP(pp_fteowned)
-{
- return pp_ftrowned(ARGS);
-}
-
-PP(pp_ftrowned)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftzero)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (!statcache.st_size)
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftsize)
-{
- I32 result = my_stat(ARGS);
- dSP; dTARGET;
- if (result < 0)
- RETPUSHUNDEF;
- PUSHi(statcache.st_size);
- RETURN;
-}
-
-PP(pp_ftmtime)
-{
- I32 result = my_stat(ARGS);
- dSP; dTARGET;
- if (result < 0)
- RETPUSHUNDEF;
- PUSHn( (basetime - statcache.st_mtime) / 86400.0 );
- RETURN;
-}
-
-PP(pp_ftatime)
-{
- I32 result = my_stat(ARGS);
- dSP; dTARGET;
- if (result < 0)
- RETPUSHUNDEF;
- PUSHn( (basetime - statcache.st_atime) / 86400.0 );
- RETURN;
-}
-
-PP(pp_ftctime)
-{
- I32 result = my_stat(ARGS);
- dSP; dTARGET;
- if (result < 0)
- RETPUSHUNDEF;
- PUSHn( (basetime - statcache.st_ctime) / 86400.0 );
- RETURN;
-}
-
-PP(pp_ftsock)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISSOCK(statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftchr)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISCHR(statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftblk)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISBLK(statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftfile)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISREG(statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftdir)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISDIR(statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftpipe)
-{
- I32 result = my_stat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISFIFO(statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftlink)
-{
- I32 result = my_lstat(ARGS);
- dSP;
- if (result < 0)
- RETPUSHUNDEF;
- if (S_ISLNK(statcache.st_mode))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_ftsuid)
-{
- dSP;
-#ifdef S_ISUID
- I32 result = my_stat(ARGS);
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (statcache.st_mode & S_ISUID)
- RETPUSHYES;
-#endif
- RETPUSHNO;
-}
-
-PP(pp_ftsgid)
-{
- dSP;
-#ifdef S_ISGID
- I32 result = my_stat(ARGS);
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (statcache.st_mode & S_ISGID)
- RETPUSHYES;
-#endif
- RETPUSHNO;
-}
-
-PP(pp_ftsvtx)
-{
- dSP;
-#ifdef S_ISVTX
- I32 result = my_stat(ARGS);
- SPAGAIN;
- if (result < 0)
- RETPUSHUNDEF;
- if (statcache.st_mode & S_ISVTX)
- RETPUSHYES;
-#endif
- RETPUSHNO;
-}
-
-PP(pp_fttty)
-{
- dSP;
- int fd;
- GV *gv;
- char *tmps;
- if (op->op_flags & OPf_SPECIAL) {
- gv = cGVOP->op_gv;
- tmps = "";
- }
- else
- gv = gv_fetchpv(tmps = POPp, FALSE);
- if (gv && GvIO(gv) && IoIFP(GvIO(gv)))
- fd = fileno(IoIFP(GvIO(gv)));
- else if (isDIGIT(*tmps))
- fd = atoi(tmps);
- else
- RETPUSHUNDEF;
- if (isatty(fd))
- RETPUSHYES;
- RETPUSHNO;
-}
-
-PP(pp_fttext)
-{
- dSP;
- I32 i;
- I32 len;
- I32 odd = 0;
- STDCHAR tbuf[512];
- register STDCHAR *s;
- register IO *io;
- SV *sv;
-
- if (op->op_flags & OPf_SPECIAL) {
- EXTEND(SP, 1);
- if (cGVOP->op_gv == defgv) {
- if (statgv)
- io = GvIO(statgv);
- else {
- sv = statname;
- goto really_filename;
- }
- }
- else {
- statgv = cGVOP->op_gv;
- sv_setpv(statname, "");
- io = GvIO(statgv);
- }
- if (io && IoIFP(io)) {
-#if defined(STDSTDIO) || defined(atarist) /* this will work with atariST */
- fstat(fileno(IoIFP(io)), &statcache);
- if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
- if (op->op_type == OP_FTTEXT)
- RETPUSHNO;
- else
- RETPUSHYES;
- if (IoIFP(io)->_cnt <= 0) {
- i = getc(IoIFP(io));
- if (i != EOF)
- (void)ungetc(i, IoIFP(io));
- }
- if (IoIFP(io)->_cnt <= 0) /* null file is anything */
- RETPUSHYES;
- len = IoIFP(io)->_cnt + (IoIFP(io)->_ptr - IoIFP(io)->_base);
- s = IoIFP(io)->_base;
-#else
- DIE("-T and -B not implemented on filehandles");
-#endif
- }
- else {
- if (dowarn)
- warn("Test on unopened file <%s>",
- GvENAME(cGVOP->op_gv));
- errno = EBADF;
- RETPUSHUNDEF;
- }
- }
- else {
- sv = POPs;
- statgv = Nullgv;
- sv_setpv(statname, SvPV(sv, na));
- really_filename:
- i = open(SvPV(sv, na), 0);
- if (i < 0) {
- if (dowarn && strchr(SvPV(sv, na), '\n'))
- warn(warn_nl, "open");
- RETPUSHUNDEF;
- }
- fstat(i, &statcache);
- len = read(i, tbuf, 512);
- (void)close(i);
- if (len <= 0) {
- if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
- RETPUSHNO; /* special case NFS directories */
- RETPUSHYES; /* null file is anything */
- }
- s = tbuf;
- }
-
- /* now scan s to look for textiness */
-
- for (i = 0; i < len; i++, s++) {
- if (!*s) { /* null never allowed in text */
- odd += len;
- break;
- }
- else if (*s & 128)
- odd++;
- else if (*s < 32 &&
- *s != '\n' && *s != '\r' && *s != '\b' &&
- *s != '\t' && *s != '\f' && *s != 27)
- odd++;
- }
-
- if ((odd * 10 > len) == (op->op_type == OP_FTTEXT)) /* allow 10% odd */
- RETPUSHNO;
- else
- RETPUSHYES;
-}
-
-PP(pp_ftbinary)
-{
- return pp_fttext(ARGS);
-}
-
-/* File calls. */
-
-PP(pp_chdir)
-{
- dSP; dTARGET;
- double value;
- char *tmps;
- SV **svp;
-
- if (MAXARG < 1)
- tmps = Nullch;
- else
- tmps = POPp;
- if (!tmps || !*tmps) {
- svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
- if (svp)
- tmps = SvPV(*svp, na);
- }
- if (!tmps || !*tmps) {
- svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
- if (svp)
- tmps = SvPV(*svp, na);
- }
- TAINT_PROPER("chdir");
- PUSHi( chdir(tmps) >= 0 );
- RETURN;
-}
-
-PP(pp_chown)
-{
- dSP; dMARK; dTARGET;
- I32 value;
-#ifdef HAS_CHOWN
- value = (I32)apply(op->op_type, MARK, SP);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- DIE(no_func, "Unsupported function chown");
-#endif
-}
-
-PP(pp_chroot)
-{
- dSP; dTARGET;
- char *tmps;
-#ifdef HAS_CHROOT
- if (MAXARG < 1)
- tmps = SvPVx(GvSV(defgv), na);
- else
- tmps = POPp;
- TAINT_PROPER("chroot");
- PUSHi( chroot(tmps) >= 0 );
- RETURN;
-#else
- DIE(no_func, "chroot");
-#endif
-}
-
-PP(pp_unlink)
-{
- dSP; dMARK; dTARGET;
- I32 value;
- value = (I32)apply(op->op_type, MARK, SP);
- SP = MARK;
- PUSHi(value);
- RETURN;
-}
-
-PP(pp_chmod)
-{
- dSP; dMARK; dTARGET;
- I32 value;
- value = (I32)apply(op->op_type, MARK, SP);
- SP = MARK;
- PUSHi(value);
- RETURN;
-}
-
-PP(pp_utime)
-{
- dSP; dMARK; dTARGET;
- I32 value;
- value = (I32)apply(op->op_type, MARK, SP);
- SP = MARK;
- PUSHi(value);
- RETURN;
-}
-
-PP(pp_rename)
-{
- dSP; dTARGET;
- int anum;
-
- char *tmps2 = POPp;
- char *tmps = SvPV(TOPs, na);
- TAINT_PROPER("rename");
-#ifdef HAS_RENAME
- anum = rename(tmps, tmps2);
-#else
- if (same_dirent(tmps2, tmps)) /* can always rename to same name */
- anum = 1;
- else {
- if (euid || stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
- (void)UNLINK(tmps2);
- if (!(anum = link(tmps, tmps2)))
- anum = UNLINK(tmps);
- }
-#endif
- SETi( anum >= 0 );
- RETURN;
-}
-
-PP(pp_link)
-{
- dSP; dTARGET;
-#ifdef HAS_LINK
- char *tmps2 = POPp;
- char *tmps = SvPV(TOPs, na);
- TAINT_PROPER("link");
- SETi( link(tmps, tmps2) >= 0 );
-#else
- DIE(no_func, "Unsupported function link");
-#endif
- RETURN;
-}
-
-PP(pp_symlink)
-{
- dSP; dTARGET;
-#ifdef HAS_SYMLINK
- char *tmps2 = POPp;
- char *tmps = SvPV(TOPs, na);
- TAINT_PROPER("symlink");
- SETi( symlink(tmps, tmps2) >= 0 );
- RETURN;
-#else
- DIE(no_func, "symlink");
-#endif
-}
-
-PP(pp_readlink)
-{
- dSP; dTARGET;
-#ifdef HAS_SYMLINK
- char *tmps;
- int len;
- if (MAXARG < 1)
- tmps = SvPVx(GvSV(defgv), na);
- else
- tmps = POPp;
- len = readlink(tmps, buf, sizeof buf);
- EXTEND(SP, 1);
- if (len < 0)
- RETPUSHUNDEF;
- PUSHp(buf, len);
- RETURN;
-#else
- EXTEND(SP, 1);
- RETSETUNDEF; /* just pretend it's a normal file */
-#endif
-}
-
-#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
-static void
-dooneliner(cmd, filename)
-char *cmd;
-char *filename;
-{
- char mybuf[8192];
- char *s;
- int anum = 1;
- FILE *myfp;
-
- strcpy(mybuf, cmd);
- strcat(mybuf, " ");
- for (s = mybuf+strlen(mybuf); *filename; ) {
- *s++ = '\\';
- *s++ = *filename++;
- }
- strcpy(s, " 2>&1");
- myfp = my_popen(mybuf, "r");
- if (myfp) {
- *mybuf = '\0';
- s = fgets(mybuf, sizeof mybuf, myfp);
- (void)my_pclose(myfp);
- if (s != Nullch) {
- for (errno = 1; errno < sys_nerr; errno++) {
- if (instr(mybuf, sys_errlist[errno])) /* you don't see this */
- return 0;
- }
- errno = 0;
-#ifndef EACCES
-#define EACCES EPERM
-#endif
- if (instr(mybuf, "cannot make"))
- errno = EEXIST;
- else if (instr(mybuf, "existing file"))
- errno = EEXIST;
- else if (instr(mybuf, "ile exists"))
- errno = EEXIST;
- else if (instr(mybuf, "non-exist"))
- errno = ENOENT;
- else if (instr(mybuf, "does not exist"))
- errno = ENOENT;
- else if (instr(mybuf, "not empty"))
- errno = EBUSY;
- else if (instr(mybuf, "cannot access"))
- errno = EACCES;
- else
- errno = EPERM;
- return 0;
- }
- else { /* some mkdirs return no failure indication */
- tmps = SvPVx(st[1], na);
- anum = (stat(tmps, &statbuf) >= 0);
- if (op->op_type == OP_RMDIR)
- anum = !anum;
- if (anum)
- errno = 0;
- else
- errno = EACCES; /* a guess */
- }
- return anum;
- }
- else
- return 0;
-}
-#endif
-
-PP(pp_mkdir)
-{
- dSP; dTARGET;
- int mode = POPi;
- int oldumask;
- char *tmps = SvPV(TOPs, na);
-
- TAINT_PROPER("mkdir");
-#ifdef HAS_MKDIR
- SETi( mkdir(tmps, mode) >= 0 );
-#else
- SETi( dooneliner("mkdir", tmps) );
- oldumask = umask(0)
- umask(oldumask);
- chmod(tmps, (mode & ~oldumask) & 0777);
-#endif
- RETURN;
-}
-
-PP(pp_rmdir)
-{
- dSP; dTARGET;
- char *tmps;
-
- if (MAXARG < 1)
- tmps = SvPVx(GvSV(defgv), na);
- else
- tmps = POPp;
- TAINT_PROPER("rmdir");
-#ifdef HAS_RMDIR
- XPUSHi( rmdir(tmps) >= 0 );
-#else
- XPUSHi( dooneliner("rmdir", tmps) );
-#endif
- RETURN;
-}
-
-/* Directory calls. */
-
-PP(pp_open_dir)
-{
- dSP;
-#if defined(DIRENT) && defined(HAS_READDIR)
- char *dirname = POPp;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io)
- goto nope;
-
- if (IoDIRP(io))
- closedir(IoDIRP(io));
- if (!(IoDIRP(io) = opendir(dirname)))
- goto nope;
-
- RETPUSHYES;
-nope:
- if (!errno)
- errno = EBADF;
- RETPUSHUNDEF;
-#else
- DIE(no_dir_func, "opendir");
-#endif
-}
-
-PP(pp_readdir)
-{
- dSP;
-#if defined(DIRENT) && defined(HAS_READDIR)
-#ifndef apollo
- struct DIRENT *readdir();
-#endif
- register struct DIRENT *dp;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io || !IoDIRP(io))
- goto nope;
-
- if (GIMME == G_ARRAY) {
- /*SUPPRESS 560*/
- while (dp = readdir(IoDIRP(io))) {
-#ifdef DIRNAMLEN
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
-#else
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
-#endif
- }
- }
- else {
- if (!(dp = readdir(IoDIRP(io))))
- goto nope;
-#ifdef DIRNAMLEN
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
-#else
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
-#endif
- }
- RETURN;
-
-nope:
- if (!errno)
- errno = EBADF;
- if (GIMME == G_ARRAY)
- RETURN;
- else
- RETPUSHUNDEF;
-#else
- DIE(no_dir_func, "readdir");
-#endif
-}
-
-PP(pp_telldir)
-{
- dSP; dTARGET;
-#if defined(HAS_TELLDIR) || defined(telldir)
-#ifndef telldir
- long telldir();
-#endif
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io || !IoDIRP(io))
- goto nope;
-
- PUSHi( telldir(IoDIRP(io)) );
- RETURN;
-nope:
- if (!errno)
- errno = EBADF;
- RETPUSHUNDEF;
-#else
- DIE(no_dir_func, "telldir");
-#endif
-}
-
-PP(pp_seekdir)
-{
- dSP;
-#if defined(HAS_SEEKDIR) || defined(seekdir)
- long along = POPl;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io || !IoDIRP(io))
- goto nope;
-
- (void)seekdir(IoDIRP(io), along);
-
- RETPUSHYES;
-nope:
- if (!errno)
- errno = EBADF;
- RETPUSHUNDEF;
-#else
- DIE(no_dir_func, "seekdir");
-#endif
-}
-
-PP(pp_rewinddir)
-{
- dSP;
-#if defined(HAS_REWINDDIR) || defined(rewinddir)
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io || !IoDIRP(io))
- goto nope;
-
- (void)rewinddir(IoDIRP(io));
- RETPUSHYES;
-nope:
- if (!errno)
- errno = EBADF;
- RETPUSHUNDEF;
-#else
- DIE(no_dir_func, "rewinddir");
-#endif
-}
-
-PP(pp_closedir)
-{
- dSP;
-#if defined(DIRENT) && defined(HAS_READDIR)
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
-
- if (!io || !IoDIRP(io))
- goto nope;
-
- if (closedir(IoDIRP(io)) < 0)
- goto nope;
- IoDIRP(io) = 0;
-
- RETPUSHYES;
-nope:
- if (!errno)
- errno = EBADF;
- RETPUSHUNDEF;
-#else
- DIE(no_dir_func, "closedir");
-#endif
-}
-
-/* Process control. */
-
-PP(pp_fork)
-{
- dSP; dTARGET;
- int childpid;
- GV *tmpgv;
-
- EXTEND(SP, 1);
-#ifdef HAS_FORK
- childpid = fork();
- if (childpid < 0)
- RETSETUNDEF;
- if (!childpid) {
- /*SUPPRESS 560*/
- if (tmpgv = gv_fetchpv("$", TRUE))
- sv_setiv(GvSV(tmpgv), (I32)getpid());
- hv_clear(pidstatus); /* no kids, so don't wait for 'em */
- }
- PUSHi(childpid);
- RETURN;
-#else
- DIE(no_func, "Unsupported function fork");
-#endif
-}
-
-PP(pp_wait)
-{
- dSP; dTARGET;
- int childpid;
- int argflags;
- I32 value;
-
- EXTEND(SP, 1);
-#ifdef HAS_WAIT
- childpid = wait(&argflags);
- if (childpid > 0)
- pidgone(childpid, argflags);
- value = (I32)childpid;
- statusvalue = (U16)argflags;
- PUSHi(value);
- RETURN;
-#else
- DIE(no_func, "Unsupported function wait");
-#endif
-}
-
-PP(pp_waitpid)
-{
- dSP; dTARGET;
- int childpid;
- int optype;
- int argflags;
- I32 value;
-
-#ifdef HAS_WAIT
- optype = POPi;
- childpid = TOPi;
- childpid = wait4pid(childpid, &argflags, optype);
- value = (I32)childpid;
- statusvalue = (U16)argflags;
- SETi(value);
- RETURN;
-#else
- DIE(no_func, "Unsupported function wait");
-#endif
-}
-
-PP(pp_system)
-{
- dSP; dMARK; dORIGMARK; dTARGET;
- I32 value;
- int childpid;
- int result;
- int status;
- VOIDRET (*ihand)(); /* place to save signal during system() */
- VOIDRET (*qhand)(); /* place to save signal during system() */
-
-#ifdef HAS_FORK
- if (SP - MARK == 1) {
- if (tainting) {
- char *junk = SvPV(TOPs, na);
- TAINT_ENV();
- TAINT_PROPER("system");
- }
- }
- while ((childpid = vfork()) == -1) {
- if (errno != EAGAIN) {
- value = -1;
- SP = ORIGMARK;
- PUSHi(value);
- RETURN;
- }
- sleep(5);
- }
- if (childpid > 0) {
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
- result = wait4pid(childpid, &status, 0);
- (void)signal(SIGINT, ihand);
- (void)signal(SIGQUIT, qhand);
- statusvalue = (U16)status;
- if (result < 0)
- value = -1;
- else {
- value = (I32)((unsigned int)status & 0xffff);
- }
- do_execfree(); /* free any memory child malloced on vfork */
- SP = ORIGMARK;
- PUSHi(value);
- RETURN;
- }
- if (op->op_flags & OPf_STACKED) {
- SV *really = *++MARK;
- value = (I32)do_aexec(really, MARK, SP);
- }
- else if (SP - MARK != 1)
- value = (I32)do_aexec(Nullsv, MARK, SP);
- else {
- value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
- }
- _exit(-1);
-#else /* ! FORK */
- if ((op[1].op_type & A_MASK) == A_GV)
- value = (I32)do_aspawn(st[1], arglast);
- else if (arglast[2] - arglast[1] != 1)
- value = (I32)do_aspawn(Nullsv, arglast);
- else {
- value = (I32)do_spawn(SvPVx(sv_mortalcopy(st[2]), na));
- }
- PUSHi(value);
-#endif /* FORK */
- RETURN;
-}
-
-PP(pp_exec)
-{
- dSP; dMARK; dORIGMARK; dTARGET;
- I32 value;
-
- if (op->op_flags & OPf_STACKED) {
- SV *really = *++MARK;
- value = (I32)do_aexec(really, MARK, SP);
- }
- else if (SP - MARK != 1)
- value = (I32)do_aexec(Nullsv, MARK, SP);
- else {
- if (tainting) {
- char *junk = SvPV(*SP, na);
- TAINT_ENV();
- TAINT_PROPER("exec");
- }
- value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
- }
- SP = ORIGMARK;
- PUSHi(value);
- RETURN;
-}
-
-PP(pp_kill)
-{
- dSP; dMARK; dTARGET;
- I32 value;
-#ifdef HAS_KILL
- value = (I32)apply(op->op_type, MARK, SP);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- DIE(no_func, "Unsupported function kill");
-#endif
-}
-
-PP(pp_getppid)
-{
-#ifdef HAS_GETPPID
- dSP; dTARGET;
- XPUSHi( getppid() );
- RETURN;
-#else
- DIE(no_func, "getppid");
-#endif
-}
-
-PP(pp_getpgrp)
-{
-#ifdef HAS_GETPGRP
- dSP; dTARGET;
- int pid;
- I32 value;
-
- if (MAXARG < 1)
- pid = 0;
- else
- pid = SvIVx(POPs);
-#ifdef _POSIX_SOURCE
- if (pid != 0)
- DIE("POSIX getpgrp can't take an argument");
- value = (I32)getpgrp();
-#else
- value = (I32)getpgrp(pid);
-#endif
- XPUSHi(value);
- RETURN;
-#else
- DIE(no_func, "getpgrp()");
-#endif
-}
-
-PP(pp_setpgrp)
-{
-#ifdef HAS_SETPGRP
- dSP; dTARGET;
- int pgrp = POPi;
- int pid = TOPi;
-
- TAINT_PROPER("setpgrp");
- SETi( setpgrp(pid, pgrp) >= 0 );
- RETURN;
-#else
- DIE(no_func, "setpgrp()");
-#endif
-}
-
-PP(pp_getpriority)
-{
- dSP; dTARGET;
- int which;
- int who;
-#ifdef HAS_GETPRIORITY
- who = POPi;
- which = TOPi;
- SETi( getpriority(which, who) );
- RETURN;
-#else
- DIE(no_func, "getpriority()");
-#endif
-}
-
-PP(pp_setpriority)
-{
- dSP; dTARGET;
- int which;
- int who;
- int niceval;
-#ifdef HAS_SETPRIORITY
- niceval = POPi;
- who = POPi;
- which = TOPi;
- TAINT_PROPER("setpriority");
- SETi( setpriority(which, who, niceval) >= 0 );
- RETURN;
-#else
- DIE(no_func, "setpriority()");
-#endif
-}
-
-/* Time calls. */
-
-PP(pp_time)
-{
- dSP; dTARGET;
- XPUSHi( time(Null(long*)) );
- RETURN;
-}
-
-#ifndef HZ
-#define HZ 60
-#endif
-
-PP(pp_tms)
-{
- dSP;
-
-#ifdef MSDOS
- DIE("times not implemented");
-#else
- EXTEND(SP, 4);
-
- (void)times(×buf);
-
- PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
- if (GIMME == G_ARRAY) {
- PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
- PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
- PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
- }
- RETURN;
-#endif /* MSDOS */
-}
-
-PP(pp_localtime)
-{
- return pp_gmtime(ARGS);
-}
-
-PP(pp_gmtime)
-{
- dSP;
- time_t when;
- struct tm *tmbuf;
- static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
- static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
- "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
-
- if (MAXARG < 1)
- (void)time(&when);
- else
- when = (time_t)SvIVx(POPs);
-
- if (op->op_type == OP_LOCALTIME)
- tmbuf = localtime(&when);
- else
- tmbuf = gmtime(&when);
-
- EXTEND(SP, 9);
- if (GIMME != G_ARRAY) {
- dTARGET;
- char mybuf[30];
- if (!tmbuf)
- RETPUSHUNDEF;
- sprintf(mybuf, "%s %s %2d %02d:%02d:%02d %d",
- dayname[tmbuf->tm_wday],
- monname[tmbuf->tm_mon],
- tmbuf->tm_mday,
- tmbuf->tm_hour,
- tmbuf->tm_min,
- tmbuf->tm_sec,
- tmbuf->tm_year + 1900);
- PUSHp(mybuf, strlen(mybuf));
- }
- else if (tmbuf) {
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
- }
- RETURN;
-}
-
-PP(pp_alarm)
-{
- dSP; dTARGET;
- int anum;
-#ifdef HAS_ALARM
- if (MAXARG < 1)
- anum = SvIVx(GvSV(defgv));
- else
- anum = POPi;
- anum = alarm((unsigned int)anum);
- EXTEND(SP, 1);
- if (anum < 0)
- RETPUSHUNDEF;
- PUSHi((I32)anum);
- RETURN;
-#else
- DIE(no_func, "Unsupported function alarm");
- break;
-#endif
-}
-
-PP(pp_sleep)
-{
- dSP; dTARGET;
- char *tmps;
- I32 duration;
- time_t lasttime;
- time_t when;
-
- (void)time(&lasttime);
- if (MAXARG < 1)
- pause();
- else {
- duration = POPi;
- sleep((unsigned int)duration);
- }
- (void)time(&when);
- XPUSHi(when - lasttime);
- RETURN;
-}
-
-/* Shared memory. */
-
-PP(pp_shmget)
-{
- return pp_semget(ARGS);
-}
-
-PP(pp_shmctl)
-{
- return pp_semctl(ARGS);
-}
-
-PP(pp_shmread)
-{
- return pp_shmwrite(ARGS);
-}
-
-PP(pp_shmwrite)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- pp_semget(ARGS);
-#endif
-}
-
-/* Message passing. */
-
-PP(pp_msgget)
-{
- return pp_semget(ARGS);
-}
-
-PP(pp_msgctl)
-{
- return pp_semctl(ARGS);
-}
-
-PP(pp_msgsnd)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- pp_semget(ARGS);
-#endif
-}
-
-PP(pp_msgrcv)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- pp_semget(ARGS);
-#endif
-}
-
-/* Semaphores. */
-
-PP(pp_semget)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- int anum = do_ipcget(op->op_type, MARK, SP);
- SP = MARK;
- if (anum == -1)
- RETPUSHUNDEF;
- PUSHi(anum);
- RETURN;
-#else
- DIE("System V IPC is not implemented on this machine");
-#endif
-}
-
-PP(pp_semctl)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- int anum = do_ipcctl(op->op_type, MARK, SP);
- SP = MARK;
- if (anum == -1)
- RETSETUNDEF;
- if (anum != 0) {
- PUSHi(anum);
- }
- else {
- PUSHp("0 but true",10);
- }
- RETURN;
-#else
- pp_semget(ARGS);
-#endif
-}
-
-PP(pp_semop)
-{
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- dSP; dMARK; dTARGET;
- I32 value = (I32)(do_semop(MARK, SP) >= 0);
- SP = MARK;
- PUSHi(value);
- RETURN;
-#else
- pp_semget(ARGS);
-#endif
-}
-
-/* Eval. */
-
-static void
-save_lines(array, sv)
-AV *array;
-SV *sv;
-{
- register char *s = SvPVX(sv);
- register char *send = SvPVX(sv) + SvCUR(sv);
- register char *t;
- register I32 line = 1;
-
- while (s && s < send) {
- SV *tmpstr = NEWSV(85,0);
-
- sv_upgrade(tmpstr, SVt_PVMG);
- t = strchr(s, '\n');
- if (t)
- t++;
- else
- t = send;
-
- sv_setpvn(tmpstr, s, t - s);
- av_store(array, line++, tmpstr);
- s = t;
- }
-}
-
-OP *
-doeval()
-{
- dSP;
- OP *saveop = op;
- HV *newstash;
-
- in_eval = 1;
-
- /* set up a scratch pad */
-
- SAVEINT(padix);
- SAVESPTR(curpad);
- SAVESPTR(comppad);
- SAVESPTR(comppad_name);
- SAVEINT(comppad_name_fill);
- SAVEINT(min_intro_pending);
- SAVEINT(max_intro_pending);
- comppad = newAV();
- comppad_name = newAV();
- comppad_name_fill = 0;
- min_intro_pending = 0;
- av_push(comppad, Nullsv);
- curpad = AvARRAY(comppad);
- padix = 0;
-
- /* make sure we compile in the right package */
-
- newstash = curcop->cop_stash;
- if (curstash != newstash) {
- SAVESPTR(curstash);
- curstash = newstash;
- }
- SAVESPTR(beginav);
- beginav = 0;
-
- /* try to compile it */
-
- eval_root = Nullop;
- error_count = 0;
- curcop = &compiling;
- rs = "\n";
- rslen = 1;
- rschar = '\n';
- rspara = 0;
- if (yyparse() || error_count || !eval_root) {
- SV **newsp;
- I32 gimme;
- CONTEXT *cx;
- I32 optype;
-
- op = saveop;
- if (eval_root) {
- op_free(eval_root);
- eval_root = Nullop;
- }
- POPBLOCK(cx);
- POPEVAL(cx);
- pop_return();
- lex_end();
- LEAVE;
- if (optype == OP_REQUIRE)
- DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE)), na));
- rs = nrs;
- rslen = nrslen;
- rschar = nrschar;
- rspara = (nrslen == 2);
- RETPUSHUNDEF;
- }
- rs = nrs;
- rslen = nrslen;
- rschar = nrschar;
- rspara = (nrslen == 2);
- compiling.cop_line = 0;
- SAVEFREESV(comppad_name);
- SAVEFREESV(comppad);
- SAVEFREEOP(eval_root);
-
- DEBUG_x(dump_eval());
-
- /* compiled okay, so do it */
-
- sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
- RETURNOP(eval_start);
-}
-
-PP(pp_require)
-{
- dSP;
- register CONTEXT *cx;
- SV *sv;
- char *name;
- char *tmpname;
- SV** svp;
- I32 gimme = G_SCALAR;
- FILE *tryrsfp = 0;
-
- if (MAXARG < 1) {
- sv = GvSV(defgv);
- EXTEND(SP, 1);
- }
- else
- sv = POPs;
- if (SvNIOK(sv) && !SvPOKp(sv)) {
- if (SvNV(sv) > atof(patchlevel) + 0.000999)
- DIE("Perl %3.3f required--this is only version %s, stopped",
- SvNV(sv),patchlevel);
- RETPUSHYES;
- }
- name = SvPV(sv, na);
- if (op->op_type == OP_REQUIRE &&
- (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
- *svp != &sv_undef)
- RETPUSHYES;
-
- /* prepare to compile file */
-
- tmpname = savestr(name);
- if (*tmpname == '/' ||
- (*tmpname == '.' &&
- (tmpname[1] == '/' ||
- (tmpname[1] == '.' && tmpname[2] == '/'))))
- {
- tryrsfp = fopen(tmpname,"r");
- }
- else {
- AV *ar = GvAVn(incgv);
- I32 i;
-
- for (i = 0; i <= AvFILL(ar); i++) {
- (void)sprintf(buf, "%s/%s",
- SvPVx(*av_fetch(ar, i, TRUE), na), name);
- tryrsfp = fopen(buf, "r");
- if (tryrsfp) {
- char *s = buf;
-
- if (*s == '.' && s[1] == '/')
- s += 2;
- Safefree(tmpname);
- tmpname = savestr(s);
- break;
+ 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));
+ }
}
- }
- }
- compiling.cop_filegv = gv_fetchfile(tmpname);
- Safefree(tmpname);
- tmpname = Nullch;
- if (!tryrsfp) {
- if (op->op_type == OP_REQUIRE) {
- sprintf(tokenbuf,"Can't locate %s in @INC", name);
- if (instr(tokenbuf,".h "))
- strcat(tokenbuf," (change .h to .ph maybe?)");
- if (instr(tokenbuf,".ph "))
- strcat(tokenbuf," (did you run h2ph?)");
- DIE("%s",tokenbuf);
- }
-
- RETPUSHUNDEF;
- }
-
- ENTER;
- SAVETMPS;
- lex_start(sv_2mortal(newSVpv("",0)));
- rsfp = tryrsfp;
- name = savestr(name);
- SAVEFREEPV(name);
-
- /* switch to eval mode */
-
- push_return(op->op_next);
- PUSHBLOCK(cx, CXt_EVAL, SP);
- PUSHEVAL(cx, name, compiling.cop_filegv);
-
- compiling.cop_line = 0;
-
- PUTBACK;
- return doeval();
-}
-
-PP(pp_dofile)
-{
- return pp_require(ARGS);
-}
-
-PP(pp_entereval)
-{
- dSP;
- register CONTEXT *cx;
- dPOPss;
- I32 gimme = GIMME;
- char tmpbuf[32];
-
- ENTER;
- SAVETMPS;
- lex_start(sv);
-
- /* switch to eval mode */
-
- sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
- compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
- compiling.cop_line = 1;
- SAVEDELETE(defstash, savestr(tmpbuf), strlen(tmpbuf));
-
- push_return(op->op_next);
- PUSHBLOCK(cx, CXt_EVAL, SP);
- PUSHEVAL(cx, 0, compiling.cop_filegv);
-
- /* prepare to compile string */
-
- if (perldb && curstash != debstash)
- save_lines(GvAV(compiling.cop_filegv), linestr);
- PUTBACK;
- return doeval();
-}
-
-PP(pp_leaveeval)
-{
- dSP;
- register SV **mark;
- SV **newsp;
- I32 gimme;
- register CONTEXT *cx;
- OP *retop;
- I32 optype;
- OP *eroot = eval_root;
-
- POPBLOCK(cx);
- POPEVAL(cx);
- retop = pop_return();
-
- if (gimme == G_SCALAR) {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & SVs_TEMP)
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &sv_undef;
- }
- SP = MARK;
- }
- else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(TOPs) & SVs_TEMP))
- *mark = sv_mortalcopy(*mark);
- /* in case LEAVE wipes old return values */
- }
-
- if (optype != OP_ENTEREVAL) {
- char *name = cx->blk_eval.old_name;
-
- if (gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp) {
- (void)hv_store(GvHVn(incgv), name,
- strlen(name), newSVsv(GvSV(curcop->cop_filegv)), 0 );
- }
- else if (optype == OP_REQUIRE)
- retop = die("%s did not return a true value", name);
- }
-
- lex_end();
- LEAVE;
- sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
-
- RETURNOP(retop);
-}
-
-PP(pp_evalonce)
-{
- dSP;
-#ifdef NOTDEF
- SP = do_eval(st[1], OP_EVAL, curcop->cop_stash, TRUE,
- GIMME, arglast);
- if (eval_root) {
- SvREFCNT_dec(cSVOP->op_sv);
- op[1].arg_ptr.arg_cmd = eval_root;
- op[1].op_type = (A_CMD|A_DONT);
- op[0].op_type = OP_TRY;
- }
- RETURN;
-
-#endif
- RETURN;
-}
-
-PP(pp_entertry)
-{
- dSP;
- register CONTEXT *cx;
- I32 gimme = GIMME;
-
- ENTER;
- SAVETMPS;
-
- push_return(cLOGOP->op_other->op_next);
- PUSHBLOCK(cx, CXt_EVAL, SP);
- PUSHEVAL(cx, 0, 0);
- eval_root = op; /* Only needed so that goto works right. */
-
- in_eval = 1;
- sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
- RETURN;
-}
-
-PP(pp_leavetry)
-{
- dSP;
- register SV **mark;
- SV **newsp;
- I32 gimme;
- register CONTEXT *cx;
- I32 optype;
-
- POPBLOCK(cx);
- POPEVAL(cx);
- pop_return();
-
- if (gimme == G_SCALAR) {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &sv_undef;
- }
- SP = MARK;
- }
- else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)))
- *mark = sv_mortalcopy(*mark);
- /* in case LEAVE wipes old return values */
- }
-
- LEAVE;
- sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
- RETURN;
-}
-
-/* Get system info. */
-
-PP(pp_ghbyname)
-{
-#ifdef HAS_SOCKET
- return pp_ghostent(ARGS);
-#else
- DIE(no_sock_func, "gethostbyname");
+ 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 = ntohl(aulong);
#endif
-}
-
-PP(pp_ghbyaddr)
-{
-#ifdef HAS_SOCKET
- return pp_ghostent(ARGS);
-#else
- DIE(no_sock_func, "gethostbyaddr");
+#ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
#endif
-}
-
-PP(pp_ghostent)
-{
- dSP;
-#ifdef HAS_SOCKET
- I32 which = op->op_type;
- register char **elem;
- register SV *sv;
- struct hostent *gethostbyname();
- struct hostent *gethostbyaddr();
-#ifdef HAS_GETHOSTENT
- struct hostent *gethostent();
+ 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 = ntohl(aulong);
#endif
- struct hostent *hent;
- unsigned long len;
-
- EXTEND(SP, 10);
- if (which == OP_GHBYNAME) {
- hent = gethostbyname(POPp);
- }
- else if (which == OP_GHBYADDR) {
- int addrtype = POPi;
- SV *addrstr = POPs;
- char *addr = SvPV(addrstr, na);
-
- hent = gethostbyaddr(addr, SvCUR(addrstr), addrtype);
- }
- else
-#ifdef HAS_GETHOSTENT
- hent = gethostent();
-#else
- DIE("gethostent not implemented");
+#ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
#endif
-
-#ifdef HOST_NOT_FOUND
- if (!hent)
- statusvalue = (U16)h_errno & 0xffff;
+ 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, 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':
+ 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':
+ 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 (aquad <= 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':
+ along = (strend - s) * 3 / 4;
+ sv = NEWSV(42, along);
+ if (along)
+ SvPOK_on(sv);
+ while (s < strend && *s > ' ' && *s < 'a') {
+ I32 a, b, c, d;
+ char hunk[4];
- if (GIMME != G_ARRAY) {
- PUSHs(sv = sv_newmortal());
- if (hent) {
- if (which == OP_GHBYNAME) {
- sv_setpvn(sv, hent->h_addr, hent->h_length);
+ hunk[3] = '\0';
+ len = (*s++ - ' ') & 077;
+ while (len > 0) {
+ if (s < strend && *s >= ' ')
+ a = (*s++ - ' ') & 077;
+ else
+ a = 0;
+ if (s < strend && *s >= ' ')
+ b = (*s++ - ' ') & 077;
+ else
+ b = 0;
+ if (s < strend && *s >= ' ')
+ c = (*s++ - ' ') & 077;
+ else
+ c = 0;
+ if (s < strend && *s >= ' ')
+ d = (*s++ - ' ') & 077;
+ 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;
}
- else
- sv_setpv(sv, hent->h_name);
+ XPUSHs(sv_2mortal(sv));
+ break;
}
- RETURN;
- }
+ if (checksum) {
+ sv = NEWSV(42, 0);
+ if (strchr("fFdD", datumtype) ||
+ (checksum > 32 && strchr("iIlLN", datumtype)) ) {
+ double trouble;
- if (hent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, hent->h_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = hent->h_aliases; *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvn(sv, " ", 1);
- }
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)hent->h_addrtype);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- len = hent->h_length;
- sv_setiv(sv, (I32)len);
-#ifdef h_addr
- for (elem = hent->h_addr_list; *elem; elem++) {
- XPUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpvn(sv, *elem, len);
+ 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;
}
-#else
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpvn(sv, hent->h_addr, len);
-#endif /* h_addr */
}
+ if (sp == oldsp && gimme == G_SCALAR)
+ PUSHs(&sv_undef);
RETURN;
-#else
- DIE(no_sock_func, "gethostent");
-#endif
-}
-
-PP(pp_gnbyname)
-{
-#ifdef HAS_SOCKET
- return pp_gnetent(ARGS);
-#else
- DIE(no_sock_func, "getnetbyname");
-#endif
-}
-
-PP(pp_gnbyaddr)
-{
-#ifdef HAS_SOCKET
- return pp_gnetent(ARGS);
-#else
- DIE(no_sock_func, "getnetbyaddr");
-#endif
}
-PP(pp_gnetent)
+static void
+doencodes(register SV *sv, register char *s, register I32 len)
{
- dSP;
-#ifdef HAS_SOCKET
- I32 which = op->op_type;
- register char **elem;
- register SV *sv;
- struct netent *getnetbyname();
- struct netent *getnetbyaddr();
- struct netent *getnetent();
- struct netent *nent;
-
- if (which == OP_GNBYNAME)
- nent = getnetbyname(POPp);
- else if (which == OP_GNBYADDR) {
- int addrtype = POPi;
- unsigned long addr = U_L(POPn);
- nent = getnetbyaddr((long)addr, addrtype);
- }
- else
- nent = getnetent();
+ char hunk[5];
- EXTEND(SP, 4);
- if (GIMME != G_ARRAY) {
- PUSHs(sv = sv_newmortal());
- if (nent) {
- if (which == OP_GNBYNAME)
- sv_setiv(sv, (I32)nent->n_net);
- else
- sv_setpv(sv, nent->n_name);
- }
- RETURN;
+ *hunk = len + ' ';
+ sv_catpvn(sv, hunk, 1);
+ hunk[4] = '\0';
+ while (len > 0) {
+ hunk[0] = ' ' + (077 & (*s >> 2));
+ hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)));
+ hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)));
+ hunk[3] = ' ' + (077 & (s[2] & 077));
+ sv_catpvn(sv, hunk, 4);
+ s += 3;
+ len -= 3;
}
-
- if (nent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, nent->n_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = nent->n_aliases; *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvn(sv, " ", 1);
- }
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)nent->n_addrtype);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)nent->n_net);
+ for (s = SvPVX(sv); *s; s++) {
+ if (*s == ' ')
+ *s = '`';
}
-
- RETURN;
-#else
- DIE(no_sock_func, "getnetent");
-#endif
-}
-
-PP(pp_gpbyname)
-{
-#ifdef HAS_SOCKET
- return pp_gprotoent(ARGS);
-#else
- DIE(no_sock_func, "getprotobyname");
-#endif
+ sv_catpvn(sv, "\n", 1);
}
-PP(pp_gpbynumber)
-{
-#ifdef HAS_SOCKET
- return pp_gprotoent(ARGS);
-#else
- DIE(no_sock_func, "getprotobynumber");
-#endif
+static SV *
+is_an_int(char *s, STRLEN l)
+{
+ SV *result = newSVpv("", l);
+ char *result_c = SvPV(result, 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);
}
-PP(pp_gprotoent)
+static int
+div128(SV *pnum, bool *done)
+ /* must be '\0' terminated */
+
{
- dSP;
-#ifdef HAS_SOCKET
- I32 which = op->op_type;
- register char **elem;
- register SV *sv;
- struct protoent *getprotobyname();
- struct protoent *getprotobynumber();
- struct protoent *getprotoent();
- struct protoent *pent;
-
- if (which == OP_GPBYNAME)
- pent = getprotobyname(POPp);
- else if (which == OP_GPBYNUMBER)
- pent = getprotobynumber(POPi);
- else
- pent = getprotoent();
+ STRLEN len;
+ char *s = SvPV(pnum, len);
+ int m = 0;
+ int r = 0;
+ char *t = s;
- EXTEND(SP, 3);
- if (GIMME != G_ARRAY) {
- PUSHs(sv = sv_newmortal());
- if (pent) {
- if (which == OP_GPBYNAME)
- sv_setiv(sv, (I32)pent->p_proto);
- else
- sv_setpv(sv, pent->p_name);
- }
- RETURN;
- }
+ *done = 1;
+ while (*t) {
+ int i;
- if (pent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, pent->p_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = pent->p_aliases; *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvn(sv, " ", 1);
- }
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pent->p_proto);
+ i = m * 10 + (*t - '0');
+ m = i & 0x7F;
+ r = (i >> 7); /* r < 10 */
+ if (r) {
+ *done = 0;
}
-
- RETURN;
-#else
- DIE(no_sock_func, "getprotoent");
-#endif
-}
-
-PP(pp_gsbyname)
-{
-#ifdef HAS_SOCKET
- return pp_gservent(ARGS);
-#else
- DIE(no_sock_func, "getservbyname");
-#endif
+ *(t++) = '0' + r;
+ }
+ *(t++) = '\0';
+ SvCUR_set(pnum, (STRLEN) (t - s));
+ return (m);
}
-PP(pp_gsbyport)
-{
-#ifdef HAS_SOCKET
- return pp_gservent(ARGS);
-#else
- DIE(no_sock_func, "getservbyport");
-#endif
-}
-PP(pp_gservent)
+PP(pp_pack)
{
- dSP;
-#ifdef HAS_SOCKET
- I32 which = op->op_type;
- register char **elem;
- register SV *sv;
- struct servent *getservbyname();
- struct servent *getservbynumber();
- struct servent *getservent();
- struct servent *sent;
-
- if (which == OP_GSBYNAME) {
- char *proto = POPp;
- char *name = POPp;
+ 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 = " ";
- if (proto && !*proto)
- proto = Nullch;
+ /* 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;
- sent = getservbyname(name, proto);
- }
- else if (which == OP_GSBYPORT) {
- char *proto = POPp;
- int port = POPi;
+ items = SP - MARK;
+ MARK++;
+ sv_setpvn(cat, "", 0);
+ while (pat < patend) {
+#define NEXTFROM (items-- > 0 ? *MARK++ : &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 && 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;
- sent = getservbyport(port, proto);
- }
- else
- sent = getservent();
+ 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';
- EXTEND(SP, 4);
- if (GIMME != G_ARRAY) {
- PUSHs(sv = sv_newmortal());
- if (sent) {
- if (which == OP_GSBYNAME) {
-#ifdef HAS_NTOHS
- sv_setiv(sv, (I32)ntohs(sent->s_port));
-#else
- sv_setiv(sv, (I32)(sent->s_port));
-#endif
+ pat = savepat;
+ items = saveitems;
}
- else
- sv_setpv(sv, sent->s_name);
- }
- RETURN;
- }
-
- if (sent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, sent->s_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = sent->s_aliases; *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvn(sv, " ", 1);
- }
- PUSHs(sv = sv_mortalcopy(&sv_no));
-#ifdef HAS_NTOHS
- sv_setiv(sv, (I32)ntohs(sent->s_port));
-#else
- sv_setiv(sv, (I32)(sent->s_port));
-#endif
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, sent->s_proto);
- }
-
- RETURN;
-#else
- DIE(no_sock_func, "getservent");
-#endif
-}
-
-PP(pp_shostent)
-{
- dSP;
-#ifdef HAS_SOCKET
- sethostent(TOPi);
- RETSETYES;
-#else
- DIE(no_sock_func, "sethostent");
-#endif
-}
+ break;
+ case 'H':
+ case 'h':
+ {
+ char *savepat = pat;
+ I32 saveitems;
-PP(pp_snetent)
-{
- dSP;
-#ifdef HAS_SOCKET
- setnetent(TOPi);
- RETSETYES;
-#else
- DIE(no_sock_func, "setnetent");
-#endif
-}
+ 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';
-PP(pp_sprotoent)
-{
- dSP;
-#ifdef HAS_SOCKET
- setprotoent(TOPi);
- RETSETYES;
-#else
- DIE(no_sock_func, "setprotoent");
+ 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 = htons(ashort);
#endif
-}
-
-PP(pp_sservent)
-{
- dSP;
-#ifdef HAS_SOCKET
- setservent(TOPi);
- RETSETYES;
-#else
- DIE(no_sock_func, "setservent");
+ 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));
-PP(pp_ehostent)
-{
- dSP;
-#ifdef HAS_SOCKET
- endhostent();
- EXTEND(sp,1);
- RETPUSHYES;
-#else
- DIE(no_sock_func, "endhostent");
-#endif
-}
+ if (adouble < 0)
+ croak("Cannot compress negative numbers");
-PP(pp_enetent)
-{
- dSP;
-#ifdef HAS_SOCKET
- endnetent();
- EXTEND(sp,1);
- RETPUSHYES;
+ if (
+#ifdef BW_BITS
+ adouble <= BW_MASK
#else
- DIE(no_sock_func, "endnetent");
-#endif
-}
-
-PP(pp_eprotoent)
-{
- dSP;
-#ifdef HAS_SOCKET
- endprotoent();
- EXTEND(sp,1);
- RETPUSHYES;
+#ifdef CXUX_BROKEN_CONSTANT_CONVERT
+ adouble <= UV_MAX_cxux
#else
- DIE(no_sock_func, "endprotoent");
+ adouble <= UV_MAX
#endif
-}
-
-PP(pp_eservent)
-{
- dSP;
-#ifdef HAS_SOCKET
- endservent();
- EXTEND(sp,1);
- RETPUSHYES;
-#else
- DIE(no_sock_func, "endservent");
#endif
-}
+ )
+ {
+ char buf[1 + sizeof(UV)];
+ char *in = buf + sizeof(buf);
+ UV auv = U_V(adouble);;
-PP(pp_gpwnam)
-{
-#ifdef HAS_PASSWD
- return pp_gpwent(ARGS);
-#else
- DIE(no_func, "getpwnam");
+ 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 = htonl(aulong);
#endif
-}
-
-PP(pp_gpwuid)
-{
-#ifdef HAS_PASSWD
- return pp_gpwent(ARGS);
-#else
- DIE(no_func, "getpwuid");
+ CAT32(cat, &aulong);
+ }
+ break;
+ case 'V':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+#ifdef HAS_HTOVL
+ aulong = htovl(aulong);
#endif
-}
-
-PP(pp_gpwent)
-{
- dSP;
-#ifdef HAS_PASSWD
- I32 which = op->op_type;
- register AV *ary = stack;
- register SV *sv;
- struct passwd *getpwnam();
- struct passwd *getpwuid();
- struct passwd *getpwent();
- struct passwd *pwent;
-
- if (which == OP_GPWNAM)
- pwent = getpwnam(POPp);
- else if (which == OP_GPWUID)
- pwent = getpwuid(POPi);
- else
- pwent = getpwent();
-
- EXTEND(SP, 10);
- if (GIMME != G_ARRAY) {
- PUSHs(sv = sv_newmortal());
- if (pwent) {
- if (which == OP_GPWNAM)
- sv_setiv(sv, (I32)pwent->pw_uid);
+ 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 == &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 (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
+ warn("Attempt to pack pointer to temporary value");
+ if (SvPOK(fromstr) || SvNIOK(fromstr))
+ aptr = SvPV(fromstr,na);
+ else
+ aptr = SvPV_force(fromstr,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
- sv_setpv(sv, pwent->pw_name);
- }
- RETURN;
- }
+ len = len / 3 * 3;
+ while (fromlen > 0) {
+ I32 todo;
- if (pwent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, pwent->pw_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, pwent->pw_passwd);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_uid);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_gid);
- PUSHs(sv = sv_mortalcopy(&sv_no));
-#ifdef PWCHANGE
- sv_setiv(sv, (I32)pwent->pw_change);
-#else
-#ifdef PWQUOTA
- sv_setiv(sv, (I32)pwent->pw_quota);
-#else
-#ifdef PWAGE
- sv_setpv(sv, pwent->pw_age);
-#endif
-#endif
-#endif
- PUSHs(sv = sv_mortalcopy(&sv_no));
-#ifdef PWCLASS
- sv_setpv(sv, pwent->pw_class);
-#else
-#ifdef PWCOMMENT
- sv_setpv(sv, pwent->pw_comment);
-#endif
-#endif
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, pwent->pw_gecos);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, pwent->pw_dir);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, pwent->pw_shell);
-#ifdef PWEXPIRE
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_expire);
-#endif
+ if (fromlen > len)
+ todo = len;
+ else
+ todo = fromlen;
+ doencodes(cat, aptr, todo);
+ fromlen -= todo;
+ aptr += todo;
+ }
+ break;
+ }
}
+ SvSETMAGIC(cat);
+ SP = ORIGMARK;
+ PUSHs(cat);
RETURN;
-#else
- DIE(no_func, "getpwent");
-#endif
}
+#undef NEXTFROM
-PP(pp_spwent)
+PP(pp_split)
{
- dSP; dTARGET;
-#ifdef HAS_PASSWD
- setpwent();
- RETPUSHYES;
-#else
- DIE(no_func, "setpwent");
-#endif
-}
+ 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 = curstack;
+ I32 gimme = GIMME_V;
+ I32 oldsave = savestack_ix;
+ I32 stacks_switched = 0;
-PP(pp_epwent)
-{
- dSP; dTARGET;
-#ifdef HAS_PASSWD
- endpwent();
- RETPUSHYES;
+#ifdef DEBUGGING
+ Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
#else
- DIE(no_func, "endpwent");
+ pm = (PMOP*)POPs;
#endif
-}
+ if (!pm || !s)
+ DIE("panic: do_split");
+ rx = pm->op_pmregexp;
-PP(pp_ggrnam)
-{
-#ifdef HAS_GROUP
- return pp_ggrent(ARGS);
-#else
- DIE(no_func, "getgrnam");
-#endif
-}
+ TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
+ (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
-PP(pp_ggrgid)
-{
-#ifdef HAS_GROUP
- return pp_ggrent(ARGS);
+ if (pm->op_pmreplroot)
+ ary = GvAVn((GV*)pm->op_pmreplroot);
+ else if (gimme != G_ARRAY)
+#ifdef USE_THREADS
+ ary = (AV*)curpad[0];
#else
- DIE(no_func, "getgrgid");
-#endif
-}
-
-PP(pp_ggrent)
-{
- dSP;
-#ifdef HAS_GROUP
- I32 which = op->op_type;
- register char **elem;
- register SV *sv;
- struct group *getgrnam();
- struct group *getgrgid();
- struct group *getgrent();
- struct group *grent;
-
- if (which == OP_GGRNAM)
- grent = getgrnam(POPp);
- else if (which == OP_GGRGID)
- grent = getgrgid(POPi);
+ ary = GvAVn(defgv);
+#endif /* USE_THREADS */
else
- grent = getgrent();
-
- EXTEND(SP, 4);
- if (GIMME != G_ARRAY) {
- PUSHs(sv = sv_newmortal());
- if (grent) {
- if (which == OP_GGRNAM)
- sv_setiv(sv, (I32)grent->gr_gid);
- else
- sv_setpv(sv, grent->gr_name);
+ ary = Nullav;
+ if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
+ realarray = 1;
+ av_extend(ary,0);
+ av_clear(ary);
+ if (!SvRMAGICAL(ary) || !mg_find((SV *) ary, 'P')) {
+ if (!AvREAL(ary)) {
+ AvREAL_on(ary);
+ for (i = AvFILLp(ary); i >= 0; i--)
+ AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */
+ }
+ /* temporarily switch stacks */
+ SWITCHSTACK(curstack, ary);
+ stacks_switched = 1;
}
- RETURN;
}
-
- if (grent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, grent->gr_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, grent->gr_passwd);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)grent->gr_gid);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = grent->gr_mem; *elem; elem++) {
- sv_catpv(sv, *elem);
- if (elem[1])
- sv_catpvn(sv, " ", 1);
+ base = SP - 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(multiline);
+ multiline = pm->op_pmflags & PMf_MULTILINE;
+ }
- RETURN;
-#else
- DIE(no_func, "getgrent");
-#endif
-}
+ 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;
-PP(pp_sgrent)
-{
- dSP; dTARGET;
-#ifdef HAS_GROUP
- setgrent();
- RETPUSHYES;
-#else
- DIE(no_func, "setgrent");
-#endif
-}
+ dstr = NEWSV(30, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
-PP(pp_egrent)
-{
- dSP; dTARGET;
-#ifdef HAS_GROUP
- endgrent();
- RETPUSHYES;
-#else
- DIE(no_func, "endgrent");
+ 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 (!realarray)
+ 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 (!realarray)
+ 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)) )
#endif
+ {
+ dstr = NEWSV(31, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ s = m + i;
+ }
+ }
+ }
+ else {
+ maxiters += (strend - s) * rx->nparens;
+ while (s < strend && --limit &&
+ regexec_flags(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 (!realarray)
+ 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 (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ }
+ }
+ s = rx->endp[0];
+ }
+ }
+ LEAVE_SCOPE(oldsave);
+ iters = (SP - 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 (!realarray)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ iters++;
+ }
+ else if (!origlimit) {
+ while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
+ iters--, SP--;
+ }
+ if (realarray) {
+ if (stacks_switched) {
+ 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 {
+ av_extend(ary, iters -1);
+ for (i= 0; i < iters; i++) {
+ dstr = SP[i+1-iters];
+ PUTBACK;
+ fprintf(stderr,"%d:%p %d '%s'\n",i,dstr,SvREFCNT(dstr), SvPV(dstr,na));
+ av_store(ary, i, dstr);
+ SPAGAIN;
+ }
+ if (SvSMAGICAL(ary)) {
+ PUTBACK;
+ mg_set((SV*)ary);
+ SPAGAIN;
+ }
+ for (i= 0; i < iters; i++) {
+ dstr = *av_fetch(ary,i,FALSE);
+ if (SvGMAGICAL(dstr))
+ mg_get(dstr);
+ fprintf(stderr,"%d:%p '%s'\n",i,dstr,SvPV(dstr,na));
+ }
+ if (gimme != G_ARRAY) {
+ SP -= iters;
+ RETURN;
+ }
+ }
+ }
+ else {
+ if (gimme == G_ARRAY)
+ RETURN;
+ }
+ if (iters || !pm->op_pmreplroot) {
+ GETTARGET;
+ PUSHi(iters);
+ RETURN;
+ }
+ RETPUSHUNDEF;
}
-PP(pp_getlogin)
-{
- dSP; dTARGET;
-#ifdef HAS_GETLOGIN
- char *tmps;
- EXTEND(SP, 1);
- if (!(tmps = getlogin()))
- RETPUSHUNDEF;
- PUSHp(tmps, strlen(tmps));
+#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_L(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_L(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;
-#else
- DIE(no_func, "getlogin");
-#endif
}
-/* Miscellaneous. */
-
-PP(pp_syscall)
+PP(pp_threadsv)
{
-#ifdef HAS_SYSCALL
- dSP; dMARK; dORIGMARK; dTARGET;
- register I32 items = SP - MARK;
- unsigned long a[20];
- register I32 i = 0;
- I32 retval = -1;
-
- if (tainting) {
- while (++MARK <= SP) {
- if (SvRMAGICAL(*MARK) && mg_find(*MARK, 't'))
- tainted = TRUE;
- }
- MARK = ORIGMARK;
- TAINT_PROPER("syscall");
- }
-
- /* This probably won't work on machines where sizeof(long) != sizeof(int)
- * or where sizeof(long) != sizeof(char*). But such machines will
- * not likely have syscall implemented either, so who cares?
- */
- while (++MARK <= SP) {
- if (SvNIOK(*MARK) || !i)
- a[i++] = SvIV(*MARK);
- else
- a[i++] = (unsigned long)SvPVX(*MARK);
- if (i > 15)
- break;
- }
- switch (items) {
- default:
- DIE("Too many args to syscall");
- case 0:
- DIE("Too few args to syscall");
- case 1:
- retval = syscall(a[0]);
- break;
- case 2:
- retval = syscall(a[0],a[1]);
- break;
- case 3:
- retval = syscall(a[0],a[1],a[2]);
- break;
- case 4:
- retval = syscall(a[0],a[1],a[2],a[3]);
- break;
- case 5:
- retval = syscall(a[0],a[1],a[2],a[3],a[4]);
- break;
- case 6:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
- break;
- case 7:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
- break;
- case 8:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
- break;
-#ifdef atarist
- case 9:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
- break;
- case 10:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
- break;
- case 11:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10]);
- break;
- case 12:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11]);
- break;
- case 13:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11],a[12]);
- break;
- case 14:
- retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
- a[10],a[11],a[12],a[13]);
- break;
-#endif /* atarist */
- }
- SP = ORIGMARK;
- PUSHi(retval);
+ djSP;
+#ifdef USE_THREADS
+ EXTEND(sp, 1);
+ if (op->op_private & OPpLVAL_INTRO)
+ PUSHs(*save_threadsv(op->op_targ));
+ else
+ PUSHs(*av_fetch(thr->threadsv, op->op_targ, FALSE));
RETURN;
#else
- DIE(no_func, "syscall");
-#endif
+ DIE("tried to access per-thread data in non-threaded perl");
+#endif /* USE_THREADS */
}