summaryrefslogtreecommitdiff
path: root/pp.c
diff options
context:
space:
mode:
Diffstat (limited to 'pp.c')
-rw-r--r--pp.c9703
1 files changed, 9703 insertions, 0 deletions
diff --git a/pp.c b/pp.c
new file mode 100644
index 0000000000..35d2930f8a
--- /dev/null
+++ b/pp.c
@@ -0,0 +1,9703 @@
+/***********************************************************
+ *
+ * $Header: /usr/src/local/lwall/perl5/RCS/pp.c, v 4.1 92/08/07 18:26:21 lwall Exp Locker: lwall $
+ *
+ * Description:
+ * Push/Pop code.
+ *
+ * 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
+ *
+ *
+ **********************************************************/
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef HAS_SOCKET
+#include <sys/socket.h>
+#include <netdb.h>
+#ifndef ENOTSOCK
+#include <net/errno.h>
+#endif
+#endif
+
+#ifdef HAS_SELECT
+#ifdef I_SYS_SELECT
+#ifndef I_SYS_TIME
+#include <sys/select.h>
+#endif
+#endif
+#endif
+
+#ifdef HOST_NOT_FOUND
+extern int h_errno;
+#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
+
+#ifdef I_VARARGS
+# include <varargs.h>
+#endif
+
+/* Nothing. */
+
+PP(pp_null)
+{
+ return NORMAL;
+}
+
+PP(pp_scalar)
+{
+ return NORMAL;
+}
+
+/* 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)
+{
+ dSP;
+ I32 cxix;
+ EXTEND(SP, 1);
+
+ cxix = dopoptosub(cxstack_ix);
+ if (cxix < 0)
+ RETPUSHUNDEF;
+
+ if (cxstack[cxix].blk_gimme == G_ARRAY)
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+}
+
+PP(pp_word)
+{
+ DIE("PP_WORD");
+}
+
+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++;
+ }
+}
+
+static void
+lcase(s,send)
+register char *s;
+register char *send;
+{
+ while (s < send) {
+ if (isUPPER(*s))
+ *s = tolower(*s);
+ s++;
+ }
+}
+
+PP(pp_interp)
+{
+ DIE("panic: pp_interp");
+}
+
+PP(pp_gvsv)
+{
+ dSP;
+ EXTEND(sp,1);
+ if (op->op_flags & OPf_LOCAL)
+ 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_pushre)
+{
+ dSP;
+ XPUSHs((SV*)op);
+ RETURN;
+}
+
+/* Translations. */
+
+PP(pp_rv2gv)
+{
+ dSP; dTOPss;
+ if (SvTYPE(sv) == SVt_REF) {
+ sv = (SV*)SvANY(sv);
+ if (SvTYPE(sv) != SVt_PVGV)
+ DIE("Not a glob reference");
+ }
+ else {
+ if (SvTYPE(sv) != SVt_PVGV)
+ sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
+ }
+ if (op->op_flags & OPf_LOCAL) {
+ GP *ogp = GvGP(sv);
+
+ 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;
+ }
+ }
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_sv2len)
+{
+ dSP; dTARGET;
+ dPOPss;
+ PUSHi(sv_len(sv));
+ RETURN;
+}
+
+PP(pp_rv2sv)
+{
+ dSP; dTOPss;
+
+ if (SvTYPE(sv) == SVt_REF) {
+ sv = (SV*)SvANY(sv);
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ case SVt_PVHV:
+ case SVt_PVCV:
+ DIE("Not a scalar reference");
+ }
+ }
+ else {
+ if (SvTYPE(sv) != SVt_PVGV)
+ sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
+ sv = GvSV(sv);
+ }
+ if (op->op_flags & OPf_LOCAL)
+ SETs(save_scalar((GV*)TOPs));
+ else
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_av2arylen)
+{
+ dSP;
+ AV *av = (AV*)TOPs;
+ SV *sv = AvARYLEN(av);
+ if (!sv) {
+ AvARYLEN(av) = sv = NEWSV(0,0);
+ sv_upgrade(sv, SVt_IV);
+ sv_magic(sv, (SV*)av, '#', Nullch, 0);
+ }
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_rv2cv)
+{
+ dSP;
+ SV *sv;
+ GV *gv;
+ HV *stash;
+ CV *cv = sv_2cv(TOPs, &stash, &gv, 0);
+
+ SETs((SV*)cv);
+ RETURN;
+}
+
+PP(pp_refgen)
+{
+ dSP; dTOPss;
+ SV* rv;
+ if (!sv)
+ RETSETUNDEF;
+ rv = sv_mortalcopy(&sv_undef);
+ sv_upgrade(rv, SVt_REF);
+ SvANY(rv) = (void*)sv_ref(sv);
+ SETs(rv);
+ RETURN;
+}
+
+PP(pp_ref)
+{
+ dSP; dTARGET; dTOPss;
+ char *pv;
+
+ if (SvTYPE(sv) != SVt_REF)
+ RETSETUNDEF;
+
+ sv = (SV*)SvANY(sv);
+ if (SvSTORAGE(sv) == 'O')
+ pv = HvNAME(SvSTASH(sv));
+ else {
+ switch (SvTYPE(sv)) {
+ case SVt_REF: pv = "REF"; break;
+ case SVt_NULL:
+ case SVt_IV:
+ case SVt_NV:
+ case SVt_PV:
+ case SVt_PVIV:
+ case SVt_PVNV:
+ case SVt_PVMG:
+ case SVt_PVBM: 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;
+ }
+ }
+ SETp(pv, strlen(pv));
+ RETURN;
+}
+
+PP(pp_bless)
+{
+ dSP; dTOPss;
+ register SV* ref;
+
+ if (SvTYPE(sv) != SVt_REF)
+ RETSETUNDEF;
+
+ ref = (SV*)SvANY(sv);
+ if (SvSTORAGE(ref) && SvSTORAGE(ref) != 'O')
+ DIE("Can't bless temporary scalar");
+ SvSTORAGE(ref) = 'O';
+ SvUPGRADE(ref, SVt_PVMG);
+ SvSTASH(ref) = curcop->cop_stash;
+ RETURN;
+}
+
+/* Pushy I/O. */
+
+PP(pp_backtick)
+{
+ dSP; dTARGET;
+ FILE *fp;
+ char *tmps = POPp;
+#ifdef TAINT
+ TAINT_PROPER("``");
+#endif
+ 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;
+
+ for (;;) {
+ sv = NEWSV(56, 80);
+ if (sv_gets(sv, fp, 0) == Nullch) {
+ sv_free(sv);
+ break;
+ }
+ XPUSHs(sv_2mortal(sv));
+ if (SvLEN(sv) - SvCUR(sv) > 20) {
+ SvLEN_set(sv, SvCUR(sv)+1);
+ Renew(SvPV(sv), SvLEN(sv), char);
+ }
+ }
+ }
+ statusvalue = my_pclose(fp);
+ }
+ else {
+ statusvalue = -1;
+ if (GIMME == G_SCALAR)
+ RETPUSHUNDEF;
+ }
+
+ RETURN;
+}
+
+OP *
+do_readline()
+{
+ 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 = io->ifp;
+ if (!fp) {
+ if (io->flags & IOf_ARGV) {
+ if (io->flags & IOf_START) {
+ io->flags &= ~IOf_START;
+ io->lines = 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 != io->ifp */
+ (void)do_close(last_in_gv, FALSE); /* now it does*/
+ io->flags |= IOf_START;
+ }
+ }
+ else if (type == OP_GLOB) {
+ SV *tmpcmd = NEWSV(55, 0);
+ SV *tmpglob = POPs;
+#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, SvPV(tmpcmd), SvCUR(tmpcmd));
+ fp = io->ifp;
+ sv_free(tmpcmd);
+ }
+ }
+ 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;
+ }
+ if (GIMME == G_ARRAY) {
+ sv = sv_2mortal(NEWSV(57, 80));
+ offset = 0;
+ }
+ 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 (io->flags & IOf_ARGV) {
+ fp = nextargv(last_in_gv);
+ if (fp)
+ continue;
+ (void)do_close(last_in_gv, FALSE);
+ io->flags |= IOf_START;
+ }
+ else if (type == OP_GLOB) {
+ (void)do_close(last_in_gv, FALSE);
+ }
+ if (GIMME == G_SCALAR)
+ RETPUSHUNDEF;
+ RETURN;
+ }
+ io->lines++;
+ XPUSHs(sv);
+#ifdef TAINT
+ sv->sv_tainted = 1; /* Anything from the outside world...*/
+#endif
+ if (type == OP_GLOB) {
+ char *tmps;
+
+ if (SvCUR(sv) > 0)
+ SvCUR(sv)--;
+ if (*SvEND(sv) == rschar)
+ *SvEND(sv) = '\0';
+ else
+ SvCUR(sv)++;
+ for (tmps = SvPV(sv); *tmps; tmps++)
+ if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
+ index("$&*(){}[]'\";\\|?<>~`", *tmps))
+ break;
+ if (*tmps && stat(SvPV(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(SvPV(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(SvPV(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(SvPVnx(GvSV((GV*)(*stack_sp--))), TRUE);
+ return do_readline();
+}
+
+PP(pp_rcatline)
+{
+ last_in_gv = cGVOP->op_gv;
+ return do_readline();
+}
+
+PP(pp_regcomp) {
+ dSP;
+ register PMOP *pm = (PMOP*)cLOGOP->op_other;
+ register char *t;
+ I32 global;
+ SV *tmpstr;
+ register REGEXP *rx = pm->op_pmregexp;
+
+ global = pm->op_pmflags & PMf_GLOBAL;
+ tmpstr = POPs;
+ t = SvPVn(tmpstr);
+ if (!global && rx)
+ regfree(rx);
+ pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
+ pm->op_pmregexp = regcomp(t, t+SvCUR(tmpstr),
+ 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);
+ op->op_type = OP_NULL;
+ op->op_ppaddr = ppaddr[OP_NULL];
+ /* XXX delete push code */
+ }
+ RETURN;
+}
+
+PP(pp_match)
+{
+ dSP; dTARG;
+ register PMOP *pm = cPMOP;
+ register char *t;
+ register char *s;
+ char *strend;
+ SV *tmpstr;
+ char *myhint = hint;
+ I32 global;
+ I32 safebase;
+ char *truebase;
+ register REGEXP *rx = pm->op_pmregexp;
+ I32 gimme = GIMME;
+
+ hint = Nullch;
+ global = pm->op_pmflags & PMf_GLOBAL;
+ safebase = (gimme == G_ARRAY) || global;
+
+ if (op->op_flags & OPf_STACKED)
+ TARG = POPs;
+ else {
+ TARG = GvSV(defgv);
+ EXTEND(SP,1);
+ }
+ s = SvPVn(TARG);
+ strend = s + SvCUR(TARG);
+ if (!s)
+ DIE("panic: do_match");
+
+ if (pm->op_pmflags & PMf_USED) {
+ if (gimme == G_ARRAY)
+ RETURN;
+ RETPUSHNO;
+ }
+
+ if (!rx->prelen && curpm) {
+ pm = curpm;
+ rx = pm->op_pmregexp;
+ }
+ truebase = t = s;
+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 (myhint) {
+ if (myhint < s || myhint > strend)
+ DIE("panic: hint in do_match");
+ s = myhint;
+ if (rx->regback >= 0) {
+ s -= rx->regback;
+ if (s < t)
+ s = t;
+ }
+ else
+ s = t;
+ }
+ else 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 (*SvPV(pm->op_pmshort) != *s ||
+ bcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) ) {
+ if (pm->op_pmflags & PMf_FOLD) {
+ if (ibcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) )
+ goto nope;
+ }
+ else
+ goto nope;
+ }
+ }
+ if (--BmUSEFUL(pm->op_pmshort) < 0) {
+ sv_free(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 {
+ if (global)
+ rx->startp[0] = Nullch;
+ if (gimme == G_ARRAY)
+ RETURN;
+ RETPUSHNO;
+ }
+ /*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_mortalcopy(&sv_no));
+ /*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 {
+ RETPUSHYES;
+ }
+
+yup:
+ ++BmUSEFUL(pm->op_pmshort);
+ curpm = pm;
+ if (pm->op_pmflags & PMf_ONCE)
+ pm->op_pmflags |= PMf_USED;
+ if (global) {
+ rx->subbeg = t;
+ 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:
+ rx->startp[0] = Nullch;
+ if (pm->op_pmshort)
+ ++BmUSEFUL(pm->op_pmshort);
+ 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;
+ I32 clen;
+ I32 iters = 0;
+ I32 maxiters;
+ register I32 i;
+ bool once;
+ char *orig;
+ I32 safebase;
+ register REGEXP *rx = pm->op_pmregexp;
+
+ 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 = SvPVn(TARG);
+ if (!pm || !s)
+ DIE("panic: do_subst");
+
+ strend = s + SvCUR(TARG);
+ maxiters = (strend - s) + 10;
+
+ if (!rx->prelen && curpm) {
+ pm = curpm;
+ rx = pm->op_pmregexp;
+ }
+ safebase = ((!rx || !rx->nparens) && !sawampersand);
+ orig = m = s;
+ if (hint) {
+ if (hint < s || hint > strend)
+ DIE("panic: hint in do_match");
+ s = hint;
+ hint = Nullch;
+ if (rx->regback >= 0) {
+ s -= rx->regback;
+ if (s < m)
+ s = m;
+ }
+ else
+ s = m;
+ }
+ else 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 (*SvPV(pm->op_pmshort) != *s ||
+ bcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) ) {
+ if (pm->op_pmflags & PMf_FOLD) {
+ if (ibcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) )
+ goto nope;
+ }
+ else
+ goto nope;
+ }
+ }
+ if (--BmUSEFUL(pm->op_pmshort) < 0) {
+ sv_free(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 = SvPVn(dstr);
+ clen = SvCUR(dstr);
+ 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);
+ SvNOK_off(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);
+ SvNOK_off(TARG);
+ SvSETMAGIC(TARG);
+ PUSHs(&sv_yes);
+ RETURN;
+ }
+ else if (clen) {
+ d -= clen;
+ sv_chop(TARG, d);
+ Copy(c, d, clen, char);
+ SvNOK_off(TARG);
+ SvSETMAGIC(TARG);
+ PUSHs(&sv_yes);
+ RETURN;
+ }
+ else {
+ sv_chop(TARG, d);
+ SvNOK_off(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 - SvPV(TARG) + i);
+ Move(s, d, i+1, char); /* include the Null */
+ }
+ SvNOK_off(TARG);
+ SvSETMAGIC(TARG);
+ PUSHs(sv_2mortal(newSVnv((double)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);
+ SvNOK_off(TARG);
+ SvSETMAGIC(TARG);
+ PUSHs(sv_2mortal(newSVnv((double)iters)));
+ RETURN;
+ }
+ PUSHs(&sv_no);
+ RETURN;
+
+nope:
+ ++BmUSEFUL(pm->op_pmshort);
+ PUSHs(&sv_no);
+ RETURN;
+}
+
+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);
+ SvNOK_off(targ);
+ SvSETMAGIC(targ);
+ PUSHs(sv_2mortal(newSVnv((double)(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);
+ }
+ 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);
+}
+
+PP(pp_trans)
+{
+ dSP; dTARG;
+ SV *sv;
+
+ if (op->op_flags & OPf_STACKED)
+ sv = POPs;
+ else {
+ sv = GvSV(defgv);
+ EXTEND(SP,1);
+ }
+ TARG = NEWSV(27,0);
+ PUSHi(do_trans(sv, op));
+ RETURN;
+}
+
+/* Lvalue operators. */
+
+PP(pp_sassign)
+{
+ dSP; dPOPTOPssrl;
+#ifdef TAINT
+ if (tainted && !lstr->sv_tainted)
+ TAINT_NOT;
+#endif
+ SvSetSV(rstr, lstr);
+ SvSETMAGIC(rstr);
+ SETs(rstr);
+ RETURN;
+}
+
+PP(pp_aassign)
+{
+ 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;
+
+ 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;
+ 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);
+ }
+ break;
+ case SVt_PVHV: {
+ char *tmps;
+ SV *tmpstr;
+ MAGIC* magic = 0;
+ I32 magictype;
+
+ hash = (HV*)sv;
+ hv_clear(hash, TRUE); /* wipe any dbm file too */
+
+ while (relem < lastrelem) { /* gobble up all the rest */
+ if (*relem)
+ sv = *(relem++);
+ else
+ sv = &sv_no, relem++;
+ tmps = SvPVn(sv);
+ tmpstr = NEWSV(29,0);
+ if (*relem)
+ sv_setsv(tmpstr,*relem); /* value */
+ *(relem++) = tmpstr;
+ (void)hv_store(hash,tmps,SvCUR(sv),tmpstr,0);
+ }
+ }
+ break;
+ default:
+ if (SvREADONLY(sv)) {
+ if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
+ DIE(no_modify);
+ if (relem <= lastrelem)
+ relem++;
+ 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();
+ }
+ }
+ 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;
+ }
+}
+
+PP(pp_schop)
+{
+ dSP; dTARGET;
+ SV *sv;
+
+ if (MAXARG < 1)
+ sv = GvSV(defgv);
+ else
+ sv = POPs;
+ do_chop(TARG, sv);
+ PUSHTARG;
+ RETURN;
+}
+
+PP(pp_chop)
+{
+ dSP; dMARK; dTARGET;
+ while (SP > MARK)
+ do_chop(TARG, POPs);
+ PUSHTARG;
+ RETURN;
+}
+
+PP(pp_defined)
+{
+ dSP;
+ register SV* sv;
+
+ if (MAXARG < 1) {
+ sv = GvSV(defgv);
+ EXTEND(SP, 1);
+ }
+ else
+ sv = POPs;
+ if (!sv || !SvANY(sv))
+ RETPUSHNO;
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ if (AvMAX(sv) >= 0)
+ RETPUSHYES;
+ break;
+ case SVt_PVHV:
+ if (HvARRAY(sv))
+ RETPUSHYES;
+ break;
+ case SVt_PVCV:
+ if (CvROOT(sv))
+ RETPUSHYES;
+ break;
+ default:
+ if (SvOK(sv))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+}
+
+PP(pp_undef)
+{
+ dSP;
+ SV *sv;
+
+ if (!op->op_private)
+ RETPUSHUNDEF;
+
+ sv = POPs;
+ if (SvREADONLY(sv))
+ RETPUSHUNDEF;
+
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ break;
+ case SVt_PVAV:
+ av_undef((AV*)sv);
+ break;
+ case SVt_PVHV:
+ hv_undef((HV*)sv);
+ break;
+ case SVt_PVCV: {
+ CV *cv = (CV*)sv;
+ op_free(CvROOT(cv));
+ CvROOT(cv) = 0;
+ break;
+ }
+ default:
+ if (sv != GvSV(defgv)) {
+ if (SvPOK(sv) && SvLEN(sv)) {
+ SvOOK_off(sv);
+ Safefree(SvPV(sv));
+ SvPV_set(sv, Nullch);
+ SvLEN_set(sv, 0);
+ }
+ SvOK_off(sv);
+ SvSETMAGIC(sv);
+ }
+ }
+
+ RETPUSHUNDEF;
+}
+
+PP(pp_study)
+{
+ dSP; dTARGET;
+ register unsigned char *s;
+ register I32 pos;
+ register I32 ch;
+ register I32 *sfirst;
+ register I32 *snext;
+ I32 retval;
+
+ s = (unsigned char*)(SvPVn(TARG));
+ pos = SvCUR(TARG);
+ if (lastscream)
+ SvSCREAM_off(lastscream);
+ lastscream = TARG;
+ if (pos <= 0) {
+ retval = 0;
+ goto ret;
+ }
+ 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(newSVnv((double)retval)));
+ RETURN;
+}
+
+PP(pp_preinc)
+{
+ dSP;
+ sv_inc(TOPs);
+ SvSETMAGIC(TOPs);
+ return NORMAL;
+}
+
+PP(pp_predec)
+{
+ dSP;
+ sv_dec(TOPs);
+ SvSETMAGIC(TOPs);
+ return NORMAL;
+}
+
+PP(pp_postinc)
+{
+ dSP; dTARGET;
+ sv_setsv(TARG, TOPs);
+ sv_inc(TOPs);
+ SvSETMAGIC(TOPs);
+ SETs(TARG);
+ return NORMAL;
+}
+
+PP(pp_postdec)
+{
+ dSP; dTARGET;
+ sv_setsv(TARG, TOPs);
+ sv_dec(TOPs);
+ SvSETMAGIC(TOPs);
+ SETs(TARG);
+ return NORMAL;
+}
+
+/* Ordinary operators. */
+
+PP(pp_pow)
+{
+ dSP; dATARGET; dPOPTOPnnrl;
+ SETn( pow( left, right) );
+ RETURN;
+}
+
+PP(pp_multiply)
+{
+ dSP; dATARGET; dPOPTOPnnrl;
+ SETn( left * right );
+ RETURN;
+}
+
+PP(pp_divide)
+{
+ dSP; dATARGET; dPOPnv;
+ if (value == 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) {
+ value = k;
+ } else {
+ value = x/value;
+ }
+ }
+#else
+ value = POPn / value;
+#endif
+ PUSHn( value );
+ RETURN;
+}
+
+PP(pp_modulo)
+{
+ dSP; dATARGET;
+ register unsigned long tmpulong;
+ register long tmplong;
+ I32 value;
+
+ tmpulong = (unsigned long) POPn;
+ if (tmpulong == 0L)
+ 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;
+ }
+ SETi(value);
+ RETURN;
+}
+
+PP(pp_repeat)
+{
+ dSP; dATARGET;
+ register I32 count = POPi;
+ if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
+ dMARK;
+ I32 items = SP - MARK;
+ I32 max;
+
+ max = items * count;
+ MEXTEND(MARK, max);
+ if (count > 1) {
+ while (SP > MARK) {
+ if (*SP)
+ SvTEMP_off((*SP));
+ SP--;
+ }
+ MARK++;
+ repeatcpy(MARK + items, MARK, items * sizeof(SV*), count - 1);
+ }
+ SP += max;
+ }
+ else { /* Note: mark already snarfed by pp_list */
+ SV *tmpstr;
+ char *tmps;
+
+ tmpstr = POPs;
+ SvSetSV(TARG, tmpstr);
+ if (count >= 1) {
+ tmpstr = NEWSV(50, 0);
+ tmps = SvPVn(TARG);
+ sv_setpvn(tmpstr, tmps, SvCUR(TARG));
+ tmps = SvPVn(tmpstr); /* force to be string */
+ SvGROW(TARG, (count * SvCUR(TARG)) + 1);
+ repeatcpy(SvPV(TARG), tmps, SvCUR(tmpstr), count);
+ SvCUR(TARG) *= count;
+ *SvEND(TARG) = '\0';
+ SvNOK_off(TARG);
+ sv_free(tmpstr);
+ }
+ else {
+ if (dowarn && SvPOK(SP[1]) && !looks_like_number(SP[1]))
+ warn("Right operand of x is not numeric");
+ sv_setsv(TARG, &sv_no);
+ }
+ 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;
+}
+
+PP(pp_left_shift)
+{
+ dSP; dATARGET;
+ I32 anum = POPi;
+ double value = TOPn;
+ SETi( U_L(value) << anum );
+ RETURN;
+}
+
+PP(pp_right_shift)
+{
+ dSP; dATARGET;
+ I32 anum = POPi;
+ double value = TOPn;
+ SETi( U_L(value) >> anum );
+ RETURN;
+}
+
+PP(pp_lt)
+{
+ dSP; dPOPnv;
+ SETs((TOPn < value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_gt)
+{
+ dSP; dPOPnv;
+ SETs((TOPn > value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_le)
+{
+ dSP; dPOPnv;
+ SETs((TOPn <= value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_ge)
+{
+ dSP; dPOPnv;
+ SETs((TOPn >= value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_eq)
+{
+ dSP; double value;
+
+ if (dowarn) {
+ if ((!SvNIOK(SP[ 0]) && !looks_like_number(SP[ 0])) ||
+ (!SvNIOK(SP[-1]) && !looks_like_number(SP[-1])) )
+ warn("Possible use of == on string value");
+ }
+
+ value = POPn;
+ SETs((TOPn == value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_ne)
+{
+ dSP; dPOPnv;
+ SETs((TOPn != value) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_ncmp)
+{
+ dSP; dTARGET; dPOPTOPnnrl;
+ I32 value;
+
+ if (left > right)
+ value = 1;
+ else if (left < right)
+ value = -1;
+ else
+ value = 0;
+ SETi(value);
+ RETURN;
+}
+
+PP(pp_slt)
+{
+ dSP; dPOPTOPssrl;
+ SETs( sv_cmp(lstr, rstr) < 0 ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_sgt)
+{
+ dSP; dPOPTOPssrl;
+ SETs( sv_cmp(lstr, rstr) > 0 ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_sle)
+{
+ dSP; dPOPTOPssrl;
+ SETs( sv_cmp(lstr, rstr) <= 0 ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_sge)
+{
+ dSP; dPOPTOPssrl;
+ SETs( sv_cmp(lstr, rstr) >= 0 ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_seq)
+{
+ dSP; dPOPTOPssrl;
+ SETs( sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_sne)
+{
+ dSP; dPOPTOPssrl;
+ SETs( !sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
+ RETURN;
+}
+
+PP(pp_scmp)
+{
+ dSP; dTARGET;
+ dPOPTOPssrl;
+ SETi( sv_cmp(lstr, rstr) );
+ RETURN;
+}
+
+PP(pp_bit_and)
+{
+ dSP; dATARGET; dPOPTOPssrl;
+ if (SvNIOK(lstr) || SvNIOK(rstr)) {
+ I32 value = SvIVn(lstr);
+ value = value & SvIVn(rstr);
+ SETi(value);
+ }
+ else {
+ do_vop(op->op_type, TARG, lstr, rstr);
+ SETTARG;
+ }
+ RETURN;
+}
+
+PP(pp_xor)
+{
+ dSP; dATARGET; dPOPTOPssrl;
+ if (SvNIOK(lstr) || SvNIOK(rstr)) {
+ I32 value = SvIVn(lstr);
+ value = value ^ SvIVn(rstr);
+ SETi(value);
+ }
+ else {
+ do_vop(op->op_type, TARG, lstr, rstr);
+ SETTARG;
+ }
+ RETURN;
+}
+
+PP(pp_bit_or)
+{
+ dSP; dATARGET; dPOPTOPssrl;
+ if (SvNIOK(lstr) || SvNIOK(rstr)) {
+ I32 value = SvIVn(lstr);
+ value = value | SvIVn(rstr);
+ SETi(value);
+ }
+ else {
+ do_vop(op->op_type, TARG, lstr, rstr);
+ SETTARG;
+ }
+ RETURN;
+}
+
+PP(pp_negate)
+{
+ dSP; dTARGET;
+ SETn(-TOPn);
+ RETURN;
+}
+
+PP(pp_not)
+{
+ *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
+ return NORMAL;
+}
+
+PP(pp_complement)
+{
+ dSP; dTARGET; dTOPss;
+ register I32 anum;
+
+ if (SvNIOK(sv)) {
+ SETi( ~SvIVn(sv) );
+ }
+ else {
+ register char *tmps;
+ register long *tmpl;
+
+ SvSetSV(TARG, sv);
+ tmps = SvPVn(TARG);
+ anum = SvCUR(TARG);
+#ifdef LIBERAL
+ for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
+ *tmps = ~*tmps;
+ tmpl = (long*)tmps;
+ for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
+ *tmpl = ~*tmpl;
+ tmps = (char*)tmpl;
+#endif
+ for ( ; anum > 0; anum--, tmps++)
+ *tmps = ~*tmps;
+
+ SETs(TARG);
+ }
+ RETURN;
+}
+
+/* High falutin' math. */
+
+PP(pp_atan2)
+{
+ dSP; dTARGET; dPOPTOPnnrl;
+ SETn(atan2(left, right));
+ RETURN;
+}
+
+PP(pp_sin)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ value = sin(value);
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_cos)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ value = cos(value);
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_rand)
+{
+ 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;
+}
+
+PP(pp_srand)
+{
+ dSP;
+ I32 anum;
+ time_t when;
+
+ if (MAXARG < 1) {
+ (void)time(&when);
+ anum = when;
+ }
+ else
+ anum = POPi;
+ (void)srand(anum);
+ EXTEND(SP, 1);
+ RETPUSHYES;
+}
+
+PP(pp_exp)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ value = exp(value);
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_log)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ if (value <= 0.0)
+ DIE("Can't take log of %g\n", value);
+ value = log(value);
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_sqrt)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ if (value < 0.0)
+ DIE("Can't take sqrt of %g\n", value);
+ value = sqrt(value);
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_int)
+{
+ dSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = SvNVnx(GvSV(defgv));
+ else
+ value = POPn;
+ if (value >= 0.0)
+ (void)modf(value, &value);
+ else {
+ (void)modf(-value, &value);
+ value = -value;
+ }
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_hex)
+{
+ dSP; dTARGET;
+ char *tmps;
+ I32 argtype;
+
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+ XPUSHi( scan_hex(tmps, 99, &argtype) );
+ RETURN;
+}
+
+PP(pp_oct)
+{
+ dSP; dTARGET;
+ I32 value;
+ I32 argtype;
+ char *tmps;
+
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+ while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
+ tmps++;
+ if (*tmps == 'x')
+ value = (I32)scan_hex(++tmps, 99, &argtype);
+ else
+ value = (I32)scan_oct(tmps, 99, &argtype);
+ XPUSHi(value);
+ RETURN;
+}
+
+/* String stuff. */
+
+PP(pp_length)
+{
+ dSP; dTARGET;
+ if (MAXARG < 1) {
+ XPUSHi( sv_len(GvSV(defgv)) );
+ }
+ else
+ SETi( sv_len(TOPs) );
+ RETURN;
+}
+
+PP(pp_substr)
+{
+ dSP; dTARGET;
+ SV *sv;
+ I32 len;
+ I32 curlen;
+ I32 pos;
+ I32 rem;
+ I32 lvalue = op->op_flags & OPf_LVAL;
+ char *tmps;
+
+ if (MAXARG > 2)
+ len = POPi;
+ pos = POPi - arybase;
+ sv = POPs;
+ tmps = SvPVn(sv); /* force conversion to string */
+ curlen = SvCUR(sv);
+ if (pos < 0)
+ pos += curlen + arybase;
+ if (pos < 0 || pos > curlen)
+ sv_setpvn(TARG, "", 0);
+ 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! */
+ LvTYPE(TARG) = 's';
+ LvTARG(TARG) = sv;
+ LvTARGOFF(TARG) = tmps - SvPVn(sv);
+ LvTARGLEN(TARG) = rem;
+ }
+ }
+ PUSHs(TARG); /* avoid SvSETMAGIC here */
+ RETURN;
+}
+
+PP(pp_vec)
+{
+ dSP; dTARGET;
+ register I32 size = POPi;
+ register I32 offset = POPi;
+ register SV *src = POPs;
+ I32 lvalue = op->op_flags & OPf_LVAL;
+ unsigned char *s = (unsigned char*)SvPVn(src);
+ unsigned long retnum;
+ I32 len;
+
+ offset *= size; /* turn into bit offset */
+ len = (offset + size + 7) / 8;
+ if (offset < 0 || size < 1)
+ retnum = 0;
+ else if (!lvalue && len > SvCUR(src))
+ retnum = 0;
+ else {
+ if (len > SvCUR(src)) {
+ SvGROW(src, len);
+ (void)memzero(SvPV(src) + SvCUR(src), len - SvCUR(src));
+ SvCUR_set(src, len);
+ }
+ s = (unsigned char*)SvPVn(src);
+ if (size < 8)
+ retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
+ else {
+ offset >>= 3;
+ if (size == 8)
+ retnum = s[offset];
+ else if (size == 16)
+ retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
+ else if (size == 32)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8) + s[offset+3];
+ }
+
+ if (lvalue) { /* it's an lvalue! */
+ LvTYPE(TARG) = 'v';
+ LvTARG(TARG) = src;
+ LvTARGOFF(TARG) = offset;
+ LvTARGLEN(TARG) = size;
+ }
+ }
+
+ sv_setiv(TARG, (I32)retnum);
+ PUSHs(TARG);
+ RETURN;
+}
+
+PP(pp_index)
+{
+ dSP; dTARGET;
+ SV *big;
+ SV *little;
+ I32 offset;
+ I32 retval;
+ char *tmps;
+ char *tmps2;
+
+ if (MAXARG < 3)
+ offset = 0;
+ else
+ offset = POPi - arybase;
+ little = POPs;
+ big = POPs;
+ tmps = SvPVn(big);
+ if (offset < 0)
+ offset = 0;
+ else if (offset > SvCUR(big))
+ offset = SvCUR(big);
+ if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
+ (unsigned char*)tmps + SvCUR(big), little)))
+ retval = -1 + arybase;
+ else
+ retval = tmps2 - tmps + arybase;
+ PUSHi(retval);
+ RETURN;
+}
+
+PP(pp_rindex)
+{
+ dSP; dTARGET;
+ SV *big;
+ SV *little;
+ SV *offstr;
+ I32 offset;
+ I32 retval;
+ char *tmps;
+ char *tmps2;
+
+ if (MAXARG == 3)
+ offstr = POPs;
+ little = POPs;
+ big = POPs;
+ tmps2 = SvPVn(little);
+ tmps = SvPVn(big);
+ if (MAXARG < 3)
+ offset = SvCUR(big);
+ else
+ offset = SvIVn(offstr) - arybase + SvCUR(little);
+ if (offset < 0)
+ offset = 0;
+ else if (offset > SvCUR(big))
+ offset = SvCUR(big);
+ if (!(tmps2 = rninstr(tmps, tmps + offset,
+ tmps2, tmps2 + SvCUR(little))))
+ retval = -1 + arybase;
+ else
+ retval = tmps2 - tmps + arybase;
+ PUSHi(retval);
+ RETURN;
+}
+
+PP(pp_sprintf)
+{
+ dSP; dMARK; dORIGMARK; dTARGET;
+ do_sprintf(TARG, SP-MARK, MARK+1);
+ SP = ORIGMARK;
+ PUSHTARG;
+ RETURN;
+}
+
+static void
+doparseform(sv)
+SV *sv;
+{
+ register char *s = SvPVn(sv);
+ register char *send = s + SvCUR(sv);
+ 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;
+
+ case '@':
+ case '^':
+ ischop = s[-1] == '^';
+
+ if (postspace) {
+ *fpc++ = FF_SPACE;
+ postspace = FALSE;
+ }
+ arg = (s - base) - 1;
+ if (arg) {
+ *fpc++ = FF_LITERAL;
+ *fpc++ = arg;
+ }
+
+ 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;
+
+ 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 */
+
+ *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
+
+ if (prespace)
+ *fpc++ = prespace;
+ *fpc++ = FF_ITEM;
+ if (ismore)
+ *fpc++ = FF_MORE;
+ if (ischop)
+ *fpc++ = FF_CHOP;
+ }
+ base = s;
+ skipspaces = 0;
+ continue;
+ }
+ }
+ *fpc++ = FF_END;
+
+ arg = fpc - fops;
+ SvGROW(sv, SvCUR(sv) + arg * sizeof(U16) + 4);
+
+ s = SvPV(sv) + SvCUR(sv);
+ s += 2 + (SvCUR(sv) & 1);
+
+ Copy(fops, s, arg, U16);
+ Safefree(fops);
+}
+
+PP(pp_formline)
+{
+ 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 = (index(chopset, ' ') != Nullch);
+ char *chophere;
+ char *linemark;
+ char *formmark;
+ SV **markmark;
+ double value;
+ bool gotsome;
+
+ if (!SvCOMPILED(form))
+ doparseform(form);
+
+ SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
+ t = SvPVn(formtarget);
+ t += SvCUR(formtarget);
+ f = SvPVn(form);
+
+ s = f + SvCUR(form);
+ s += 2 + (SvCUR(form) & 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 = SvPVn(sv);
+ itemsize = SvCUR(sv);
+ 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 - SvPV(sv);
+ break;
+
+ case FF_CHECKCHOP:
+ s = SvPVn(sv);
+ itemsize = SvCUR(sv);
+ if (itemsize > fieldsize)
+ 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 (index(chopset, *s))
+ chophere = s + 1;
+ }
+ s++;
+ }
+ itemsize = chophere - SvPV(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 = SvPV(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 = SvPVn(sv);
+ itemsize = SvCUR(sv);
+ if (itemsize) {
+ gotsome = TRUE;
+ send = s + itemsize;
+ while (s < send) {
+ if (*s++ == '\n') {
+ if (s == send)
+ itemsize--;
+ else
+ lines++;
+ }
+ }
+ SvCUR_set(formtarget, t - SvPV(formtarget));
+ sv_catpvn(formtarget, SvPV(sv), itemsize);
+ SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
+ t = SvPV(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 = SvNVn(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 - t, arg))
+ DIE("Runaway format");
+ }
+ arg = t - SvPV(formtarget);
+ SvGROW(formtarget,
+ (t - SvPV(formtarget)) + (f - formmark) + 1);
+ t = SvPV(formtarget) + arg;
+ }
+ }
+ else {
+ t = linemark;
+ lines--;
+ }
+ break;
+
+ case FF_MORE:
+ if (SvCUR(sv)) {
+ arg = fieldsize - itemsize;
+ if (arg) {
+ fieldsize -= arg;
+ while (arg-- > 0)
+ *t++ = ' ';
+ }
+ s = t - 3;
+ if (strnEQ(s," ",3)) {
+ while (s > SvPV(formtarget) && isSPACE(s[-1]))
+ s--;
+ }
+ *s++ = '.';
+ *s++ = '.';
+ *s++ = '.';
+ }
+ break;
+
+ case FF_END:
+ *t = '\0';
+ SvCUR_set(formtarget, t - SvPV(formtarget));
+ FmLINES(formtarget) += lines;
+ SP = ORIGMARK;
+ RETPUSHYES;
+ }
+ }
+}
+
+PP(pp_ord)
+{
+ dSP; dTARGET;
+ I32 value;
+ char *tmps;
+ I32 anum;
+
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+#ifndef I286
+ value = (I32) (*tmps & 255);
+#else
+ anum = (I32) *tmps;
+ value = (I32) (anum & 255);
+#endif
+ XPUSHi(value);
+ RETURN;
+}
+
+PP(pp_crypt)
+{
+ dSP; dTARGET; dPOPTOPssrl;
+#ifdef HAS_CRYPT
+ char *tmps = SvPVn(lstr);
+#ifdef FCRYPT
+ sv_setpv(TARG, fcrypt(tmps, SvPVn(rstr)));
+#else
+ sv_setpv(TARG, crypt(tmps, SvPVn(rstr)));
+#endif
+#else
+ DIE(
+ "The crypt() function is unimplemented due to excessive paranoia.");
+#endif
+ SETs(TARG);
+ RETURN;
+}
+
+PP(pp_ucfirst)
+{
+ dSP;
+ SV *sv = TOPs;
+ register char *s;
+
+ if (SvSTORAGE(sv) != 'T') {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPVn(sv);
+ if (isascii(*s) && islower(*s))
+ *s = toupper(*s);
+
+ RETURN;
+}
+
+PP(pp_lcfirst)
+{
+ dSP;
+ SV *sv = TOPs;
+ register char *s;
+
+ if (SvSTORAGE(sv) != 'T') {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPVn(sv);
+ if (isascii(*s) && isupper(*s))
+ *s = tolower(*s);
+
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_uc)
+{
+ dSP;
+ SV *sv = TOPs;
+ register char *s;
+ register char *send;
+
+ if (SvSTORAGE(sv) != 'T') {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPVn(sv);
+ send = s + SvCUR(sv);
+ while (s < send) {
+ if (isascii(*s) && islower(*s))
+ *s = toupper(*s);
+ s++;
+ }
+ RETURN;
+}
+
+PP(pp_lc)
+{
+ dSP;
+ SV *sv = TOPs;
+ register char *s;
+ register char *send;
+
+ if (SvSTORAGE(sv) != 'T') {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPVn(sv);
+ send = s + SvCUR(sv);
+ while (s < send) {
+ if (isascii(*s) && isupper(*s))
+ *s = tolower(*s);
+ s++;
+ }
+ RETURN;
+}
+
+/* Arrays. */
+
+PP(pp_rv2av)
+{
+ dSP; dPOPss;
+
+ AV *av;
+
+ if (SvTYPE(sv) == SVt_REF) {
+ av = (AV*)SvANY(sv);
+ if (SvTYPE(av) != SVt_PVAV)
+ DIE("Not an array reference");
+ if (op->op_flags & OPf_LVAL) {
+ if (op->op_flags & OPf_LOCAL)
+ av = (AV*)save_svref(sv);
+ PUSHs((SV*)av);
+ RETURN;
+ }
+ }
+ else {
+ if (SvTYPE(sv) != SVt_PVGV)
+ sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
+ av = GvAVn(sv);
+ if (op->op_flags & OPf_LVAL) {
+ if (op->op_flags & OPf_LOCAL)
+ av = save_ary(sv);
+ PUSHs((SV*)av);
+ RETURN;
+ }
+ }
+
+ 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 = (AV*)cSVOP->op_sv;
+ SV** svp = av_fetch(av, op->op_private - arybase, FALSE);
+ PUSHs(svp ? *svp : &sv_undef);
+ RETURN;
+}
+
+PP(pp_aelem)
+{
+ dSP;
+ SV** svp;
+ I32 elem = POPi - arybase;
+ AV *av = (AV*)POPs;
+
+ if (op->op_flags & OPf_LVAL) {
+ svp = av_fetch(av, elem, TRUE);
+ if (!svp || *svp == &sv_undef)
+ DIE("Assignment to non-creatable value, subscript %d", elem);
+ if (op->op_flags & OPf_LOCAL)
+ save_svref(svp);
+ else if (!SvOK(*svp)) {
+ if (op->op_private == OP_RV2HV) {
+ sv_free(*svp);
+ *svp = (SV*)newHV(COEFFSIZE);
+ }
+ else if (op->op_private == OP_RV2AV) {
+ sv_free(*svp);
+ *svp = (SV*)newAV();
+ }
+ }
+ }
+ else
+ svp = av_fetch(av, elem, FALSE);
+ PUSHs(svp ? *svp : &sv_undef);
+ RETURN;
+}
+
+PP(pp_aslice)
+{
+ dSP; dMARK; dORIGMARK;
+ register SV** svp;
+ register AV* av = (AV*)POPs;
+ register I32 lval = op->op_flags & OPf_LVAL;
+ I32 is_something_there = lval;
+
+ while (++MARK <= SP) {
+ I32 elem = SvIVnx(*MARK);
+
+ if (lval) {
+ svp = av_fetch(av, elem, TRUE);
+ if (!svp || *svp == &sv_undef)
+ DIE("Assignment to non-creatable value, subscript \"%d\"",elem);
+ if (op->op_flags & OPf_LOCAL)
+ save_svref(svp);
+ }
+ else {
+ svp = av_fetch(av, elem, FALSE);
+ if (!is_something_there && svp && SvOK(*svp))
+ is_something_there = TRUE;
+ }
+ *MARK = svp ? *svp : &sv_undef;
+ }
+ if (!is_something_there)
+ SP = ORIGMARK;
+ RETURN;
+}
+
+/* Associative arrays. */
+
+PP(pp_each)
+{
+ dSP; dTARGET;
+ HV *hash = (HV*)POPs;
+ HE *entry = hv_iternext(hash);
+ I32 i;
+ char *tmps;
+
+ if (mystrk) {
+ sv_free(mystrk);
+ mystrk = Nullsv;
+ }
+
+ EXTEND(SP, 2);
+ if (entry) {
+ if (GIMME == G_ARRAY) {
+ tmps = hv_iterkey(entry, &i);
+ if (!i)
+ tmps = "";
+ mystrk = newSVpv(tmps, i);
+ PUSHs(mystrk);
+ }
+ sv_setsv(TARG, hv_iterval(hash, entry));
+ PUSHs(TARG);
+ }
+ else if (GIMME == G_SCALAR)
+ RETPUSHUNDEF;
+
+ RETURN;
+}
+
+PP(pp_values)
+{
+ return do_kv(ARGS);
+}
+
+PP(pp_keys)
+{
+ return do_kv(ARGS);
+}
+
+PP(pp_delete)
+{
+ dSP;
+ SV *sv;
+ SV *tmpsv = POPs;
+ HV *hv = (HV*)POPs;
+ char *tmps;
+ if (!hv) {
+ DIE("Not an associative array reference");
+ }
+ tmps = SvPVn(tmpsv);
+ sv = hv_delete(hv, tmps, SvCUR(tmpsv));
+ if (!sv)
+ RETPUSHUNDEF;
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_rv2hv)
+{
+
+ dSP; dTOPss;
+
+ HV *hv;
+
+ if (SvTYPE(sv) == SVt_REF) {
+ hv = (HV*)SvANY(sv);
+ if (SvTYPE(hv) != SVt_PVHV)
+ DIE("Not an associative array reference");
+ if (op->op_flags & OPf_LVAL) {
+ if (op->op_flags & OPf_LOCAL)
+ hv = (HV*)save_svref(sv);
+ SETs((SV*)hv);
+ RETURN;
+ }
+ }
+ else {
+ if (SvTYPE(sv) != SVt_PVGV)
+ sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
+ hv = GvHVn(sv);
+ if (op->op_flags & OPf_LVAL) {
+ if (op->op_flags & OPf_LOCAL)
+ hv = save_hash(sv);
+ SETs((SV*)hv);
+ RETURN;
+ }
+ }
+
+ if (GIMME == G_ARRAY) { /* array wanted */
+ *stack_sp = (SV*)hv;
+ return do_kv(ARGS);
+ }
+ else {
+ dTARGET;
+ if (HvFILL(hv))
+ sv_setiv(TARG, 0);
+ else {
+ sprintf(buf, "%d/%d", HvFILL(hv),
+ HvFILL(hv)+1);
+ sv_setpv(TARG, buf);
+ }
+ SETTARG;
+ RETURN;
+ }
+}
+
+PP(pp_helem)
+{
+ dSP;
+ SV** svp;
+ SV *keysv = POPs;
+ char *key = SvPVn(keysv);
+ I32 keylen = SvPOK(keysv) ? SvCUR(keysv) : 0;
+ HV *hv = (HV*)POPs;
+
+ if (op->op_flags & OPf_LVAL) {
+ svp = hv_fetch(hv, key, keylen, TRUE);
+ if (!svp || *svp == &sv_undef)
+ DIE("Assignment to non-creatable value, subscript \"%s\"", key);
+ if (op->op_flags & OPf_LOCAL)
+ save_svref(svp);
+ else if (!SvOK(*svp)) {
+ if (op->op_private == OP_RV2HV) {
+ sv_free(*svp);
+ *svp = (SV*)newHV(COEFFSIZE);
+ }
+ else if (op->op_private == OP_RV2AV) {
+ sv_free(*svp);
+ *svp = (SV*)newAV();
+ }
+ }
+ }
+ else
+ svp = hv_fetch(hv, key, keylen, FALSE);
+ PUSHs(svp ? *svp : &sv_undef);
+ RETURN;
+}
+
+PP(pp_hslice)
+{
+ dSP; dMARK; dORIGMARK;
+ register SV **svp;
+ register HV *hv = (HV*)POPs;
+ register I32 lval = op->op_flags & OPf_LVAL;
+ I32 is_something_there = lval;
+
+ while (++MARK <= SP) {
+ char *key = SvPVnx(*MARK);
+ I32 keylen = SvPOK(*MARK) ? SvCUR(*MARK) : 0;
+
+ if (lval) {
+ svp = hv_fetch(hv, key, keylen, TRUE);
+ if (!svp || *svp == &sv_undef)
+ DIE("Assignment to non-creatable value, subscript \"%s\"", key);
+ if (op->op_flags & OPf_LOCAL)
+ save_svref(svp);
+ }
+ else {
+ svp = hv_fetch(hv, key, keylen, FALSE);
+ if (!is_something_there && svp && SvOK(*svp))
+ is_something_there = TRUE;
+ }
+ *MARK = svp ? *svp : &sv_undef;
+ }
+ if (!is_something_there)
+ SP = ORIGMARK;
+ RETURN;
+}
+
+/* Explosives and implosives. */
+
+PP(pp_unpack)
+{
+ dSP;
+ dPOPPOPssrl;
+ SV *sv;
+ register char *pat = SvPVn(lstr);
+ register char *s = SvPVn(rstr);
+ char *strend = s + SvCUR(rstr);
+ char *strbeg = s;
+ register char *patend = pat + SvCUR(lstr);
+ I32 datumtype;
+ register I32 len;
+ register I32 bits;
+
+ /* 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;
+
+ if (GIMME != G_ARRAY) { /* arrange to do first one only */
+ /*SUPPRESS 530*/
+ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
+ if (index("aAbBhH", *patend) || *pat == '%') {
+ patend++;
+ while (isDIGIT(*patend) || *patend == '*')
+ patend++;
+ }
+ else
+ patend++;
+ }
+ while (pat < patend) {
+ reparse:
+ datumtype = *pat++;
+ if (pat >= patend)
+ len = 1;
+ else if (*pat == '*') {
+ len = strend - strbeg; /* long enough */
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = (datumtype != '@');
+ switch(datumtype) {
+ default:
+ 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 = SvPV(sv) + len - 1;
+ while (s >= SvPV(sv) && (!*s || isSPACE(*s)))
+ s--;
+ *++s = '\0';
+ SvCUR_set(sv, s - SvPV(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 = SvPV(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 = SvPV(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));
+ }
+ }
+ break;
+ case 'C':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ uchar_checksum:
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ culong += auint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ sv = NEWSV(37, 0);
+ sv_setiv(sv, (I32)auint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ 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;
+ }
+ }
+ 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));
+ }
+ }
+ 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;
+ }
+ }
+ 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));
+ }
+ }
+ break;
+ case 'i':
+ along = (strend - s) / sizeof(int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &aint, 1, int);
+ s += sizeof(int);
+ if (checksum > 32)
+ cdouble += (double)aint;
+ else
+ culong += aint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ while (len-- > 0) {
+ Copy(s, &aint, 1, int);
+ s += sizeof(int);
+ sv = NEWSV(40, 0);
+ sv_setiv(sv, (I32)aint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'I':
+ along = (strend - s) / sizeof(unsigned int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &auint, 1, unsigned int);
+ s += sizeof(unsigned int);
+ if (checksum > 32)
+ cdouble += (double)auint;
+ else
+ culong += auint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ 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;
+#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;
+ }
+ if (checksum) {
+ sv = NEWSV(42, 0);
+ if (index("fFdD", datumtype) ||
+ (checksum > 32 && index("iIlLN", datumtype)) ) {
+ double modf();
+ double trouble;
+
+ adouble = 1.0;
+ while (checksum >= 16) {
+ checksum -= 16;
+ adouble *= 65536.0;
+ }
+ while (checksum >= 4) {
+ checksum -= 4;
+ adouble *= 16.0;
+ }
+ while (checksum--)
+ adouble *= 2.0;
+ along = (1 << checksum) - 1;
+ while (cdouble < 0.0)
+ cdouble += adouble;
+ cdouble = modf(cdouble / adouble, &trouble) * adouble;
+ sv_setnv(sv, cdouble);
+ }
+ else {
+ if (checksum < 32) {
+ along = (1 << checksum) - 1;
+ culong &= (U32)along;
+ }
+ sv_setnv(sv, (double)culong);
+ }
+ XPUSHs(sv_2mortal(sv));
+ checksum = 0;
+ }
+ }
+ RETURN;
+}
+
+static void
+doencodes(sv, s, len)
+register SV *sv;
+register char *s;
+register I32 len;
+{
+ char hunk[5];
+
+ *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;
+ }
+ for (s = SvPV(sv); *s; s++) {
+ if (*s == ' ')
+ *s = '`';
+ }
+ sv_catpvn(sv, "\n", 1);
+}
+
+PP(pp_pack)
+{
+ dSP; dMARK; dORIGMARK; dTARGET;
+ register SV *cat = TARG;
+ register I32 items;
+ register char *pat = SvPVnx(*++MARK);
+ register char *patend = pat + SvCUR(*MARK);
+ register I32 len;
+ I32 datumtype;
+ SV *fromstr;
+ /*SUPPRESS 442*/
+ static char *null10 = "\0\0\0\0\0\0\0\0\0\0";
+ static char *space10 = " ";
+
+ /* These must not be in registers: */
+ char achar;
+ I16 ashort;
+ int aint;
+ unsigned int auint;
+ I32 along;
+ U32 aulong;
+#ifdef QUAD
+ quad aquad;
+ unsigned quad auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+
+ items = SP - MARK;
+ MARK++;
+ sv_setpvn(cat, "", 0);
+ while (pat < patend) {
+#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
+ datumtype = *pat++;
+ if (*pat == '*') {
+ len = index("@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:
+ 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 = SvPVn(fromstr);
+ if (pat[-1] == '*')
+ len = SvCUR(fromstr);
+ if (SvCUR(fromstr) > len)
+ sv_catpvn(cat, aptr, len);
+ else {
+ sv_catpvn(cat, aptr, SvCUR(fromstr));
+ len -= SvCUR(fromstr);
+ if (datumtype == 'A') {
+ while (len >= 10) {
+ sv_catpvn(cat, space10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, space10, len);
+ }
+ else {
+ while (len >= 10) {
+ sv_catpvn(cat, null10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, null10, len);
+ }
+ }
+ break;
+ case 'B':
+ case 'b':
+ {
+ char *savepat = pat;
+ I32 saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = SvPVn(fromstr);
+ if (pat[-1] == '*')
+ len = SvCUR(fromstr);
+ pat = aptr;
+ aint = SvCUR(cat);
+ SvCUR(cat) += (len+7)/8;
+ SvGROW(cat, SvCUR(cat) + 1);
+ aptr = SvPV(cat) + aint;
+ if (len > SvCUR(fromstr))
+ len = SvCUR(fromstr);
+ 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 = SvPV(cat) + SvCUR(cat);
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'H':
+ case 'h':
+ {
+ char *savepat = pat;
+ I32 saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = SvPVn(fromstr);
+ if (pat[-1] == '*')
+ len = SvCUR(fromstr);
+ pat = aptr;
+ aint = SvCUR(cat);
+ SvCUR(cat) += (len+1)/2;
+ SvGROW(cat, SvCUR(cat) + 1);
+ aptr = SvPV(cat) + aint;
+ if (len > SvCUR(fromstr))
+ len = SvCUR(fromstr);
+ 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 = SvPV(cat) + SvCUR(cat);
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'C':
+ case 'c':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = SvIVn(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)SvNVn(fromstr);
+ sv_catpvn(cat, (char *)&afloat, sizeof (float));
+ }
+ break;
+ case 'd':
+ case 'D':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ adouble = (double)SvNVn(fromstr);
+ sv_catpvn(cat, (char *)&adouble, sizeof (double));
+ }
+ break;
+ case 'n':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIVn(fromstr);
+#ifdef HAS_HTONS
+ ashort = htons(ashort);
+#endif
+ sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ }
+ break;
+ case 'v':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIVn(fromstr);
+#ifdef HAS_HTOVS
+ ashort = htovs(ashort);
+#endif
+ sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ }
+ break;
+ case 'S':
+ case 's':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIVn(fromstr);
+ sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ }
+ break;
+ case 'I':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auint = U_I(SvNVn(fromstr));
+ sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
+ }
+ break;
+ case 'i':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = SvIVn(fromstr);
+ sv_catpvn(cat, (char*)&aint, sizeof(int));
+ }
+ break;
+ case 'N':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(SvNVn(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(SvNVn(fromstr));
+#ifdef HAS_HTOVL
+ aulong = htovl(aulong);
+#endif
+ sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ }
+ break;
+ case 'L':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = U_L(SvNVn(fromstr));
+ sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ }
+ break;
+ case 'l':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ along = SvIVn(fromstr);
+ sv_catpvn(cat, (char*)&along, sizeof(I32));
+ }
+ break;
+#ifdef QUAD
+ case 'Q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auquad = (unsigned quad)SvNVn(fromstr);
+ sv_catpvn(cat, (char*)&auquad, sizeof(unsigned quad));
+ }
+ break;
+ case 'q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aquad = (quad)SvNVn(fromstr);
+ sv_catpvn(cat, (char*)&aquad, sizeof(quad));
+ }
+ break;
+#endif /* QUAD */
+ case 'p':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aptr = SvPVn(fromstr);
+ sv_catpvn(cat, (char*)&aptr, sizeof(char*));
+ }
+ break;
+ case 'u':
+ fromstr = NEXTFROM;
+ aptr = SvPVn(fromstr);
+ aint = SvCUR(fromstr);
+ SvGROW(cat, aint * 4 / 3);
+ if (len <= 1)
+ len = 45;
+ else
+ len = len / 3 * 3;
+ while (aint > 0) {
+ I32 todo;
+
+ if (aint > len)
+ todo = len;
+ else
+ todo = aint;
+ doencodes(cat, aptr, todo);
+ aint -= todo;
+ aptr += todo;
+ }
+ break;
+ }
+ }
+ SvSETMAGIC(cat);
+ SP = ORIGMARK;
+ PUSHs(cat);
+ RETURN;
+}
+#undef NEXTFROM
+
+PP(pp_split)
+{
+ dSP; dTARG;
+ AV *ary;
+ register I32 limit = POPi;
+ register char *s = SvPVn(TOPs);
+ char *strend = s + SvCURx(POPs);
+ 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
+ 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 = *SvPV(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*/
+ ;
+ }
+ 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);
+ }
+ 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);
+ }
+ }
+ 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;
+ if (GIMME != G_ARRAY) {
+ dMARK;
+ 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 = SvIVnx(*lastlelem) - arybase;
+ if (ix < 0 || ix >= max)
+ *firstlelem = &sv_undef;
+ else
+ *firstlelem = firstrelem[ix];
+ SP = firstlelem;
+ RETURN;
+ }
+
+ if (max == 0) {
+ SP = firstlelem;
+ RETURN;
+ }
+
+ for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
+ ix = SvIVnx(*lelem) - arybase;
+ if (ix < 0 || 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;
+ 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(COEFFSIZE);
+ SvREFCNT(hv) = 0;
+ while (MARK < SP) {
+ SV* key = *++MARK;
+ SV* val;
+ char *tmps;
+ if (MARK < SP)
+ val = *++MARK;
+ tmps = SvPV(key);
+ (void)hv_store(hv,tmps,SvCUR(key),val,0);
+ }
+ SP = ORIGMARK;
+ 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 = SvIVnx(*MARK);
+ if (offset < 0)
+ offset += AvFILL(ary) + 1;
+ else
+ offset -= arybase;
+ if (++MARK < SP) {
+ length = SvIVnx(*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--)
+ sv_free(*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*);
+ 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*);
+ }
+ 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 */
+ sv_free(*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)
+ sv_free(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_mortalcopy(&sv_undef);
+
+ 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_mortalcopy(&sv_undef);
+
+ RETURNOP(cLOGOP->op_other);
+ }
+}
+
+PP(pp_sort)
+{
+ dSP; dMARK; dORIGMARK;
+ register SV **up;
+ SV **myorigmark = ORIGMARK;
+ register I32 max;
+ register I32 i;
+ int sortcmp();
+ int sortcv();
+ HV *stash;
+ SV *sortcvvar;
+ GV *gv;
+ CV *cv;
+
+ if (GIMME != G_ARRAY) {
+ SP = MARK;
+ RETSETUNDEF;
+ }
+
+ 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) {
+ if (gv) {
+ SV *tmpstr = sv_mortalcopy(&sv_undef);
+ gv_efullname(tmpstr, gv);
+ DIE("Undefined sort subroutine \"%s\" called",
+ SvPV(tmpstr));
+ }
+ DIE("Undefined subroutine 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);
+ 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;
+
+ if (SP - MARK > 1)
+ do_join(TARG, sv_no, MARK, SP);
+ else
+ sv_setsv(TARG, *SP);
+ up = SvPVn(TARG);
+ if (SvCUR(TARG) > 1) {
+ down = SvPV(TARG) + SvCUR(TARG) - 1;
+ while (down > up) {
+ tmp = *up;
+ *up++ = *down;
+ *down-- = tmp;
+ }
+ }
+ 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 && SvIVn(sv) == GvIO(last_in_gv)->lines
+ : 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) && *SvPV(lstr) != '0') ) {
+ i = SvIVn(lstr);
+ max = SvIVn(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);
+ char *tmps = SvPVn(final);
+
+ sv = sv_mortalcopy(lstr);
+ while (!SvNIOK(sv) && SvCUR(sv) <= SvCUR(final) &&
+ strNE(SvPV(sv),tmps) ) {
+ XPUSHs(sv);
+ sv = sv_2mortal(newSVsv(sv));
+ sv_inc(sv);
+ }
+ if (strEQ(SvPV(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 && SvIVn(sv) == GvIO(last_in_gv)->lines
+ : 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 %d\n", cxstack_ix+1,
+ 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;
+ }
+ }
+}
+
+/*VARARGS0*/
+OP *
+die(va_alist)
+va_dcl
+{
+ va_list args;
+ char *tmps;
+ char *message;
+ OP *retop;
+
+ va_start(args);
+ message = mess(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", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
+ 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; dTARGET;
+ SV* ob;
+ GV* gv;
+
+ if (SvTYPE(sv) != SVt_REF || !(ob = (SV*)SvANY(sv)) || SvSTORAGE(ob) != 'O')
+ DIE("Not an object reference");
+
+ if (TARG && SvTYPE(TARG) == SVt_REF) {
+ /* XXX */
+ gv = 0;
+ }
+ else
+ gv = 0;
+
+ if (!gv) { /* nothing cached */
+ char *name = SvPV(((SVOP*)cLOGOP->op_other)->op_sv);
+ if (index(name, '\''))
+ gv = gv_fetchpv(name, FALSE);
+ else
+ gv = gv_fetchmethod(SvSTASH(ob),name);
+ if (!gv)
+ DIE("Can't locate object method \"%s\" via package \"%s\"",
+ name, HvNAME(SvSTASH(ob)));
+ }
+
+ EXTEND(sp,2);
+ PUSHs(gv);
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_entersubr)
+{
+ dSP; dMARK;
+ SV *sv;
+ GV *gv;
+ HV *stash;
+ register CV *cv = sv_2cv(*++MARK, &stash, &gv, 0);
+ register I32 items = SP - MARK;
+ I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
+ register CONTEXT *cx;
+
+ ENTER;
+ SAVETMPS;
+
+ if (!cv) {
+ if (gv) {
+ SV *tmpstr = sv_mortalcopy(&sv_undef);
+ gv_efullname(tmpstr, gv);
+ DIE("Undefined subroutine \"%s\" called",SvPV(tmpstr));
+ }
+ DIE("Not a subroutine reference");
+ }
+ if ((op->op_private & OPpSUBR_DB) && !CvUSERSUB(cv)) {
+ sv = GvSV(DBsub);
+ save_item(sv);
+ gv_efullname(sv,gv);
+ cv = GvCV(DBsub);
+ if (!cv)
+ DIE("No DBsub routine");
+ }
+
+ if (CvUSERSUB(cv)) {
+ cx->blk_sub.hasargs = 0;
+ cx->blk_sub.savearray = Null(AV*);;
+ cx->blk_sub.argarray = Null(AV*);
+ if (!hasargs)
+ items = 0;
+ items = (*CvUSERSUB(cv))(CvUSERINDEX(cv), sp - stack_base, items);
+ sp = stack_base + items;
+ RETURN;
+ }
+ else {
+ I32 gimme = GIMME;
+ push_return(op->op_next);
+ PUSHBLOCK(cx, CXt_SUB, MARK - 1);
+ PUSHSUB(cx);
+ if (hasargs) {
+ cx->blk_sub.savearray = GvAV(defgv);
+ cx->blk_sub.argarray = av_fake(items, ++MARK);
+ GvAV(defgv) = cx->blk_sub.argarray;
+ }
+ CvDEPTH(cv)++;
+ if (CvDEPTH(cv) >= 2) { /* save temporaries on recursion? */
+ if (CvDEPTH(cv) == 100 && dowarn)
+ warn("Deep recursion on subroutine \"%s\"",GvENAME(gv));
+ if (CvDEPTH(cv) > AvFILL(CvPADLIST(cv))) {
+ AV *newpad = newAV();
+ I32 ix = AvFILL((AV*)*av_fetch(CvPADLIST(cv), 1, FALSE));
+ while (ix > 0)
+ av_store(newpad, ix--, NEWSV(0,0));
+ av_store(CvPADLIST(cv), CvDEPTH(cv), (SV*)newpad);
+ AvFILL(CvPADLIST(cv)) = CvDEPTH(cv);
+ }
+ }
+ SAVESPTR(curpad);
+ curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),CvDEPTH(cv),FALSE));
+ 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)
+ *MARK = sv_mortalcopy(TOPs);
+ else {
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
+ }
+ SP = MARK;
+ }
+ else {
+ for (mark = newsp + 1; mark <= SP; mark++)
+ *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 (cxix < 0)
+ DIE("There is no caller");
+ if (MAXARG)
+ count = POPi;
+ for (;;) {
+ if (cxix < 0)
+ 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];
+ EXTEND(SP, 6);
+ 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(SvPV(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
+ PUSHs(sv_2mortal(newSVnv((double)cx->blk_oldcop->cop_line)));
+ if (!MAXARG)
+ RETURN;
+ sv = NEWSV(49, 0);
+ gv_efullname(sv, cx->blk_sub.gv);
+ PUSHs(sv_2mortal(sv));
+ PUSHs(sv_2mortal(newSVnv((double)cx->blk_sub.hasargs)));
+ PUSHs(sv_2mortal(newSVnv((double)cx->blk_gimme)));
+ if (cx->blk_sub.hasargs) {
+ AV *ary = cx->blk_sub.argarray;
+
+ if (!dbargs)
+ dbargs = GvAV(gv_AVadd(gv_fetchpv("DB'args", TRUE)));
+ 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;
+{
+ GvSV(firstgv) = *str1;
+ GvSV(secondgv) = *str2;
+ stack_sp = stack_base;
+ op = sortcop;
+ run();
+ return SvIVnx(AvARRAY(stack)[1]);
+}
+
+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(SvPV(str1), SvPV(str2), SvCUR(str1)))
+ return retval;
+ else
+ return -1;
+ }
+ /*SUPPRESS 560*/
+ else if (retval = memcmp(SvPV(str1), SvPV(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 = SvPVn(TARG);
+ SP = MARK + 1;
+ }
+ else {
+ tmps = SvPVn(TOPs);
+ }
+ if (!tmps || !*tmps) {
+ SV *error = GvSV(gv_fetchpv("@", TRUE));
+ if (SvCUR(error))
+ sv_catpv(error, "\t...caught");
+ tmps = SvPVn(error);
+ }
+ 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 = SvPVn(TARG);
+ SP = MARK + 1;
+ }
+ else {
+ tmps = SvPVn(TOPs);
+ }
+ if (!tmps || !*tmps) {
+ SV *error = GvSV(gv_fetchpv("@", TRUE));
+ if (SvCUR(error))
+ sv_catpv(error, "\t...propagated");
+ tmps = SvPVn(error);
+ }
+ 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_curcop)
+{
+ curcop = (COP*)op;
+#ifdef TAINT
+ tainted = 0; /* Each statement is presumed innocent */
+#endif
+ stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
+ free_tmps();
+ return NORMAL;
+}
+
+PP(pp_unstack)
+{
+ I32 oldsave;
+#ifdef TAINT
+ tainted = 0; /* Each statement is presumed innocent */
+#endif
+ stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
+ /* XXX should tmps_floor live in cxstack? */
+ while (tmps_ix > tmps_floor) { /* clean up after last eval */
+ sv_free(tmps_stack[tmps_ix]);
+ tmps_stack[tmps_ix--] = Nullsv;
+ }
+ oldsave = scopestack[scopestack_ix - 1];
+ if (savestack_ix > oldsave)
+ 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;
+ I32 gimme;
+ SV **newsp;
+
+ POPBLOCK(cx);
+ LEAVE;
+
+ RETURN;
+}
+
+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;
+
+ sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix];
+ *cx->blk_loop.itervar = sv ? sv : &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;
+
+ 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", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
+ }
+ else {
+ if (optype == OP_REQUIRE && MARK == SP)
+ DIE("%s", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
+ 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];
+ if (savestack_ix > oldsave)
+ 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];
+ if (savestack_ix > oldsave)
+ 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_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_CURCOP && 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_CURCOP) {
+ if (ops > opstack && ops[-1]->op_type == OP_CURCOP)
+ *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_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];
+ if (savestack_ix > oldsave)
+ 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 = SvIVnx(POPs);
+ my_exit(anum);
+ PUSHs(&sv_undef);
+ RETURN;
+}
+
+PP(pp_nswitch)
+{
+ dSP;
+ double value = SvNVnx(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 = *(SvPVnx(GvSV(cCOP->cop_gv))) & 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;
+ dPOPss;
+ char *tmps;
+
+ gv = (GV*)POPs;
+ tmps = SvPVn(sv);
+ if (do_open(gv, tmps, SvCUR(sv))) {
+ GvIO(gv)->lines = 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 (rstio->ifp)
+ do_close(rgv, FALSE);
+ if (wstio->ifp)
+ do_close(wgv, FALSE);
+
+ if (pipe(fd) < 0)
+ goto badexit;
+
+ rstio->ifp = fdopen(fd[0], "r");
+ wstio->ofp = fdopen(fd[1], "w");
+ wstio->ifp = wstio->ofp;
+ rstio->type = '<';
+ wstio->type = '>';
+
+ if (!rstio->ifp || !wstio->ofp) {
+ if (rstio->ifp) fclose(rstio->ifp);
+ else close(fd[0]);
+ if (wstio->ofp) fclose(wstio->ofp);
+ 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 = io->ifp))
+ 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 = io->ifp))
+ 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_dbmopen)
+{
+ dSP; dTARGET;
+ int anum;
+ HV *hv;
+ dPOPPOPssrl;
+
+ hv = (HV*)POPs;
+ if (SvOK(rstr))
+ anum = SvIVn(rstr);
+ else
+ anum = -1;
+#ifdef SOME_DBM
+ PUSHi( (I32)hv_dbmopen(hv, SvPVn(lstr), anum) );
+#else
+ DIE("No dbm or ndbm on this machine");
+#endif
+ RETURN;
+}
+
+PP(pp_dbmclose)
+{
+ dSP;
+ I32 anum;
+ HV *hv;
+
+ hv = (HV*)POPs;
+#ifdef SOME_DBM
+ hv_dbmclose(hv);
+ RETPUSHYES;
+#else
+ DIE("No dbm or ndbm on this machine");
+#endif
+}
+
+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 = SvNVn(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 = SvPVn(sv) + j;
+ while (++j <= growsize) {
+ *s++ = '\0';
+ }
+ }
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ s = SvPV(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] = SvPV(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 = SvPV(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, " ");
+ *SvPV(TARG) = getc(GvIO(gv)->ifp); /* 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 (io->fmt_gv)
+ fgv = io->fmt_gv;
+ else
+ fgv = gv;
+
+ cv = GvFORM(fgv);
+
+ if (!cv) {
+ if (fgv) {
+ SV *tmpstr = sv_mortalcopy(&sv_undef);
+ gv_efullname(tmpstr, gv);
+ DIE("Undefined format \"%s\" called",SvPV(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 = io->ofp;
+ FILE *fp;
+ SV **mark;
+ SV **newsp;
+ I32 gimme;
+ register CONTEXT *cx;
+
+ DEBUG_f(fprintf(stderr,"left=%ld, todo=%ld\n",
+ (long)io->lines_left, (long)FmLINES(formtarget)));
+ if (io->lines_left < FmLINES(formtarget) &&
+ formtarget != toptarget)
+ {
+ if (!io->top_gv) {
+ GV *topgv;
+ char tmpbuf[256];
+
+ if (!io->top_name) {
+ if (!io->fmt_name)
+ io->fmt_name = savestr(GvNAME(gv));
+ sprintf(tmpbuf, "%s_TOP", io->fmt_name);
+ topgv = gv_fetchpv(tmpbuf,FALSE);
+ if (topgv && GvFORM(topgv))
+ io->top_name = savestr(tmpbuf);
+ else
+ io->top_name = savestr("top");
+ }
+ topgv = gv_fetchpv(io->top_name,FALSE);
+ if (!topgv || !GvFORM(topgv)) {
+ io->lines_left = 100000000;
+ goto forget_top;
+ }
+ io->top_gv = topgv;
+ }
+ if (io->lines_left >= 0 && io->page > 0)
+ fwrite(SvPV(formfeed), SvCUR(formfeed), 1, ofp);
+ io->lines_left = io->page_len;
+ io->page++;
+ formtarget = toptarget;
+ return doform(GvFORM(io->top_gv),gv,op);
+ }
+
+ forget_top:
+ POPBLOCK(cx);
+ POPFORMAT(cx);
+ LEAVE;
+
+ fp = io->ofp;
+ if (!fp) {
+ if (dowarn) {
+ if (io->ifp)
+ warn("Filehandle only opened for input");
+ else
+ warn("Write on closed filehandle");
+ }
+ PUSHs(&sv_no);
+ }
+ else {
+ if ((io->lines_left -= FmLINES(formtarget)) < 0) {
+ if (dowarn)
+ warn("page overflow");
+ }
+ if (!fwrite(SvPV(formtarget), 1, SvCUR(formtarget), ofp) ||
+ ferror(fp))
+ PUSHs(&sv_no);
+ else {
+ FmLINES(formtarget) = 0;
+ SvCUR_set(formtarget, 0);
+ if (io->flags & 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 = io->ofp)) {
+ if (dowarn) {
+ if (io->ifp)
+ 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 (io->flags & IOf_FLUSH)
+ if (fflush(fp) == EOF)
+ goto just_say_no;
+ }
+ sv_free(sv);
+ SP = ORIGMARK;
+ PUSHs(&sv_yes);
+ RETURN;
+
+ just_say_no:
+ sv_free(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 = io->ofp)) {
+ if (dowarn) {
+ if (io->ifp)
+ 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 (io->flags & 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;
+
+ gv = (GV*)*++MARK;
+ if (!gv)
+ goto say_undef;
+ bufstr = *++MARK;
+ buffer = SvPVn(bufstr);
+ length = SvIVnx(*++MARK);
+ errno = 0;
+ if (MARK < SP)
+ offset = SvIVnx(*++MARK);
+ else
+ offset = 0;
+ if (MARK < SP)
+ warn("Too many args on read");
+ io = GvIO(gv);
+ if (!io || !io->ifp)
+ goto say_undef;
+#ifdef HAS_SOCKET
+ if (op->op_type == OP_RECV) {
+ bufsize = sizeof buf;
+ SvGROW(bufstr, length+1), (buffer = SvPVn(bufstr)); /* sneaky */
+ length = recvfrom(fileno(io->ifp), buffer, length, offset,
+ buf, &bufsize);
+ if (length < 0)
+ RETPUSHUNDEF;
+ SvCUR_set(bufstr, length);
+ *SvEND(bufstr) = '\0';
+ SvNOK_off(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 = SvPVn(bufstr)); /* sneaky */
+ if (op->op_type == OP_SYSREAD) {
+ length = read(fileno(io->ifp), buffer+offset, length);
+ }
+ else
+#ifdef HAS_SOCKET
+ if (io->type == 's') {
+ bufsize = sizeof buf;
+ length = recvfrom(fileno(io->ifp), buffer+offset, length, 0,
+ buf, &bufsize);
+ }
+ else
+#endif
+ length = fread(buffer+offset, 1, length, io->ifp);
+ if (length < 0)
+ goto say_undef;
+ SvCUR_set(bufstr, length+offset);
+ *SvEND(bufstr) = '\0';
+ SvNOK_off(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;
+
+ gv = (GV*)*++MARK;
+ if (!gv)
+ goto say_undef;
+ bufstr = *++MARK;
+ buffer = SvPVn(bufstr);
+ length = SvIVnx(*++MARK);
+ errno = 0;
+ io = GvIO(gv);
+ if (!io || !io->ifp) {
+ 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 = SvIVnx(*++MARK);
+ else
+ offset = 0;
+ if (MARK < SP)
+ warn("Too many args on syswrite");
+ length = write(fileno(io->ifp), buffer+offset, length);
+ }
+#ifdef HAS_SOCKET
+ else if (SP >= MARK) {
+ if (SP > MARK)
+ warn("Too many args on send");
+ buffer = SvPVnx(*++MARK);
+ length = sendto(fileno(io->ifp), buffer, SvCUR(bufstr),
+ length, buffer, SvCUR(*MARK));
+ }
+ else
+ length = send(fileno(io->ifp), buffer, SvCUR(bufstr), 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 = (GV*)POPs;
+ PUSHs(do_eof(gv) ? &sv_yes : &sv_no);
+ RETURN;
+}
+
+PP(pp_tell)
+{
+ dSP; dTARGET;
+ GV *gv;
+
+ if (MAXARG <= 0)
+ gv = last_in_gv;
+ else
+ gv = (GV*)POPs;
+ PUSHi( do_tell(gv) );
+ RETURN;
+}
+
+PP(pp_seek)
+{
+ dSP;
+ GV *gv;
+ int whence = POPi;
+ long offset = POPl;
+
+ 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) || !GvIO(tmpgv)->ifp ||
+ ftruncate(fileno(GvIO(tmpgv)->ifp), 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) || !GvIO(tmpgv)->ifp ||
+ chsize(fileno(GvIO(tmpgv)->ifp), 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);
+
+ TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
+
+ if (!io || !argstr || !io->ifp) {
+ errno = EBADF; /* well, sort of... */
+ RETPUSHUNDEF;
+ }
+
+ if (SvPOK(argstr) || !SvNIOK(argstr)) {
+ if (!SvPOK(argstr))
+ s = SvPVn(argstr);
+ retval = IOCPARM_LEN(func);
+ if (SvCUR(argstr) < retval) {
+ Sv_Grow(argstr, retval+1);
+ SvCUR_set(argstr, retval);
+ }
+
+ s = SvPV(argstr);
+ s[SvCUR(argstr)] = 17; /* a little sanity check here */
+ }
+ else {
+ retval = SvIVn(argstr);
+#ifdef DOSISH
+ s = (char*)(long)retval; /* ouch */
+#else
+ s = (char*)retval; /* ouch */
+#endif
+ }
+
+ if (optype == OP_IOCTL)
+ retval = ioctl(fileno(io->ifp), func, s);
+ else
+#ifdef DOSISH
+ DIE("fcntl is not implemented");
+#else
+# ifdef HAS_FCNTL
+ retval = fcntl(fileno(io->ifp), func, s);
+# else
+ DIE("fcntl is not implemented");
+# endif
+#endif
+
+ if (SvPOK(argstr)) {
+ if (s[SvCUR(argstr)] != 17)
+ DIE("Return value overflowed string");
+ 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 = GvIO(gv)->ifp;
+ 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 (io->ifp)
+ do_close(gv, FALSE);
+
+ TAINT_PROPER("socket");
+ fd = socket(domain, type, protocol);
+ if (fd < 0)
+ RETPUSHUNDEF;
+ io->ifp = fdopen(fd, "r"); /* stdio gets confused about sockets */
+ io->ofp = fdopen(fd, "w");
+ io->type = 's';
+ if (!io->ifp || !io->ofp) {
+ if (io->ifp) fclose(io->ifp);
+ if (io->ofp) fclose(io->ofp);
+ if (!io->ifp && !io->ofp) 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 (io1->ifp)
+ do_close(gv1, FALSE);
+ if (io2->ifp)
+ do_close(gv2, FALSE);
+
+ TAINT_PROPER("socketpair");
+ if (socketpair(domain, type, protocol, fd) < 0)
+ RETPUSHUNDEF;
+ io1->ifp = fdopen(fd[0], "r");
+ io1->ofp = fdopen(fd[0], "w");
+ io1->type = 's';
+ io2->ifp = fdopen(fd[1], "r");
+ io2->ofp = fdopen(fd[1], "w");
+ io2->type = 's';
+ if (!io1->ifp || !io1->ofp || !io2->ifp || !io2->ofp) {
+ if (io1->ifp) fclose(io1->ifp);
+ if (io1->ofp) fclose(io1->ofp);
+ if (!io1->ifp && !io1->ofp) close(fd[0]);
+ if (io2->ifp) fclose(io2->ifp);
+ if (io2->ofp) fclose(io2->ofp);
+ if (!io2->ifp && !io2->ofp) 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);
+
+ if (!io || !io->ifp)
+ goto nuts;
+
+ addr = SvPVn(addrstr);
+ TAINT_PROPER("bind");
+ if (bind(fileno(io->ifp), addr, SvCUR(addrstr)) >= 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);
+
+ if (!io || !io->ifp)
+ goto nuts;
+
+ addr = SvPVn(addrstr);
+ TAINT_PROPER("connect");
+ if (connect(fileno(io->ifp), addr, SvCUR(addrstr)) >= 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 || !io->ifp)
+ goto nuts;
+
+ if (listen(fileno(io->ifp), 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 || !gstio->ifp)
+ goto nuts;
+
+ nstio = GvIOn(ngv);
+ if (nstio->ifp)
+ do_close(ngv, FALSE);
+
+ fd = accept(fileno(gstio->ifp), (struct sockaddr *)buf, &len);
+ if (fd < 0)
+ goto badexit;
+ nstio->ifp = fdopen(fd, "r");
+ nstio->ofp = fdopen(fd, "w");
+ nstio->type = 's';
+ if (!nstio->ifp || !nstio->ofp) {
+ if (nstio->ifp) fclose(nstio->ifp);
+ if (nstio->ofp) fclose(nstio->ofp);
+ if (!nstio->ifp && !nstio->ofp) 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 || !io->ifp)
+ goto nuts;
+
+ PUSHi( shutdown(fileno(io->ifp), 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 || !io->ifp)
+ goto nuts;
+
+ fd = fileno(io->ifp);
+ switch (optype) {
+ case OP_GSOCKOPT:
+ SvCUR_set(sv, 256);
+ SvPOK_on(sv);
+ if (getsockopt(fd, lvl, optname, SvPV(sv), (int*)&SvCUR(sv)) < 0)
+ goto nuts2;
+ PUSHs(sv);
+ break;
+ case OP_SSOCKOPT:
+ if (setsockopt(fd, lvl, optname, SvPV(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 || !io->ifp)
+ goto nuts;
+
+ sv = sv_2mortal(NEWSV(22, 257));
+ SvCUR_set(sv, 256);
+ SvPOK_on(sv);
+ fd = fileno(io->ifp);
+ switch (optype) {
+ case OP_GETSOCKNAME:
+ if (getsockname(fd, SvPV(sv), (int*)&SvCUR(sv)) < 0)
+ goto nuts2;
+ break;
+ case OP_GETPEERNAME:
+ if (getpeername(fd, SvPV(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) || !GvIO(tmpgv)->ifp ||
+ fstat(fileno(GvIO(tmpgv)->ifp), &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(SvPVn(statname), &statcache);
+ else
+#endif
+ laststatval = stat(SvPVn(statname), &statcache);
+ if (laststatval < 0) {
+ if (dowarn && index(SvPVn(statname), '\n'))
+ warn(warn_nl, "stat");
+ max = 0;
+ }
+ }
+
+ EXTEND(SP, 13);
+ if (GIMME != G_ARRAY) {
+ if (max)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+ }
+ if (max) {
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_dev)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_ino)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_mode)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_nlink)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_uid)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_gid)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_rdev)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_size)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_atime)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_mtime)));
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_ctime)));
+#ifdef STATBLOCKS
+ PUSHs(sv_2mortal(newSVnv((double)statcache.st_blksize)));
+ PUSHs(sv_2mortal(newSVnv((double)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) && GvIO(gv)->ifp)
+ fd = fileno(GvIO(gv)->ifp);
+ 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 && io->ifp) {
+#if defined(STDSTDIO) || defined(atarist) /* this will work with atariST */
+ fstat(fileno(io->ifp), &statcache);
+ if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
+ if (op->op_type == OP_FTTEXT)
+ RETPUSHNO;
+ else
+ RETPUSHYES;
+ if (io->ifp->_cnt <= 0) {
+ i = getc(io->ifp);
+ if (i != EOF)
+ (void)ungetc(i, io->ifp);
+ }
+ if (io->ifp->_cnt <= 0) /* null file is anything */
+ RETPUSHYES;
+ len = io->ifp->_cnt + (io->ifp->_ptr - io->ifp->_base);
+ s = io->ifp->_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, SvPVn(sv));
+ really_filename:
+ i = open(SvPVn(sv), 0);
+ if (i < 0) {
+ if (dowarn && index(SvPVn(sv), '\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 = SvPVn(*svp);
+ }
+ if (!tmps || !*tmps) {
+ svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
+ if (svp)
+ tmps = SvPVn(*svp);
+ }
+ 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 = SvPVnx(GvSV(defgv));
+ 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 = SvPVn(TOPs);
+ 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 = SvPVn(TOPs);
+ 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 = SvPVn(TOPs);
+ 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 = SvPVnx(GvSV(defgv));
+ 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 = SvPVnx(st[1]);
+ 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 = SvPVn(TOPs);
+
+ 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 = SvPVnx(GvSV(defgv));
+ 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 (io->dirp)
+ closedir(io->dirp);
+ if (!(io->dirp = 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 || !io->dirp)
+ goto nope;
+
+ if (GIMME == G_ARRAY) {
+ /*SUPPRESS 560*/
+ while (dp = readdir(io->dirp)) {
+#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(io->dirp)))
+ 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 || !io->dirp)
+ goto nope;
+
+ PUSHi( telldir(io->dirp) );
+ 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 || !io->dirp)
+ goto nope;
+
+ (void)seekdir(io->dirp, 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 || !io->dirp)
+ goto nope;
+
+ (void)rewinddir(io->dirp);
+ 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 || !io->dirp)
+ goto nope;
+
+ if (closedir(io->dirp) < 0)
+ goto nope;
+ io->dirp = 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("$", allgvs))
+ sv_setiv(GvSV(tmpgv), (I32)getpid());
+ hv_clear(pidstatus, FALSE); /* 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) {
+ TAINT_ENV();
+ TAINT_IF(TOPs->sv_tainted);
+ 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(SvPVnx(sv_mortalcopy(*SP)));
+ }
+ _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(SvPVnx(sv_mortalcopy(st[2])));
+ }
+ 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 {
+ TAINT_ENV();
+ TAINT_IF((*SP)->sv_tainted);
+ TAINT_PROPER("exec");
+ value = (I32)do_exec(SvPVnx(sv_mortalcopy(*SP)));
+ }
+ 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 = SvIVnx(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(&timesbuf);
+
+ 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)SvIVnx(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(newSVnv((double)tmbuf->tm_sec)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_min)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_hour)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_mday)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_mon)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_year)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_wday)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_yday)));
+ PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_isdst)));
+ }
+ RETURN;
+}
+
+PP(pp_alarm)
+{
+ dSP; dTARGET;
+ int anum;
+ char *tmps;
+#ifdef HAS_ALARM
+ if (MAXARG < 1)
+ tmps = SvPVnx(GvSV(defgv));
+ else
+ tmps = POPp;
+ if (!tmps)
+ tmps = "0";
+ anum = alarm((unsigned int)atoi(tmps));
+ 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 = SvPV(sv);
+ register char *send = SvPV(sv) + SvCUR(sv);
+ register char *t;
+ register I32 line = 1;
+
+ while (s && s < send) {
+ SV *tmpstr = NEWSV(85,0);
+
+ t = index(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;
+ reinit_lexer();
+
+ /* set up a scratch pad */
+
+ SAVEINT(padix);
+ SAVESPTR(curpad);
+ SAVESPTR(comppad);
+ comppad = newAV();
+ 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;
+ }
+
+ /* try to compile it */
+
+ eval_root = Nullop;
+ error_count = 0;
+ curcop = &compiling;
+ if (yyparse() || error_count || !eval_root) {
+ SV **newsp;
+ I32 gimme;
+ CONTEXT *cx;
+ I32 optype;
+
+ op = saveop;
+ POPBLOCK(cx);
+ POPEVAL(cx);
+ pop_return();
+ LEAVE;
+ if (eval_root) {
+ op_free(eval_root);
+ eval_root = Nullop;
+ }
+ if (optype == OP_REQUIRE)
+ DIE("%s", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
+ RETPUSHUNDEF;
+ }
+ compiling.cop_line = 0;
+
+ DEBUG_x(dump_eval(eval_root, eval_start));
+
+ /* compiled okay, so do it */
+
+ sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
+ RETURNOP(eval_start);
+}
+
+PP(pp_require)
+{
+ dSP;
+ register CONTEXT *cx;
+ dPOPss;
+ char *name = SvPVn(sv);
+ char *tmpname;
+ SV** svp;
+ I32 gimme = G_SCALAR;
+
+ if (op->op_type == OP_REQUIRE &&
+ (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
+ *svp != &sv_undef)
+ RETPUSHYES;
+
+ /* prepare to compile file */
+
+ sv_setpv(linestr,"");
+
+ tmpname = savestr(name);
+ if (*tmpname == '/' ||
+ (*tmpname == '.' &&
+ (tmpname[1] == '/' ||
+ (tmpname[1] == '.' && tmpname[2] == '/'))))
+ {
+ rsfp = fopen(tmpname,"r");
+ }
+ else {
+ AV *ar = GvAVn(incgv);
+ I32 i;
+
+ for (i = 0; i <= AvFILL(ar); i++) {
+ (void)sprintf(buf, "%s/%s", SvPVnx(*av_fetch(ar, i, TRUE)), name);
+ rsfp = fopen(buf, "r");
+ if (rsfp) {
+ char *s = buf;
+
+ if (*s == '.' && s[1] == '/')
+ s += 2;
+ Safefree(tmpname);
+ tmpname = savestr(s);
+ break;
+ }
+ }
+ }
+ compiling.cop_filegv = gv_fetchfile(tmpname);
+ Safefree(tmpname);
+ tmpname = Nullch;
+ if (!rsfp) {
+ 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;
+
+ /* switch to eval mode */
+
+ push_return(op->op_next);
+ PUSHBLOCK(cx,CXt_EVAL,SP);
+ PUSHEVAL(cx,savestr(name));
+
+ if (curcop->cop_line == 0) /* don't debug debugger... */
+ perldb = FALSE;
+ 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;
+
+ ENTER;
+ SAVETMPS;
+
+ /* switch to eval mode */
+
+ push_return(op->op_next);
+ PUSHBLOCK(cx,CXt_EVAL,SP);
+ PUSHEVAL(cx,0);
+
+ /* prepare to compile string */
+
+ save_item(linestr);
+ sv_setsv(linestr, sv);
+ sv_catpv(linestr, "\n;");
+ compiling.cop_filegv = gv_fetchfile("(eval)");
+ compiling.cop_line = 1;
+ if (perldb)
+ save_lines(GvAV(curcop->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)
+ *MARK = sv_mortalcopy(TOPs);
+ else {
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
+ }
+ SP = MARK;
+ }
+ else {
+ for (mark = newsp + 1; mark <= SP; mark++)
+ *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);
+ Safefree(name);
+ }
+ op_free(eroot);
+ av_free(comppad);
+
+ 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) {
+ sv_free(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);
+
+ 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)
+ *MARK = sv_mortalcopy(TOPs);
+ else {
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
+ }
+ SP = MARK;
+ }
+ else {
+ for (mark = newsp + 1; mark <= SP; mark++)
+ *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");
+#endif
+}
+
+PP(pp_ghbyaddr)
+{
+#ifdef HAS_SOCKET
+ return pp_ghostent(ARGS);
+#else
+ DIE(no_sock_func, "gethostbyaddr");
+#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();
+#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 = SvPVn(addrstr);
+
+ hent = gethostbyaddr(addr, SvCUR(addrstr), addrtype);
+ }
+ else
+#ifdef HAS_GETHOSTENT
+ hent = gethostent();
+#else
+ DIE("gethostent not implemented");
+#endif
+
+#ifdef HOST_NOT_FOUND
+ if (!hent)
+ statusvalue = (U16)h_errno & 0xffff;
+#endif
+
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ if (hent) {
+ if (which == OP_GHBYNAME) {
+ sv_setpvn(sv, hent->h_addr, hent->h_length);
+ }
+ else
+ sv_setpv(sv, hent->h_name);
+ }
+ RETURN;
+ }
+
+ 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);
+ }
+#else
+ PUSHs(sv = sv_mortalcopy(&sv_no));
+ sv_setpvn(sv, hent->h_addr, len);
+#endif /* h_addr */
+ }
+ 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)
+{
+ 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();
+
+ EXTEND(SP, 4);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ if (nent) {
+ if (which == OP_GNBYNAME)
+ sv_setiv(sv, (I32)nent->n_net);
+ else
+ sv_setpv(sv, nent->n_name);
+ }
+ RETURN;
+ }
+
+ 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);
+ }
+
+ 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
+}
+
+PP(pp_gpbynumber)
+{
+#ifdef HAS_SOCKET
+ return pp_gprotoent(ARGS);
+#else
+ DIE(no_sock_func, "getprotobynumber");
+#endif
+}
+
+PP(pp_gprotoent)
+{
+ 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();
+
+ EXTEND(SP, 3);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ if (pent) {
+ if (which == OP_GPBYNAME)
+ sv_setiv(sv, (I32)pent->p_proto);
+ else
+ sv_setpv(sv, pent->p_name);
+ }
+ RETURN;
+ }
+
+ 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);
+ }
+
+ 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
+}
+
+PP(pp_gsbyport)
+{
+#ifdef HAS_SOCKET
+ return pp_gservent(ARGS);
+#else
+ DIE(no_sock_func, "getservbyport");
+#endif
+}
+
+PP(pp_gservent)
+{
+ 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;
+
+ if (proto && !*proto)
+ proto = Nullch;
+
+ sent = getservbyname(name, proto);
+ }
+ else if (which == OP_GSBYPORT) {
+ char *proto = POPp;
+ int port = POPi;
+
+ sent = getservbyport(port, proto);
+ }
+ else
+ sent = getservent();
+
+ EXTEND(SP, 4);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ 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
+ }
+ 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; dTARGET;
+#ifdef HAS_SOCKET
+ SETi( sethostent(TOPi) );
+ RETURN;
+#else
+ DIE(no_sock_func, "sethostent");
+#endif
+}
+
+PP(pp_snetent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ SETi( setnetent(TOPi) );
+ RETURN;
+#else
+ DIE(no_sock_func, "setnetent");
+#endif
+}
+
+PP(pp_sprotoent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ SETi( setprotoent(TOPi) );
+ RETURN;
+#else
+ DIE(no_sock_func, "setprotoent");
+#endif
+}
+
+PP(pp_sservent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ SETi( setservent(TOPi) );
+ RETURN;
+#else
+ DIE(no_sock_func, "setservent");
+#endif
+}
+
+PP(pp_ehostent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ XPUSHi( endhostent() );
+ RETURN;
+#else
+ DIE(no_sock_func, "endhostent");
+#endif
+}
+
+PP(pp_enetent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ XPUSHi( endnetent() );
+ RETURN;
+#else
+ DIE(no_sock_func, "endnetent");
+#endif
+}
+
+PP(pp_eprotoent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ XPUSHi( endprotoent() );
+ RETURN;
+#else
+ DIE(no_sock_func, "endprotoent");
+#endif
+}
+
+PP(pp_eservent)
+{
+ dSP; dTARGET;
+#ifdef HAS_SOCKET
+ XPUSHi( endservent() );
+ RETURN;
+#else
+ DIE(no_sock_func, "endservent");
+#endif
+}
+
+PP(pp_gpwnam)
+{
+#ifdef HAS_PASSWD
+ return pp_gpwent(ARGS);
+#else
+ DIE(no_func, "getpwnam");
+#endif
+}
+
+PP(pp_gpwuid)
+{
+#ifdef HAS_PASSWD
+ return pp_gpwent(ARGS);
+#else
+ DIE(no_func, "getpwuid");
+#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_mortalcopy(&sv_undef));
+ if (pwent) {
+ if (which == OP_GPWNAM)
+ sv_setiv(sv, (I32)pwent->pw_uid);
+ else
+ sv_setpv(sv, pwent->pw_name);
+ }
+ RETURN;
+ }
+
+ 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
+ }
+ RETURN;
+#else
+ DIE(no_func, "getpwent");
+#endif
+}
+
+PP(pp_spwent)
+{
+ dSP; dTARGET;
+#ifdef HAS_PASSWD
+ setpwent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "setpwent");
+#endif
+}
+
+PP(pp_epwent)
+{
+ dSP; dTARGET;
+#ifdef HAS_PASSWD
+ endpwent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "endpwent");
+#endif
+}
+
+PP(pp_ggrnam)
+{
+#ifdef HAS_GROUP
+ return pp_ggrent(ARGS);
+#else
+ DIE(no_func, "getgrnam");
+#endif
+}
+
+PP(pp_ggrgid)
+{
+#ifdef HAS_GROUP
+ return pp_ggrent(ARGS);
+#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);
+ else
+ grent = getgrent();
+
+ EXTEND(SP, 4);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_mortalcopy(&sv_undef));
+ if (grent) {
+ if (which == OP_GGRNAM)
+ sv_setiv(sv, (I32)grent->gr_gid);
+ else
+ sv_setpv(sv, grent->gr_name);
+ }
+ 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);
+ }
+ }
+
+ RETURN;
+#else
+ DIE(no_func, "getgrent");
+#endif
+}
+
+PP(pp_sgrent)
+{
+ dSP; dTARGET;
+#ifdef HAS_GROUP
+ setgrent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "setgrent");
+#endif
+}
+
+PP(pp_egrent)
+{
+ dSP; dTARGET;
+#ifdef HAS_GROUP
+ endgrent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "endgrent");
+#endif
+}
+
+PP(pp_getlogin)
+{
+ dSP; dTARGET;
+#ifdef HAS_GETLOGIN
+ char *tmps;
+ EXTEND(SP, 1);
+ if (!(tmps = getlogin()))
+ RETPUSHUNDEF;
+ PUSHp(tmps, strlen(tmps));
+ RETURN;
+#else
+ DIE(no_func, "getlogin");
+#endif
+}
+
+/* Miscellaneous. */
+
+PP(pp_syscall)
+{
+#ifdef HAS_SYSCALL
+ dSP; dMARK; dORIGMARK; dTARGET;
+ register I32 items = SP - MARK;
+ unsigned long a[20];
+ register I32 i = 0;
+ I32 retval = -1;
+
+#ifdef TAINT
+ while (++MARK <= SP)
+ TAINT_IF((*MARK)->sv_tainted);
+ MARK = ORIGMARK;
+ TAINT_PROPER("syscall");
+#endif
+
+ /* 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++] = SvIVn(*MARK);
+ else
+ a[i++] = (unsigned long)SvPV(*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);
+ RETURN;
+#else
+ DIE(no_func, "syscall");
+#endif
+}
View Lorry Controller Status