1 /***********************************************************
3 * $Header: /usr/src/local/lwall/perl5/RCS/pp.c, v 4.1 92/08/07 18:26:21 lwall Exp Locker: lwall $
11 * Mon Jun 15 16:45:59 1992
14 * Larry Wall <lwall@netlabs.com>
17 * Revision 4.1 92/08/07 18:26:21 lwall
20 **********************************************************/
26 #include <sys/socket.h>
29 #include <net/errno.h>
36 #include <sys/select.h>
65 static I32 dopoptosub P((I32 startingblock));
77 if (GIMME != G_ARRAY) {
92 if (++markstack_ptr == markstack_max) {
93 I32 oldmax = markstack_max - markstack;
94 I32 newmax = oldmax * 3 / 2;
96 Renew(markstack, newmax, I32);
97 markstack_ptr = markstack + oldmax;
98 markstack_max = markstack + newmax;
100 *markstack_ptr = stack_sp - stack_base;
110 cxix = dopoptosub(cxstack_ix);
114 if (cxstack[cxix].blk_gimme == G_ARRAY)
123 XPUSHs(cSVOP->op_sv);
153 DIE("panic: pp_interp");
160 if (op->op_flags & OPf_INTRO)
161 PUSHs(save_scalar(cGVOP->op_gv));
163 PUSHs(GvSV(cGVOP->op_gv));
170 XPUSHs((SV*)cGVOP->op_gv);
178 if ((op->op_flags & (OPf_INTRO|OPf_SPECIAL)) == OPf_INTRO)
187 if ((op->op_flags & (OPf_INTRO|OPf_SPECIAL)) == OPf_INTRO)
189 if (op->op_flags & OPf_LVAL)
199 if ((op->op_flags & (OPf_INTRO|OPf_SPECIAL)) == OPf_INTRO)
201 if (op->op_flags & OPf_LVAL)
219 if (SvTYPE(sv) == SVt_REF) {
221 if (SvTYPE(sv) != SVt_PVGV)
222 DIE("Not a glob reference");
225 if (SvTYPE(sv) != SVt_PVGV) {
228 sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
231 if (op->op_flags & OPf_INTRO) {
239 if (op->op_flags & OPf_SPECIAL)
240 GvGP(sv)->gp_refcnt++; /* will soon be assigned */
246 GvSV(sv) = NEWSV(72,0);
247 GvLINE(sv) = curcop->cop_line;
267 if (SvTYPE(sv) == SVt_REF) {
269 switch (SvTYPE(sv)) {
273 DIE("Not a scalar reference");
278 if (SvTYPE(gv) != SVt_PVGV) {
281 gv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
284 if (op->op_private == OP_RV2HV &&
285 (SvTYPE(sv) != SVt_REF || SvTYPE((SV*)SvANY(sv)) != SVt_PVHV)) {
288 sv_upgrade(sv, SVt_REF);
289 SvANY(sv) = (void*)sv_ref((SV*)newHV());
292 else if (op->op_private == OP_RV2AV &&
293 (SvTYPE(sv) != SVt_REF || SvTYPE((SV*)SvANY(sv)) != SVt_PVAV)) {
296 sv_upgrade(sv, SVt_REF);
297 SvANY(sv) = (void*)sv_ref((SV*)newAV());
301 if (op->op_flags & OPf_INTRO)
302 SETs(save_scalar((GV*)TOPs));
312 SV *sv = AvARYLEN(av);
314 AvARYLEN(av) = sv = NEWSV(0,0);
315 sv_upgrade(sv, SVt_IV);
316 sv_magic(sv, (SV*)av, '#', Nullch, 0);
328 CV *cv = sv_2cv(TOPs, &stash, &gv, 0);
340 rv = sv_mortalcopy(&sv_undef);
341 sv_upgrade(rv, SVt_REF);
342 SvANY(rv) = (void*)sv_ref(sv);
359 if (SvTYPE(sv) != SVt_REF)
363 if (SvSTORAGE(sv) == 'O')
364 pv = HvNAME(SvSTASH(sv));
366 switch (SvTYPE(sv)) {
367 case SVt_REF: pv = "REF"; break;
375 case SVt_PVBM: pv = "SCALAR"; break;
376 case SVt_PVLV: pv = "LVALUE"; break;
377 case SVt_PVAV: pv = "ARRAY"; break;
378 case SVt_PVHV: pv = "HASH"; break;
379 case SVt_PVCV: pv = "CODE"; break;
380 case SVt_PVGV: pv = "GLOB"; break;
381 case SVt_PVFM: pv = "FORMLINE"; break;
382 default: pv = "UNKNOWN"; break;
385 PUSHp(pv, strlen(pv));
397 stash = curcop->cop_stash;
399 stash = fetch_stash(POPs, TRUE);
402 if (SvTYPE(sv) != SVt_REF)
403 DIE("Can't bless non-reference value");
404 ref = (SV*)SvANY(sv);
405 if (SvSTORAGE(ref) && SvSTORAGE(ref) != 'O')
406 DIE("Can't bless temporary scalar");
407 SvSTORAGE(ref) = 'O';
408 SvUPGRADE(ref, SVt_PVMG);
409 SvSTASH(ref) = stash;
421 fp = my_popen(tmps, "r");
423 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
424 if (GIMME == G_SCALAR) {
425 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
435 if (sv_gets(sv, fp, 0) == Nullch) {
439 XPUSHs(sv_2mortal(sv));
440 if (SvLEN(sv) - SvCUR(sv) > 20) {
441 SvLEN_set(sv, SvCUR(sv)+1);
442 Renew(SvPVX(sv), SvLEN(sv), char);
446 statusvalue = my_pclose(fp);
450 if (GIMME == G_SCALAR)
465 register IO *io = GvIO(last_in_gv);
466 register I32 type = op->op_type;
472 if (io->flags & IOf_ARGV) {
473 if (io->flags & IOf_START) {
474 io->flags &= ~IOf_START;
476 if (av_len(GvAVn(last_in_gv)) < 0) {
477 SV *tmpstr = newSVpv("-", 1); /* assume stdin */
478 (void)av_push(GvAVn(last_in_gv), tmpstr);
481 fp = nextargv(last_in_gv);
482 if (!fp) { /* Note: fp != io->ifp */
483 (void)do_close(last_in_gv, FALSE); /* now it does*/
484 io->flags |= IOf_START;
487 else if (type == OP_GLOB) {
488 SV *tmpcmd = NEWSV(55, 0);
491 sv_setpv(tmpcmd, "perlglob ");
492 sv_catsv(tmpcmd, tmpglob);
493 sv_catpv(tmpcmd, " |");
496 sv_setpvn(tmpcmd, cshname, cshlen);
497 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
498 sv_catsv(tmpcmd, tmpglob);
499 sv_catpv(tmpcmd, "'|");
501 sv_setpv(tmpcmd, "echo ");
502 sv_catsv(tmpcmd, tmpglob);
503 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
506 (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd));
511 else if (type == OP_GLOB)
516 warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
517 if (GIMME == G_SCALAR)
521 if (GIMME == G_ARRAY) {
522 sv = sv_2mortal(NEWSV(57, 80));
527 SvUPGRADE(sv, SVt_PV);
528 tmplen = SvLEN(sv); /* remember if already alloced */
530 Sv_Grow(sv, 80); /* try short-buffering it */
531 if (type == OP_RCATLINE)
537 if (!sv_gets(sv, fp, offset)) {
539 if (io->flags & IOf_ARGV) {
540 fp = nextargv(last_in_gv);
543 (void)do_close(last_in_gv, FALSE);
544 io->flags |= IOf_START;
546 else if (type == OP_GLOB) {
547 (void)do_close(last_in_gv, FALSE);
549 if (GIMME == G_SCALAR)
557 SvTAINT(sv); /* Anything from the outside world...*/
559 if (type == OP_GLOB) {
564 if (*SvEND(sv) == rschar)
568 for (tmps = SvPVX(sv); *tmps; tmps++)
569 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
570 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
572 if (*tmps && stat(SvPVX(sv), &statbuf) < 0) {
573 POPs; /* Unmatched wildcard? Chuck it... */
577 if (GIMME == G_ARRAY) {
578 if (SvLEN(sv) - SvCUR(sv) > 20) {
579 SvLEN_set(sv, SvCUR(sv)+1);
580 Renew(SvPVX(sv), SvLEN(sv), char);
582 sv = sv_2mortal(NEWSV(58, 80));
585 else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
586 /* try to reclaim a bit of scalar space (only on 1st alloc) */
590 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
591 Renew(SvPVX(sv), SvLEN(sv), char);
604 SAVESPTR(last_in_gv); /* We don't want this to be permanent. */
605 last_in_gv = (GV*)*stack_sp--;
617 result = do_readline();
624 last_in_gv = (GV*)(*stack_sp--);
625 return do_readline();
630 last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*stack_sp--)), na), TRUE);
631 return do_readline();
636 last_in_gv = cGVOP->op_gv;
637 return do_readline();
647 register PMOP *pm = (PMOP*)cLOGOP->op_other;
651 register REGEXP *rx = pm->op_pmregexp;
654 global = pm->op_pmflags & PMf_GLOBAL;
656 t = SvPV(tmpstr, len);
659 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
660 pm->op_pmregexp = regcomp(t, t + len,
661 pm->op_pmflags & PMf_FOLD);
662 if (!pm->op_pmregexp->prelen && curpm)
664 if (pm->op_pmflags & PMf_KEEP) {
665 if (!(pm->op_pmflags & PMf_FOLD))
666 scan_prefix(pm, pm->op_pmregexp->precomp,
667 pm->op_pmregexp->prelen);
668 pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */
670 cLOGOP->op_first->op_next = op->op_next;
671 /* XXX delete push code */
679 register PMOP *pm = cPMOP;
687 register REGEXP *rx = pm->op_pmregexp;
691 if (op->op_flags & OPf_STACKED)
700 DIE("panic: do_match");
702 if (pm->op_pmflags & PMf_USED) {
703 if (gimme == G_ARRAY)
708 if (!rx->prelen && curpm) {
710 rx = pm->op_pmregexp;
713 if (global = pm->op_pmflags & PMf_GLOBAL) {
715 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
716 MAGIC* mg = mg_find(TARG, 'g');
717 if (mg && mg->mg_ptr) {
718 rx->startp[0] = mg->mg_ptr;
719 rx->endp[0] = mg->mg_ptr + mg->mg_len;
723 safebase = (gimme == G_ARRAY) || global;
726 if (global && rx->startp[0]) {
728 if (s == rx->startp[0])
733 if (pm->op_pmshort) {
734 if (pm->op_pmflags & PMf_SCANFIRST) {
735 if (SvSCREAM(TARG)) {
736 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
738 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
740 else if (pm->op_pmflags & PMf_ALL)
743 else if (!(s = fbm_instr((unsigned char*)s,
744 (unsigned char*)strend, pm->op_pmshort)))
746 else if (pm->op_pmflags & PMf_ALL)
748 if (s && rx->regback >= 0) {
749 ++BmUSEFUL(pm->op_pmshort);
757 else if (!multiline) {
758 if (*SvPVX(pm->op_pmshort) != *s ||
759 bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
760 if (pm->op_pmflags & PMf_FOLD) {
761 if (ibcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) )
768 if (--BmUSEFUL(pm->op_pmshort) < 0) {
769 sv_free(pm->op_pmshort);
770 pm->op_pmshort = Nullsv; /* opt is being useless */
773 if (!rx->nparens && !global) {
774 gimme = G_SCALAR; /* accidental array context? */
777 if (regexec(rx, s, strend, truebase, 0,
778 SvSCREAM(TARG) ? TARG : Nullsv,
781 if (pm->op_pmflags & PMf_ONCE)
782 pm->op_pmflags |= PMf_USED;
790 if (gimme == G_ARRAY) {
794 if (global && !iters)
798 EXTEND(SP, iters + i);
799 for (i = !i; i <= iters; i++) {
800 PUSHs(sv_mortalcopy(&sv_no));
802 if (s = rx->startp[i]) {
803 len = rx->endp[i] - s;
805 sv_setpvn(*SP, s, len);
809 truebase = rx->subbeg;
817 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
818 mg = mg_find(TARG, 'g');
820 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
821 mg = mg_find(TARG, 'g');
823 mg->mg_ptr = rx->startp[0];
824 mg->mg_len = rx->endp[0] - rx->startp[0];
830 ++BmUSEFUL(pm->op_pmshort);
832 if (pm->op_pmflags & PMf_ONCE)
833 pm->op_pmflags |= PMf_USED;
838 rx->endp[0] = s + SvCUR(pm->op_pmshort);
845 Safefree(rx->subbase);
846 tmps = rx->subbase = nsavestr(t, strend-t);
848 rx->subend = tmps + (strend-t);
849 tmps = rx->startp[0] = tmps + (s - t);
850 rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
856 ++BmUSEFUL(pm->op_pmshort);
860 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
861 MAGIC* mg = mg_find(TARG, 'g');
868 if (gimme == G_ARRAY)
876 register PMOP *pm = cPMOP;
891 register REGEXP *rx = pm->op_pmregexp;
894 if (pm->op_pmflags & PMf_CONST) /* known replacement string? */
896 if (op->op_flags & OPf_STACKED)
904 DIE("panic: do_subst");
907 maxiters = (strend - s) + 10;
909 if (!rx->prelen && curpm) {
911 rx = pm->op_pmregexp;
913 safebase = ((!rx || !rx->nparens) && !sawampersand);
915 if (pm->op_pmshort) {
916 if (pm->op_pmflags & PMf_SCANFIRST) {
917 if (SvSCREAM(TARG)) {
918 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
920 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
923 else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
926 if (s && rx->regback >= 0) {
927 ++BmUSEFUL(pm->op_pmshort);
935 else if (!multiline) {
936 if (*SvPVX(pm->op_pmshort) != *s ||
937 bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
938 if (pm->op_pmflags & PMf_FOLD) {
939 if (ibcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) )
946 if (--BmUSEFUL(pm->op_pmshort) < 0) {
947 sv_free(pm->op_pmshort);
948 pm->op_pmshort = Nullsv; /* opt is being useless */
951 once = !(rpm->op_pmflags & PMf_GLOBAL);
952 if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */
953 c = SvPV(dstr, clen);
954 if (clen <= rx->minlen) {
955 /* can do inplace substitution */
956 if (regexec(rx, s, strend, orig, 0,
957 SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
958 if (rx->subbase) /* oops, no we can't */
962 SvSCREAM_off(TARG); /* disable possible screamer */
967 if (m - s > strend - d) { /* faster to shorten from end */
969 Copy(c, m, clen, char);
978 SvCUR_set(TARG, m - s);
985 else if (i = m - s) { /* faster from front */
993 Copy(c, m, clen, char);
1002 Copy(c, d, clen, char);
1018 if (iters++ > maxiters)
1019 DIE("Substitution loop");
1024 Move(s, d, i, char);
1028 Copy(c, d, clen, char);
1032 } while (regexec(rx, s, strend, orig, s == m,
1033 Nullsv, TRUE)); /* (don't match same null twice) */
1036 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1037 Move(s, d, i+1, char); /* include the Null */
1041 PUSHs(sv_2mortal(newSVnv((double)iters)));
1050 if (regexec(rx, s, strend, orig, 0,
1051 SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1053 dstr = NEWSV(25, sv_len(TARG));
1054 sv_setpvn(dstr, m, s-m);
1057 register CONTEXT *cx;
1059 RETURNOP(cPMOP->op_pmreplroot);
1062 if (iters++ > maxiters)
1063 DIE("Substitution loop");
1064 if (rx->subbase && rx->subbase != orig) {
1069 strend = s + (strend - m);
1072 sv_catpvn(dstr, s, m-s);
1075 sv_catpvn(dstr, c, clen);
1078 } while (regexec(rx, s, strend, orig, s == m, Nullsv,
1080 sv_catpvn(dstr, s, strend - s);
1081 sv_replace(TARG, dstr);
1084 PUSHs(sv_2mortal(newSVnv((double)iters)));
1091 ++BmUSEFUL(pm->op_pmshort);
1099 register PMOP *pm = (PMOP*) cLOGOP->op_other;
1100 register CONTEXT *cx = &cxstack[cxstack_ix];
1101 register SV *dstr = cx->sb_dstr;
1102 register char *s = cx->sb_s;
1103 register char *m = cx->sb_m;
1104 char *orig = cx->sb_orig;
1105 register REGEXP *rx = pm->op_pmregexp;
1107 if (cx->sb_iters++) {
1108 if (cx->sb_iters > cx->sb_maxiters)
1109 DIE("Substitution loop");
1111 sv_catsv(dstr, POPs);
1113 Safefree(rx->subbase);
1114 rx->subbase = cx->sb_subbase;
1117 if (cx->sb_once || !regexec(rx, s, cx->sb_strend, orig,
1118 s == m, Nullsv, cx->sb_safebase))
1120 SV *targ = cx->sb_targ;
1121 sv_catpvn(dstr, s, cx->sb_strend - s);
1122 sv_replace(targ, dstr);
1125 PUSHs(sv_2mortal(newSVnv((double)(cx->sb_iters - 1))));
1127 RETURNOP(pm->op_next);
1130 if (rx->subbase && rx->subbase != orig) {
1133 cx->sb_orig = orig = rx->subbase;
1135 cx->sb_strend = s + (cx->sb_strend - m);
1137 cx->sb_m = m = rx->startp[0];
1138 sv_catpvn(dstr, s, m-s);
1139 cx->sb_s = rx->endp[0];
1140 cx->sb_subbase = rx->subbase;
1142 rx->subbase = Nullch; /* so recursion works */
1143 RETURNOP(pm->op_pmreplstart);
1151 if (op->op_flags & OPf_STACKED)
1158 PUSHi(do_trans(sv, op));
1162 /* Lvalue operators. */
1167 if (tainting && tainted && (!SvMAGICAL(lstr) || !mg_find(lstr, 't'))) {
1170 SvSetSV(rstr, lstr);
1179 SV **lastlelem = stack_sp;
1180 SV **lastrelem = stack_base + POPMARK;
1181 SV **firstrelem = stack_base + POPMARK + 1;
1182 SV **firstlelem = lastrelem + 1;
1184 register SV **relem;
1185 register SV **lelem;
1194 delaymagic = DM_DELAY; /* catch simultaneous items */
1196 /* If there's a common identifier on both sides we have to take
1197 * special care that assigning the identifier on the left doesn't
1198 * clobber a value on the right that's used later in the list.
1200 if (op->op_private & OPpASSIGN_COMMON) {
1201 for (relem = firstrelem; relem <= lastrelem; relem++) {
1204 *relem = sv_mortalcopy(sv);
1212 while (lelem <= lastlelem) {
1214 switch (SvTYPE(sv)) {
1217 magic = SvMAGICAL(ary) != 0;
1221 while (relem <= lastrelem) { /* gobble up all the rest */
1224 sv_setsv(sv,*relem);
1226 (void)av_store(ary,i++,sv);
1236 magic = SvMAGICAL(hash) != 0;
1239 while (relem < lastrelem) { /* gobble up all the rest */
1244 sv = &sv_no, relem++;
1245 tmps = SvPV(sv, len);
1246 tmpstr = NEWSV(29,0);
1248 sv_setsv(tmpstr,*relem); /* value */
1249 *(relem++) = tmpstr;
1250 (void)hv_store(hash,tmps,len,tmpstr,0);
1257 if (SvREADONLY(sv)) {
1258 if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
1260 if (relem <= lastrelem)
1264 if (relem <= lastrelem) {
1265 sv_setsv(sv, *relem);
1269 sv_setsv(sv, &sv_undef);
1274 if (delaymagic & ~DM_DELAY) {
1275 if (delaymagic & DM_UID) {
1277 (void)setreuid(uid,euid);
1278 #else /* not HAS_SETREUID */
1280 if ((delaymagic & DM_UID) == DM_RUID) {
1282 delaymagic =~ DM_RUID;
1284 #endif /* HAS_SETRUID */
1286 if ((delaymagic & DM_UID) == DM_EUID) {
1288 delaymagic =~ DM_EUID;
1290 #endif /* HAS_SETEUID */
1291 if (delaymagic & DM_UID) {
1293 DIE("No setreuid available");
1296 #endif /* not HAS_SETREUID */
1297 uid = (int)getuid();
1298 euid = (int)geteuid();
1300 if (delaymagic & DM_GID) {
1302 (void)setregid(gid,egid);
1303 #else /* not HAS_SETREGID */
1305 if ((delaymagic & DM_GID) == DM_RGID) {
1307 delaymagic =~ DM_RGID;
1309 #endif /* HAS_SETRGID */
1311 if ((delaymagic & DM_GID) == DM_EGID) {
1313 delaymagic =~ DM_EGID;
1315 #endif /* HAS_SETEGID */
1316 if (delaymagic & DM_GID) {
1318 DIE("No setregid available");
1321 #endif /* not HAS_SETREGID */
1322 gid = (int)getgid();
1323 egid = (int)getegid();
1325 tainting |= (euid != uid || egid != gid);
1328 if (GIMME == G_ARRAY) {
1332 SP = firstrelem + (lastlelem - firstlelem);
1338 SETi(lastrelem - firstrelem + 1);
1359 dSP; dMARK; dTARGET;
1361 do_chop(TARG, POPs);
1377 if (!sv || !SvANY(sv))
1379 switch (SvTYPE(sv)) {
1404 if (!op->op_private)
1408 if (!sv || SvREADONLY(sv))
1411 switch (SvTYPE(sv)) {
1415 sv_free((SV*)SvANY(sv));
1417 SvTYPE(sv) = SVt_NULL;
1430 if (sv != GvSV(defgv)) {
1431 if (SvPOK(sv) && SvLEN(sv)) {
1433 Safefree(SvPVX(sv));
1434 SvPV_set(sv, Nullch);
1448 register unsigned char *s;
1451 register I32 *sfirst;
1452 register I32 *snext;
1456 s = (unsigned char*)(SvPV(TARG, len));
1459 SvSCREAM_off(lastscream);
1465 if (pos > maxscream) {
1466 if (maxscream < 0) {
1467 maxscream = pos + 80;
1468 New(301, screamfirst, 256, I32);
1469 New(302, screamnext, maxscream, I32);
1472 maxscream = pos + pos / 4;
1473 Renew(screamnext, maxscream, I32);
1477 sfirst = screamfirst;
1480 if (!sfirst || !snext)
1481 DIE("do_study: out of memory");
1483 for (ch = 256; ch; --ch)
1487 while (--pos >= 0) {
1489 if (sfirst[ch] >= 0)
1490 snext[pos] = sfirst[ch] - pos;
1495 /* If there were any case insensitive searches, we must assume they
1496 * all are. This speeds up insensitive searches much more than
1497 * it slows down sensitive ones.
1500 sfirst[fold[ch]] = pos;
1506 XPUSHs(sv_2mortal(newSVnv((double)retval)));
1529 sv_setsv(TARG, TOPs);
1539 sv_setsv(TARG, TOPs);
1546 /* Ordinary operators. */
1550 dSP; dATARGET; dPOPTOPnnrl;
1551 SETn( pow( left, right) );
1557 dSP; dATARGET; dPOPTOPnnrl;
1558 SETn( left * right );
1564 dSP; dATARGET; dPOPnv;
1566 DIE("Illegal division by zero");
1568 /* insure that 20./5. == 4. */
1573 if ((double)(I32)x == x &&
1574 (double)(I32)value == value &&
1575 (k = (I32)x/(I32)value)*(I32)value == (I32)x) {
1582 value = POPn / value;
1591 register unsigned long tmpulong;
1592 register long tmplong;
1595 tmpulong = (unsigned long) POPn;
1597 DIE("Illegal modulus zero");
1600 value = (I32)(((unsigned long)value) % tmpulong);
1602 tmplong = (long)value;
1603 value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
1612 register I32 count = POPi;
1613 if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
1615 I32 items = SP - MARK;
1618 max = items * count;
1627 repeatcpy((char*)(MARK + items), (char*)MARK,
1628 items * sizeof(SV*), count - 1);
1632 else { /* Note: mark already snarfed by pp_list */
1637 if (SvREADONLY(tmpstr))
1638 DIE("Can't x= to readonly value");
1639 SvSetSV(TARG, tmpstr);
1643 tmpstr = NEWSV(50, 0);
1644 tmps = SvPV(TARG, len);
1645 sv_setpvn(tmpstr, tmps, len);
1646 tmps = SvPV(tmpstr, tlen); /* force to be string */
1647 SvGROW(TARG, (count * len) + 1);
1648 repeatcpy((char*)SvPVX(TARG), tmps, tlen, count);
1649 SvCUR(TARG) *= count;
1650 *SvEND(TARG) = '\0';
1655 sv_setsv(TARG, &sv_no);
1663 dSP; dATARGET; dPOPTOPnnrl;
1664 SETn( left + right );
1670 dSP; dATARGET; dPOPTOPiirl;
1671 SETi( left + right );
1677 dSP; dATARGET; dPOPTOPnnrl;
1678 SETn( left - right );
1684 dSP; dATARGET; dPOPTOPssrl;
1685 SvSetSV(TARG, lstr);
1686 sv_catsv(TARG, rstr);
1695 double value = TOPn;
1696 SETi( U_L(value) << anum );
1704 double value = TOPn;
1705 SETi( U_L(value) >> anum );
1712 SETs((TOPn < value) ? &sv_yes : &sv_no);
1719 SETs((TOPn > value) ? &sv_yes : &sv_no);
1726 SETs((TOPn <= value) ? &sv_yes : &sv_no);
1733 SETs((TOPn >= value) ? &sv_yes : &sv_no);
1740 SETs((TOPn == value) ? &sv_yes : &sv_no);
1747 SETs((TOPn != value) ? &sv_yes : &sv_no);
1753 dSP; dTARGET; dPOPTOPnnrl;
1758 else if (left < right)
1769 SETs( sv_cmp(lstr, rstr) < 0 ? &sv_yes : &sv_no );
1776 SETs( sv_cmp(lstr, rstr) > 0 ? &sv_yes : &sv_no );
1783 SETs( sv_cmp(lstr, rstr) <= 0 ? &sv_yes : &sv_no );
1790 SETs( sv_cmp(lstr, rstr) >= 0 ? &sv_yes : &sv_no );
1797 SETs( sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
1804 SETs( !sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
1812 SETi( sv_cmp(lstr, rstr) );
1818 dSP; dATARGET; dPOPTOPssrl;
1819 if (SvNIOK(lstr) || SvNIOK(rstr)) {
1820 I32 value = SvIV(lstr);
1821 value = value & SvIV(rstr);
1825 do_vop(op->op_type, TARG, lstr, rstr);
1833 dSP; dATARGET; dPOPTOPssrl;
1834 if (SvNIOK(lstr) || SvNIOK(rstr)) {
1835 I32 value = SvIV(lstr);
1836 value = value ^ SvIV(rstr);
1840 do_vop(op->op_type, TARG, lstr, rstr);
1848 dSP; dATARGET; dPOPTOPssrl;
1849 if (SvNIOK(lstr) || SvNIOK(rstr)) {
1850 I32 value = SvIV(lstr);
1851 value = value | SvIV(rstr);
1855 do_vop(op->op_type, TARG, lstr, rstr);
1870 *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
1876 dSP; dTARGET; dTOPss;
1883 register char *tmps;
1884 register long *tmpl;
1888 tmps = SvPV(TARG, len);
1891 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1894 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1898 for ( ; anum > 0; anum--, tmps++)
1906 /* High falutin' math. */
1910 dSP; dTARGET; dPOPTOPnnrl;
1911 SETn(atan2(left, right));
1920 value = SvNVx(GvSV(defgv));
1933 value = SvNVx(GvSV(defgv));
1952 value = rand() * value / 2147483648.0;
1955 value = rand() * value / 65536.0;
1958 value = rand() * value / 32768.0;
1960 value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1990 value = SvNVx(GvSV(defgv));
2003 value = SvNVx(GvSV(defgv));
2007 DIE("Can't take log of %g\n", value);
2018 value = SvNVx(GvSV(defgv));
2022 DIE("Can't take sqrt of %g\n", value);
2023 value = sqrt(value);
2033 value = SvNVx(GvSV(defgv));
2037 (void)modf(value, &value);
2039 (void)modf(-value, &value);
2051 value = SvNVx(GvSV(defgv));
2069 tmps = SvPVx(GvSV(defgv), na);
2072 XPUSHi( scan_hex(tmps, 99, &argtype) );
2084 tmps = SvPVx(GvSV(defgv), na);
2087 while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
2090 value = (I32)scan_hex(++tmps, 99, &argtype);
2092 value = (I32)scan_oct(tmps, 99, &argtype);
2103 XPUSHi( sv_len(GvSV(defgv)) );
2106 SETi( sv_len(TOPs) );
2118 I32 lvalue = op->op_flags & OPf_LVAL;
2123 pos = POPi - arybase;
2125 tmps = SvPV(sv, curlen); /* force conversion to string */
2127 pos += curlen + arybase;
2128 if (pos < 0 || pos > curlen)
2129 sv_setpvn(TARG, "", 0);
2136 rem = curlen - pos; /* rem=how many bytes left*/
2139 sv_setpvn(TARG, tmps, rem);
2140 if (lvalue) { /* it's an lvalue! */
2145 LvTARGOFF(TARG) = tmps - SvPV(sv, na);
2146 LvTARGLEN(TARG) = rem;
2149 PUSHs(TARG); /* avoid SvSETMAGIC here */
2156 register I32 size = POPi;
2157 register I32 offset = POPi;
2158 register SV *src = POPs;
2159 I32 lvalue = op->op_flags & OPf_LVAL;
2161 unsigned char *s = (unsigned char*)SvPV(src, srclen);
2162 unsigned long retnum;
2165 offset *= size; /* turn into bit offset */
2166 len = (offset + size + 7) / 8;
2167 if (offset < 0 || size < 1)
2169 else if (!lvalue && len > srclen)
2174 (void)memzero(SvPVX(src) + srclen, len - srclen);
2175 SvCUR_set(src, len);
2177 s = (unsigned char*)SvPV(src, na);
2179 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2184 else if (size == 16)
2185 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2186 else if (size == 32)
2187 retnum = ((unsigned long) s[offset] << 24) +
2188 ((unsigned long) s[offset + 1] << 16) +
2189 (s[offset + 2] << 8) + s[offset+3];
2192 if (lvalue) { /* it's an lvalue! */
2193 if (SvREADONLY(src))
2197 LvTARGOFF(TARG) = offset;
2198 LvTARGLEN(TARG) = size;
2202 sv_setiv(TARG, (I32)retnum);
2221 offset = POPi - arybase;
2224 tmps = SvPV(big, biglen);
2227 else if (offset > biglen)
2229 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2230 (unsigned char*)tmps + biglen, little)))
2231 retval = -1 + arybase;
2233 retval = tmps2 - tmps + arybase;
2255 tmps2 = SvPV(little, llen);
2256 tmps = SvPV(big, blen);
2260 offset = SvIV(offstr) - arybase + llen;
2263 else if (offset > blen)
2265 if (!(tmps2 = rninstr(tmps, tmps + offset,
2266 tmps2, tmps2 + llen)))
2267 retval = -1 + arybase;
2269 retval = tmps2 - tmps + arybase;
2276 dSP; dMARK; dORIGMARK; dTARGET;
2277 do_sprintf(TARG, SP-MARK, MARK+1);
2288 register char *s = SvPV(sv, len);
2289 register char *send = s + len;
2290 register char *base;
2291 register I32 skipspaces = 0;
2294 bool postspace = FALSE;
2301 New(804, fops, send - s, U16); /* Almost certainly too long... */
2306 *fpc++ = FF_LINEMARK;
2307 noblank = repeat = FALSE;
2325 case ' ': case '\t':
2338 *fpc++ = FF_LITERAL;
2345 *fpc++ = skipspaces;
2349 *fpc++ = FF_NEWLINE;
2353 arg = fpc - linepc + 1;
2360 *fpc++ = FF_LINEMARK;
2361 noblank = repeat = FALSE;
2370 ischop = s[-1] == '^';
2376 arg = (s - base) - 1;
2378 *fpc++ = FF_LITERAL;
2387 *fpc++ = FF_LINEGLOB;
2389 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2390 arg = ischop ? 512 : 0;
2400 arg |= 256 + (s - f);
2402 *fpc++ = s - base; /* fieldsize for FETCH */
2403 *fpc++ = FF_DECIMAL;
2408 bool ismore = FALSE;
2411 while (*++s == '>') ;
2412 prespace = FF_SPACE;
2414 else if (*s == '|') {
2415 while (*++s == '|') ;
2416 prespace = FF_HALFSPACE;
2421 while (*++s == '<') ;
2424 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2428 *fpc++ = s - base; /* fieldsize for FETCH */
2430 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2448 SvGROW(sv, SvCUR(sv) + arg * sizeof(U16) + 4);
2450 s = SvPVX(sv) + SvCUR(sv);
2451 s += 2 + (SvCUR(sv) & 1);
2453 Copy(fops, s, arg, U16);
2459 dSP; dMARK; dORIGMARK;
2460 register SV *form = *++MARK;
2465 register char *send;
2471 bool chopspace = (strchr(chopset, ' ') != Nullch);
2480 if (!SvCOMPILED(form))
2483 SvUPGRADE(formtarget, SVt_PV);
2484 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
2485 t = SvPV(formtarget, len);
2487 f = SvPV(form, len);
2499 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
2500 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
2501 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
2502 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
2503 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
2505 case FF_CHECKNL: name = "CHECKNL"; break;
2506 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
2507 case FF_SPACE: name = "SPACE"; break;
2508 case FF_HALFSPACE: name = "HALFSPACE"; break;
2509 case FF_ITEM: name = "ITEM"; break;
2510 case FF_CHOP: name = "CHOP"; break;
2511 case FF_LINEGLOB: name = "LINEGLOB"; break;
2512 case FF_NEWLINE: name = "NEWLINE"; break;
2513 case FF_MORE: name = "MORE"; break;
2514 case FF_LINEMARK: name = "LINEMARK"; break;
2515 case FF_END: name = "END"; break;
2518 fprintf(stderr, "%-16s%d\n", name, arg);
2520 fprintf(stderr, "%-16s\n", name);
2551 warn("Not enough format arguments");
2558 if (itemsize > fieldsize)
2559 itemsize = fieldsize;
2560 send = chophere = s + itemsize;
2564 else if (*s == '\n')
2568 itemsize = s - SvPVX(sv);
2574 if (itemsize > fieldsize)
2575 itemsize = fieldsize;
2576 send = chophere = s + itemsize;
2577 while (s < send || (s == send && isSPACE(*s))) {
2587 if (strchr(chopset, *s))
2592 itemsize = chophere - SvPVX(sv);
2596 arg = fieldsize - itemsize;
2605 arg = fieldsize - itemsize;
2618 if ((*t++ = *s++) < ' ')
2626 while (*s && isSPACE(*s))
2637 send = s + itemsize;
2646 SvCUR_set(formtarget, t - SvPVX(formtarget));
2647 sv_catpvn(formtarget, SvPVX(sv), itemsize);
2648 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
2649 t = SvPVX(formtarget) + SvCUR(formtarget);
2654 /* If the field is marked with ^ and the value is undefined,
2657 if ((arg & 512) && !SvOK(sv)) {
2666 sprintf(t, "%#*.*f", fieldsize, arg & 255, value);
2668 sprintf(t, "%*.0f", fieldsize, value);
2675 while (t-- > linemark && *t == ' ') ;
2683 if (arg) { /* repeat until fields exhausted? */
2689 if (strnEQ(linemark, linemark - t, arg))
2690 DIE("Runaway format");
2692 arg = t - SvPVX(formtarget);
2694 (t - SvPVX(formtarget)) + (f - formmark) + 1);
2695 t = SvPVX(formtarget) + arg;
2706 arg = fieldsize - itemsize;
2713 if (strnEQ(s," ",3)) {
2714 while (s > SvPVX(formtarget) && isSPACE(s[-1]))
2725 SvCUR_set(formtarget, t - SvPVX(formtarget));
2726 FmLINES(formtarget) += lines;
2741 tmps = SvPVx(GvSV(defgv), na);
2745 value = (I32) (*tmps & 255);
2748 value = (I32) (anum & 255);
2759 if (SvTYPE(TARG) == SVt_NULL) {
2760 sv_upgrade(TARG,SVt_PV);
2766 *tmps = SvIVx(GvSV(defgv));
2776 dSP; dTARGET; dPOPTOPssrl;
2778 char *tmps = SvPV(lstr, na);
2780 sv_setpv(TARG, fcrypt(tmps, SvPV(rstr, na)));
2782 sv_setpv(TARG, crypt(tmps, SvPV(rstr, na)));
2786 "The crypt() function is unimplemented due to excessive paranoia.");
2798 if (SvSTORAGE(sv) != 'T') {
2805 if (isascii(*s) && islower(*s))
2817 if (SvSTORAGE(sv) != 'T') {
2824 if (isascii(*s) && isupper(*s))
2836 register char *send;
2839 if (SvSTORAGE(sv) != 'T') {
2848 if (isascii(*s) && islower(*s))
2860 register char *send;
2863 if (SvSTORAGE(sv) != 'T') {
2872 if (isascii(*s) && isupper(*s))
2887 if (SvTYPE(sv) == SVt_REF) {
2888 av = (AV*)SvANY(sv);
2889 if (SvTYPE(av) != SVt_PVAV)
2890 DIE("Not an array reference");
2891 if (op->op_flags & OPf_LVAL) {
2892 if (op->op_flags & OPf_INTRO)
2893 av = (AV*)save_svref((SV**)sv);
2899 if (SvTYPE(sv) == SVt_PVAV) {
2901 if (op->op_flags & OPf_LVAL) {
2907 if (SvTYPE(sv) != SVt_PVGV) {
2910 sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
2913 if (op->op_flags & OPf_LVAL) {
2914 if (op->op_flags & OPf_INTRO)
2922 if (GIMME == G_ARRAY) {
2923 I32 maxarg = AvFILL(av) + 1;
2925 Copy(AvARRAY(av), SP+1, maxarg, SV*);
2930 I32 maxarg = AvFILL(av) + 1;
2939 AV *av = (AV*)cSVOP->op_sv;
2940 SV** svp = av_fetch(av, op->op_private - arybase, FALSE);
2941 PUSHs(svp ? *svp : &sv_undef);
2949 I32 elem = POPi - arybase;
2952 if (op->op_flags & OPf_LVAL) {
2953 svp = av_fetch(av, elem, TRUE);
2954 if (!svp || *svp == &sv_undef)
2955 DIE(no_aelem, elem);
2956 if (op->op_flags & OPf_INTRO)
2958 else if (!SvOK(*svp)) {
2959 if (op->op_private == OP_RV2HV) {
2962 sv_upgrade(*svp, SVt_REF);
2963 SvANY(*svp) = (void*)sv_ref((SV*)newHV());
2965 else if (op->op_private == OP_RV2AV) {
2968 sv_upgrade(*svp, SVt_REF);
2969 SvANY(*svp) = (void*)sv_ref((SV*)newAV());
2974 svp = av_fetch(av, elem, FALSE);
2975 PUSHs(svp ? *svp : &sv_undef);
2981 dSP; dMARK; dORIGMARK;
2983 register AV* av = (AV*)POPs;
2984 register I32 lval = op->op_flags & OPf_LVAL;
2985 I32 is_something_there = lval;
2987 while (++MARK <= SP) {
2988 I32 elem = SvIVx(*MARK);
2991 svp = av_fetch(av, elem, TRUE);
2992 if (!svp || *svp == &sv_undef)
2993 DIE(no_aelem, elem);
2994 if (op->op_flags & OPf_INTRO)
2998 svp = av_fetch(av, elem, FALSE);
2999 if (!is_something_there && svp && SvOK(*svp))
3000 is_something_there = TRUE;
3002 *MARK = svp ? *svp : &sv_undef;
3004 if (!is_something_there)
3009 /* Associative arrays. */
3014 HV *hash = (HV*)POPs;
3015 HE *entry = hv_iternext(hash);
3026 if (GIMME == G_ARRAY) {
3027 tmps = hv_iterkey(entry, &i);
3030 mystrk = newSVpv(tmps, i);
3033 sv_setsv(TARG, hv_iterval(hash, entry));
3036 else if (GIMME == G_SCALAR)
3061 DIE("Not an associative array reference");
3063 tmps = SvPV(tmpsv, len);
3064 sv = hv_delete(hv, tmps, len);
3078 if (SvTYPE(sv) == SVt_REF) {
3079 hv = (HV*)SvANY(sv);
3080 if (SvTYPE(hv) != SVt_PVHV)
3081 DIE("Not an associative array reference");
3082 if (op->op_flags & OPf_LVAL) {
3083 if (op->op_flags & OPf_INTRO)
3084 hv = (HV*)save_svref((SV**)sv);
3090 if (SvTYPE(sv) == SVt_PVHV) {
3092 if (op->op_flags & OPf_LVAL) {
3098 if (SvTYPE(sv) != SVt_PVGV) {
3101 sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE);
3104 if (op->op_flags & OPf_LVAL) {
3105 if (op->op_flags & OPf_INTRO)
3113 if (GIMME == G_ARRAY) { /* array wanted */
3114 *stack_sp = (SV*)hv;
3122 sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1);
3123 sv_setpv(TARG, buf);
3136 char *key = SvPV(keysv, keylen);
3139 if (op->op_flags & OPf_LVAL) {
3140 svp = hv_fetch(hv, key, keylen, TRUE);
3141 if (!svp || *svp == &sv_undef)
3143 if (op->op_flags & OPf_INTRO)
3145 else if (!SvOK(*svp)) {
3146 if (op->op_private == OP_RV2HV) {
3149 sv_upgrade(*svp, SVt_REF);
3150 SvANY(*svp) = (void*)sv_ref((SV*)newHV());
3152 else if (op->op_private == OP_RV2AV) {
3155 sv_upgrade(*svp, SVt_REF);
3156 SvANY(*svp) = (void*)sv_ref((SV*)newAV());
3161 svp = hv_fetch(hv, key, keylen, FALSE);
3162 PUSHs(svp ? *svp : &sv_undef);
3168 dSP; dMARK; dORIGMARK;
3170 register HV *hv = (HV*)POPs;
3171 register I32 lval = op->op_flags & OPf_LVAL;
3172 I32 is_something_there = lval;
3174 while (++MARK <= SP) {
3176 char *key = SvPV(*MARK, keylen);
3179 svp = hv_fetch(hv, key, keylen, TRUE);
3180 if (!svp || *svp == &sv_undef)
3182 if (op->op_flags & OPf_INTRO)
3186 svp = hv_fetch(hv, key, keylen, FALSE);
3187 if (!is_something_there && svp && SvOK(*svp))
3188 is_something_there = TRUE;
3190 *MARK = svp ? *svp : &sv_undef;
3192 if (!is_something_there)
3197 /* Explosives and implosives. */
3206 register char *pat = SvPV(lstr, llen);
3207 register char *s = SvPV(rstr, rlen);
3208 char *strend = s + rlen;
3210 register char *patend = pat + llen;
3215 /* These must not be in registers: */
3226 unsigned quad auquad;
3232 register U32 culong;
3234 static char* bitcount = 0;
3236 if (GIMME != G_ARRAY) { /* arrange to do first one only */
3238 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3239 if (strchr("aAbBhH", *patend) || *pat == '%') {
3241 while (isDIGIT(*patend) || *patend == '*')
3247 while (pat < patend) {
3252 else if (*pat == '*') {
3253 len = strend - strbeg; /* long enough */
3256 else if (isDIGIT(*pat)) {
3258 while (isDIGIT(*pat))
3259 len = (len * 10) + (*pat++ - '0');
3262 len = (datumtype != '@');
3267 if (len == 1 && pat[-1] != '1')
3276 if (len > strend - strbeg)
3277 DIE("@ outside of string");
3281 if (len > s - strbeg)
3282 DIE("X outside of string");
3286 if (len > strend - s)
3287 DIE("x outside of string");
3292 if (len > strend - s)
3295 goto uchar_checksum;
3296 sv = NEWSV(35, len);
3297 sv_setpvn(sv, s, len);
3299 if (datumtype == 'A') {
3300 aptr = s; /* borrow register */
3301 s = SvPVX(sv) + len - 1;
3302 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3305 SvCUR_set(sv, s - SvPVX(sv));
3306 s = aptr; /* unborrow register */
3308 XPUSHs(sv_2mortal(sv));
3312 if (pat[-1] == '*' || len > (strend - s) * 8)
3313 len = (strend - s) * 8;
3316 Newz(601, bitcount, 256, char);
3317 for (bits = 1; bits < 256; bits++) {
3318 if (bits & 1) bitcount[bits]++;
3319 if (bits & 2) bitcount[bits]++;
3320 if (bits & 4) bitcount[bits]++;
3321 if (bits & 8) bitcount[bits]++;
3322 if (bits & 16) bitcount[bits]++;
3323 if (bits & 32) bitcount[bits]++;
3324 if (bits & 64) bitcount[bits]++;
3325 if (bits & 128) bitcount[bits]++;
3329 culong += bitcount[*(unsigned char*)s++];
3334 if (datumtype == 'b') {
3336 if (bits & 1) culong++;
3342 if (bits & 128) culong++;
3349 sv = NEWSV(35, len + 1);
3352 aptr = pat; /* borrow register */
3354 if (datumtype == 'b') {
3356 for (len = 0; len < aint; len++) {
3357 if (len & 7) /*SUPPRESS 595*/
3361 *pat++ = '0' + (bits & 1);
3366 for (len = 0; len < aint; len++) {
3371 *pat++ = '0' + ((bits & 128) != 0);
3375 pat = aptr; /* unborrow register */
3376 XPUSHs(sv_2mortal(sv));
3380 if (pat[-1] == '*' || len > (strend - s) * 2)
3381 len = (strend - s) * 2;
3382 sv = NEWSV(35, len + 1);
3385 aptr = pat; /* borrow register */
3387 if (datumtype == 'h') {
3389 for (len = 0; len < aint; len++) {
3394 *pat++ = hexdigit[bits & 15];
3399 for (len = 0; len < aint; len++) {
3404 *pat++ = hexdigit[(bits >> 4) & 15];
3408 pat = aptr; /* unborrow register */
3409 XPUSHs(sv_2mortal(sv));
3412 if (len > strend - s)
3417 if (aint >= 128) /* fake up signed chars */
3426 if (aint >= 128) /* fake up signed chars */
3429 sv_setiv(sv, (I32)aint);
3430 PUSHs(sv_2mortal(sv));
3435 if (len > strend - s)
3449 sv_setiv(sv, (I32)auint);
3450 PUSHs(sv_2mortal(sv));
3455 along = (strend - s) / sizeof(I16);
3460 Copy(s, &ashort, 1, I16);
3468 Copy(s, &ashort, 1, I16);
3471 sv_setiv(sv, (I32)ashort);
3472 PUSHs(sv_2mortal(sv));
3479 along = (strend - s) / sizeof(U16);
3484 Copy(s, &aushort, 1, U16);
3487 if (datumtype == 'n')
3488 aushort = ntohs(aushort);
3491 if (datumtype == 'v')
3492 aushort = vtohs(aushort);
3500 Copy(s, &aushort, 1, U16);
3504 if (datumtype == 'n')
3505 aushort = ntohs(aushort);
3508 if (datumtype == 'v')
3509 aushort = vtohs(aushort);
3511 sv_setiv(sv, (I32)aushort);
3512 PUSHs(sv_2mortal(sv));
3517 along = (strend - s) / sizeof(int);
3522 Copy(s, &aint, 1, int);
3525 cdouble += (double)aint;
3533 Copy(s, &aint, 1, int);
3536 sv_setiv(sv, (I32)aint);
3537 PUSHs(sv_2mortal(sv));
3542 along = (strend - s) / sizeof(unsigned int);
3547 Copy(s, &auint, 1, unsigned int);
3548 s += sizeof(unsigned int);
3550 cdouble += (double)auint;
3558 Copy(s, &auint, 1, unsigned int);
3559 s += sizeof(unsigned int);
3561 sv_setiv(sv, (I32)auint);
3562 PUSHs(sv_2mortal(sv));
3567 along = (strend - s) / sizeof(I32);
3572 Copy(s, &along, 1, I32);
3575 cdouble += (double)along;
3583 Copy(s, &along, 1, I32);
3586 sv_setiv(sv, (I32)along);
3587 PUSHs(sv_2mortal(sv));
3594 along = (strend - s) / sizeof(U32);
3599 Copy(s, &aulong, 1, U32);
3602 if (datumtype == 'N')
3603 aulong = ntohl(aulong);
3606 if (datumtype == 'V')
3607 aulong = vtohl(aulong);
3610 cdouble += (double)aulong;
3618 Copy(s, &aulong, 1, U32);
3622 if (datumtype == 'N')
3623 aulong = ntohl(aulong);
3626 if (datumtype == 'V')
3627 aulong = vtohl(aulong);
3629 sv_setnv(sv, (double)aulong);
3630 PUSHs(sv_2mortal(sv));
3635 along = (strend - s) / sizeof(char*);
3640 if (sizeof(char*) > strend - s)
3643 Copy(s, &aptr, 1, char*);
3649 PUSHs(sv_2mortal(sv));
3654 if (sizeof(char*) > strend - s)
3657 Copy(s, &aptr, 1, char*);
3662 sv_setpvn(sv, aptr, len);
3663 PUSHs(sv_2mortal(sv));
3669 if (s + sizeof(quad) > strend)
3672 Copy(s, &aquad, 1, quad);
3676 sv_setnv(sv, (double)aquad);
3677 PUSHs(sv_2mortal(sv));
3683 if (s + sizeof(unsigned quad) > strend)
3686 Copy(s, &auquad, 1, unsigned quad);
3687 s += sizeof(unsigned quad);
3690 sv_setnv(sv, (double)auquad);
3691 PUSHs(sv_2mortal(sv));
3695 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3698 along = (strend - s) / sizeof(float);
3703 Copy(s, &afloat, 1, float);
3711 Copy(s, &afloat, 1, float);
3714 sv_setnv(sv, (double)afloat);
3715 PUSHs(sv_2mortal(sv));
3721 along = (strend - s) / sizeof(double);
3726 Copy(s, &adouble, 1, double);
3727 s += sizeof(double);
3734 Copy(s, &adouble, 1, double);
3735 s += sizeof(double);
3737 sv_setnv(sv, (double)adouble);
3738 PUSHs(sv_2mortal(sv));
3743 along = (strend - s) * 3 / 4;
3744 sv = NEWSV(42, along);
3745 while (s < strend && *s > ' ' && *s < 'a') {
3750 len = (*s++ - ' ') & 077;
3752 if (s < strend && *s >= ' ')
3753 a = (*s++ - ' ') & 077;
3756 if (s < strend && *s >= ' ')
3757 b = (*s++ - ' ') & 077;
3760 if (s < strend && *s >= ' ')
3761 c = (*s++ - ' ') & 077;
3764 if (s < strend && *s >= ' ')
3765 d = (*s++ - ' ') & 077;
3768 hunk[0] = a << 2 | b >> 4;
3769 hunk[1] = b << 4 | c >> 2;
3770 hunk[2] = c << 6 | d;
3771 sv_catpvn(sv, hunk, len > 3 ? 3 : len);
3776 else if (s[1] == '\n') /* possible checksum byte */
3779 XPUSHs(sv_2mortal(sv));
3784 if (strchr("fFdD", datumtype) ||
3785 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3790 while (checksum >= 16) {
3794 while (checksum >= 4) {
3800 along = (1 << checksum) - 1;
3801 while (cdouble < 0.0)
3803 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3804 sv_setnv(sv, cdouble);
3807 if (checksum < 32) {
3808 along = (1 << checksum) - 1;
3809 culong &= (U32)along;
3811 sv_setnv(sv, (double)culong);
3813 XPUSHs(sv_2mortal(sv));
3821 doencodes(sv, s, len)
3829 sv_catpvn(sv, hunk, 1);
3832 hunk[0] = ' ' + (077 & (*s >> 2));
3833 hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
3834 hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
3835 hunk[3] = ' ' + (077 & (s[2] & 077));
3836 sv_catpvn(sv, hunk, 4);
3840 for (s = SvPVX(sv); *s; s++) {
3844 sv_catpvn(sv, "\n", 1);
3849 dSP; dMARK; dORIGMARK; dTARGET;
3850 register SV *cat = TARG;
3853 register char *pat = SvPVx(*++MARK, fromlen);
3854 register char *patend = pat + fromlen;
3859 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3860 static char *space10 = " ";
3862 /* These must not be in registers: */
3871 unsigned quad auquad;
3879 sv_setpvn(cat, "", 0);
3880 while (pat < patend) {
3881 #define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
3884 len = strchr("@Xxu", datumtype) ? 0 : items;
3887 else if (isDIGIT(*pat)) {
3889 while (isDIGIT(*pat))
3890 len = (len * 10) + (*pat++ - '0');
3898 DIE("% may only be used in unpack");
3909 if (SvCUR(cat) < len)
3910 DIE("X outside of string");
3917 sv_catpvn(cat, null10, 10);
3920 sv_catpvn(cat, null10, len);
3925 aptr = SvPV(fromstr, fromlen);
3929 sv_catpvn(cat, aptr, len);
3931 sv_catpvn(cat, aptr, fromlen);
3933 if (datumtype == 'A') {
3935 sv_catpvn(cat, space10, 10);
3938 sv_catpvn(cat, space10, len);
3942 sv_catpvn(cat, null10, 10);
3945 sv_catpvn(cat, null10, len);
3952 char *savepat = pat;
3957 aptr = SvPV(fromstr, fromlen);
3962 SvCUR(cat) += (len+7)/8;
3963 SvGROW(cat, SvCUR(cat) + 1);
3964 aptr = SvPVX(cat) + aint;
3969 if (datumtype == 'B') {
3970 for (len = 0; len++ < aint;) {
3971 items |= *pat++ & 1;
3975 *aptr++ = items & 0xff;
3981 for (len = 0; len++ < aint;) {
3987 *aptr++ = items & 0xff;
3993 if (datumtype == 'B')
3994 items <<= 7 - (aint & 7);
3996 items >>= 7 - (aint & 7);
3997 *aptr++ = items & 0xff;
3999 pat = SvPVX(cat) + SvCUR(cat);
4010 char *savepat = pat;
4015 aptr = SvPV(fromstr, fromlen);
4020 SvCUR(cat) += (len+1)/2;
4021 SvGROW(cat, SvCUR(cat) + 1);
4022 aptr = SvPVX(cat) + aint;
4027 if (datumtype == 'H') {
4028 for (len = 0; len++ < aint;) {
4030 items |= ((*pat++ & 15) + 9) & 15;
4032 items |= *pat++ & 15;
4036 *aptr++ = items & 0xff;
4042 for (len = 0; len++ < aint;) {
4044 items |= (((*pat++ & 15) + 9) & 15) << 4;
4046 items |= (*pat++ & 15) << 4;
4050 *aptr++ = items & 0xff;
4056 *aptr++ = items & 0xff;
4057 pat = SvPVX(cat) + SvCUR(cat);
4069 aint = SvIV(fromstr);
4071 sv_catpvn(cat, &achar, sizeof(char));
4074 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4079 afloat = (float)SvNV(fromstr);
4080 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4087 adouble = (double)SvNV(fromstr);
4088 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4094 ashort = (I16)SvIV(fromstr);
4096 ashort = htons(ashort);
4098 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
4104 ashort = (I16)SvIV(fromstr);
4106 ashort = htovs(ashort);
4108 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
4115 ashort = (I16)SvIV(fromstr);
4116 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
4122 auint = U_I(SvNV(fromstr));
4123 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4129 aint = SvIV(fromstr);
4130 sv_catpvn(cat, (char*)&aint, sizeof(int));
4136 aulong = U_L(SvNV(fromstr));
4138 aulong = htonl(aulong);
4140 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
4146 aulong = U_L(SvNV(fromstr));
4148 aulong = htovl(aulong);
4150 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
4156 aulong = U_L(SvNV(fromstr));
4157 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
4163 along = SvIV(fromstr);
4164 sv_catpvn(cat, (char*)&along, sizeof(I32));
4171 auquad = (unsigned quad)SvNV(fromstr);
4172 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned quad));
4178 aquad = (quad)SvNV(fromstr);
4179 sv_catpvn(cat, (char*)&aquad, sizeof(quad));
4184 len = 1; /* assume SV is correct length */
4189 aptr = SvPV(fromstr, na);
4190 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4195 aptr = SvPV(fromstr, fromlen);
4196 SvGROW(cat, fromlen * 4 / 3);
4201 while (fromlen > 0) {
4208 doencodes(cat, aptr, todo);
4226 register I32 limit = POPi; /* note, negative is forever */
4229 register char *s = SvPV(sv, len);
4230 char *strend = s + len;
4231 register PMOP *pm = (PMOP*)POPs;
4235 I32 maxiters = (strend - s) + 10;
4238 I32 origlimit = limit;
4242 register REGEXP *rx = pm->op_pmregexp;
4246 DIE("panic: do_split");
4247 if (pm->op_pmreplroot)
4248 ary = GvAVn((GV*)pm->op_pmreplroot);
4251 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4255 for (i = AvFILL(ary); i >= 0; i--)
4256 AvARRAY(ary)[i] = Nullsv; /* don't free mere refs */
4258 av_fill(ary,0); /* force allocation */
4260 /* temporarily switch stacks */
4262 SWITCHSTACK(stack, ary);
4264 base = SP - stack_base + 1;
4266 if (pm->op_pmflags & PMf_SKIPWHITE) {
4271 limit = maxiters + 2;
4272 if (strEQ("\\s+", rx->precomp)) {
4275 for (m = s; m < strend && !isSPACE(*m); m++) ;
4278 dstr = NEWSV(30, m-s);
4279 sv_setpvn(dstr, s, m-s);
4284 for (s = m + 1; s < strend && isSPACE(*s); s++) ;
4287 else if (strEQ("^", rx->precomp)) {
4290 for (m = s; m < strend && *m != '\n'; m++) ;
4294 dstr = NEWSV(30, m-s);
4295 sv_setpvn(dstr, s, m-s);
4302 else if (pm->op_pmshort) {
4303 i = SvCUR(pm->op_pmshort);
4305 I32 fold = (pm->op_pmflags & PMf_FOLD);
4306 i = *SvPVX(pm->op_pmshort);
4307 if (fold && isUPPER(i))
4312 m < strend && *m != i &&
4313 (!isUPPER(*m) || tolower(*m) != i);
4314 m++) /*SUPPRESS 530*/
4317 else /*SUPPRESS 530*/
4318 for (m = s; m < strend && *m != i; m++) ;
4321 dstr = NEWSV(30, m-s);
4322 sv_setpvn(dstr, s, m-s);
4331 while (s < strend && --limit &&
4332 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4336 dstr = NEWSV(31, m-s);
4337 sv_setpvn(dstr, s, m-s);
4346 maxiters += (strend - s) * rx->nparens;
4347 while (s < strend && --limit &&
4348 regexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) {
4350 && rx->subbase != orig) {
4355 strend = s + (strend - m);
4358 dstr = NEWSV(32, m-s);
4359 sv_setpvn(dstr, s, m-s);
4364 for (i = 1; i <= rx->nparens; i++) {
4367 dstr = NEWSV(33, m-s);
4368 sv_setpvn(dstr, s, m-s);
4377 iters = (SP - stack_base) - base;
4378 if (iters > maxiters)
4380 if (s < strend || origlimit) { /* keep field after final delim? */
4381 dstr = NEWSV(34, strend-s);
4382 sv_setpvn(dstr, s, strend-s);
4389 while (iters > 0 && SvCUR(TOPs) == 0)
4393 SWITCHSTACK(ary, oldstack);
4394 if (gimme == G_ARRAY) {
4396 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4402 if (gimme == G_ARRAY)
4405 SP = stack_base + base;
4413 dSP; dMARK; dTARGET;
4415 do_join(TARG, *MARK, MARK, SP);
4421 /* List operators. */
4426 if (GIMME != G_ARRAY) {
4429 *MARK = *SP; /* unwanted list, return last item */
4440 SV **lastrelem = stack_sp;
4441 SV **lastlelem = stack_base + POPMARK;
4442 SV **firstlelem = stack_base + POPMARK + 1;
4443 register SV **firstrelem = lastlelem + 1;
4444 I32 lval = op->op_flags & OPf_LVAL;
4445 I32 is_something_there = lval;
4447 register I32 max = lastrelem - lastlelem;
4448 register SV **lelem;
4451 if (GIMME != G_ARRAY) {
4452 ix = SvIVx(*lastlelem) - arybase;
4453 if (ix < 0 || ix >= max)
4454 *firstlelem = &sv_undef;
4456 *firstlelem = firstrelem[ix];
4462 SP = firstlelem - 1;
4466 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4467 ix = SvIVx(*lelem) - arybase;
4468 if (ix < 0 || ix >= max || !(*lelem = firstrelem[ix]))
4470 if (!is_something_there && SvOK(*lelem))
4471 is_something_there = TRUE;
4473 if (is_something_there)
4476 SP = firstlelem - 1;
4483 I32 items = SP - MARK;
4485 XPUSHs((SV*)av_make(items, MARK+1));
4491 dSP; dMARK; dORIGMARK;
4497 SV *val = NEWSV(46, 0);
4499 sv_setsv(val, *++MARK);
4501 (void)hv_store(hv,tmps,SvCUROK(key),val,0);
4510 dSP; dMARK; dORIGMARK;
4511 register AV *ary = (AV*)*++MARK;
4515 register I32 offset;
4516 register I32 length;
4525 offset = SvIVx(*MARK);
4527 offset += AvFILL(ary) + 1;
4531 length = SvIVx(*MARK++);
4536 length = AvMAX(ary) + 1; /* close enough to infinity */
4540 length = AvMAX(ary) + 1;
4548 if (offset > AvFILL(ary) + 1)
4549 offset = AvFILL(ary) + 1;
4550 after = AvFILL(ary) + 1 - (offset + length);
4551 if (after < 0) { /* not that much array */
4552 length += after; /* offset+length now in array */
4554 if (!AvALLOC(ary)) {
4560 /* At this point, MARK .. SP-1 is our new LIST */
4563 diff = newlen - length;
4565 if (diff < 0) { /* shrinking the area */
4567 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4568 Copy(MARK, tmparyval, newlen, SV*);
4571 MARK = ORIGMARK + 1;
4572 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4573 MEXTEND(MARK, length);
4574 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4576 for (i = length, dst = MARK; i; i--)
4577 sv_2mortal(*dst++); /* free them eventualy */
4582 *MARK = AvARRAY(ary)[offset+length-1];
4585 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4586 sv_free(*dst++); /* free them now */
4589 AvFILL(ary) += diff;
4591 /* pull up or down? */
4593 if (offset < after) { /* easier to pull up */
4594 if (offset) { /* esp. if nothing to pull */
4595 src = &AvARRAY(ary)[offset-1];
4596 dst = src - diff; /* diff is negative */
4597 for (i = offset; i > 0; i--) /* can't trust Copy */
4600 Zero(AvARRAY(ary), -diff, SV*);
4601 AvARRAY(ary) -= diff; /* diff is negative */
4605 if (after) { /* anything to pull down? */
4606 src = AvARRAY(ary) + offset + length;
4607 dst = src + diff; /* diff is negative */
4608 Move(src, dst, after, SV*);
4610 Zero(&AvARRAY(ary)[AvFILL(ary)+1], -diff, SV*);
4611 /* avoid later double free */
4614 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4616 *dst = NEWSV(46, 0);
4617 sv_setsv(*dst++, *src++);
4619 Safefree(tmparyval);
4622 else { /* no, expanding (or same) */
4624 New(452, tmparyval, length, SV*); /* so remember deletion */
4625 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4628 if (diff > 0) { /* expanding */
4630 /* push up or down? */
4632 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4636 Move(src, dst, offset, SV*);
4638 AvARRAY(ary) -= diff; /* diff is positive */
4640 AvFILL(ary) += diff;
4643 if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */
4644 av_store(ary, AvFILL(ary) + diff, Nullsv);
4646 AvFILL(ary) += diff;
4647 dst = AvARRAY(ary) + AvFILL(ary);
4648 for (i = diff; i > 0; i--) {
4649 if (*dst) /* stuff was hanging around */
4650 sv_free(*dst); /* after $#foo */
4654 dst = AvARRAY(ary) + AvFILL(ary);
4656 for (i = after; i; i--) {
4663 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4664 *dst = NEWSV(46, 0);
4665 sv_setsv(*dst++, *src++);
4667 MARK = ORIGMARK + 1;
4668 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4670 Copy(tmparyval, MARK, length, SV*);
4672 for (i = length, dst = MARK; i; i--)
4673 sv_2mortal(*dst++); /* free them eventualy */
4675 Safefree(tmparyval);
4679 else if (length--) {
4680 *MARK = tmparyval[length];
4683 while (length-- > 0)
4684 sv_free(tmparyval[length]);
4686 Safefree(tmparyval);
4697 dSP; dMARK; dORIGMARK; dTARGET;
4698 register AV *ary = (AV*)*++MARK;
4699 register SV *sv = &sv_undef;
4701 for (++MARK; MARK <= SP; MARK++) {
4704 sv_setsv(sv, *MARK);
4705 (void)av_push(ary, sv);
4708 PUSHi( AvFILL(ary) + 1 );
4716 SV *sv = av_pop(av);
4720 (void)sv_2mortal(sv);
4729 SV *sv = av_shift(av);
4734 (void)sv_2mortal(sv);
4741 dSP; dMARK; dORIGMARK; dTARGET;
4742 register AV *ary = (AV*)*++MARK;
4746 av_unshift(ary, SP - MARK);
4749 sv_setsv(sv, *++MARK);
4750 (void)av_store(ary, i++, sv);
4754 PUSHi( AvFILL(ary) + 1 );
4763 if (stack_base + *markstack_ptr == sp) {
4765 RETURNOP(op->op_next->op_next);
4767 stack_sp = stack_base + *markstack_ptr + 1;
4768 pp_pushmark(); /* push dst */
4769 pp_pushmark(); /* push src */
4770 ENTER; /* enter outer scope */
4773 SAVESPTR(GvSV(defgv));
4775 ENTER; /* enter inner scope */
4778 if (src = stack_base[*markstack_ptr]) {
4783 GvSV(defgv) = sv_mortalcopy(&sv_undef);
4785 RETURNOP(((LOGOP*)op->op_next)->op_other);
4793 stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr];
4795 LEAVE; /* exit inner scope */
4798 if (stack_base + *markstack_ptr > sp) {
4801 LEAVE; /* exit outer scope */
4802 POPMARK; /* pop src */
4803 items = --*markstack_ptr - markstack_ptr[-1];
4804 POPMARK; /* pop dst */
4805 SP = stack_base + POPMARK; /* pop original mark */
4806 if (GIMME != G_ARRAY) {
4817 ENTER; /* enter inner scope */
4820 if (src = stack_base[*markstack_ptr]) {
4825 GvSV(defgv) = sv_mortalcopy(&sv_undef);
4827 RETURNOP(cLOGOP->op_other);
4831 static int sortcmp();
4832 static int sortcv();
4836 dSP; dMARK; dORIGMARK;
4838 SV **myorigmark = ORIGMARK;
4846 if (GIMME != G_ARRAY) {
4851 if (op->op_flags & OPf_STACKED) {
4852 if (op->op_flags & OPf_SPECIAL) {
4853 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
4854 kid = kUNOP->op_first; /* pass rv2gv */
4855 kid = kUNOP->op_first; /* pass leave */
4856 sortcop = kid->op_next;
4857 stash = curcop->cop_stash;
4860 cv = sv_2cv(*++MARK, &stash, &gv, 0);
4861 if (!(cv && CvROOT(cv))) {
4863 SV *tmpstr = sv_mortalcopy(&sv_undef);
4864 gv_efullname(tmpstr, gv);
4866 DIE("Usersub \"%s\" called in sort", SvPVX(tmpstr));
4867 DIE("Undefined sort subroutine \"%s\" called",
4872 DIE("Usersub called in sort");
4873 DIE("Undefined subroutine in sort");
4875 DIE("Not a subroutine reference in sort");
4877 sortcop = CvSTART(cv);
4878 SAVESPTR(CvROOT(cv)->op_ppaddr);
4879 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
4884 stash = curcop->cop_stash;
4887 up = myorigmark + 1;
4888 while (MARK < SP) { /* This may or may not shift down one here. */
4890 if (*up = *++MARK) { /* Weed out nulls. */
4892 (void)sv_2pv(*up, &na);
4898 max = --up - myorigmark;
4909 sortstack = newAV();
4910 av_store(sortstack, 32, Nullsv);
4911 av_clear(sortstack);
4912 AvREAL_off(sortstack);
4914 SWITCHSTACK(stack, sortstack);
4915 if (sortstash != stash) {
4916 firstgv = gv_fetchpv("a", TRUE);
4917 secondgv = gv_fetchpv("b", TRUE);
4921 SAVESPTR(GvSV(firstgv));
4922 SAVESPTR(GvSV(secondgv));
4924 qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv);
4926 SWITCHSTACK(sortstack, oldstack);
4931 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
4932 qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp);
4935 SP = ORIGMARK + max;
4945 if (GIMME == G_ARRAY) {
4956 register char *down;
4962 do_join(TARG, &sv_no, MARK, SP);
4964 sv_setsv(TARG, *SP);
4965 up = SvPV(TARG, len);
4967 down = SvPVX(TARG) + len - 1;
4985 if (GIMME == G_ARRAY)
4986 return cCONDOP->op_true;
4987 return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
4994 if (GIMME == G_ARRAY) {
4995 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
4999 SV *targ = PAD_SV(op->op_targ);
5001 if ((op->op_private & OPpFLIP_LINENUM)
5002 ? last_in_gv && SvIV(sv) == GvIO(last_in_gv)->lines
5004 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
5005 if (op->op_flags & OPf_SPECIAL) {
5012 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
5025 if (GIMME == G_ARRAY) {
5031 if (SvNIOK(lstr) || !SvPOK(lstr) ||
5032 (looks_like_number(lstr) && *SvPVX(lstr) != '0') ) {
5036 EXTEND(SP, max - i + 1);
5038 sv = sv_mortalcopy(&sv_no);
5044 SV *final = sv_mortalcopy(rstr);
5046 char *tmps = SvPV(final, len);
5048 sv = sv_mortalcopy(lstr);
5049 while (!SvNIOK(sv) && SvCUR(sv) <= len &&
5050 strNE(SvPVX(sv),tmps) ) {
5052 sv = sv_2mortal(newSVsv(sv));
5055 if (strEQ(SvPVX(sv),tmps))
5061 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
5063 if ((op->op_private & OPpFLIP_LINENUM)
5064 ? last_in_gv && SvIV(sv) == GvIO(last_in_gv)->lines
5066 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
5067 sv_catpv(targ, "E0");
5082 register CONTEXT *cx;
5084 for (i = cxstack_ix; i >= 0; i--) {
5086 switch (cx->cx_type) {
5089 warn("Exiting substitution via %s", op_name[op->op_type]);
5093 warn("Exiting subroutine via %s", op_name[op->op_type]);
5097 warn("Exiting eval via %s", op_name[op->op_type]);
5100 if (!cx->blk_loop.label ||
5101 strNE(label, cx->blk_loop.label) ) {
5102 DEBUG_l(deb("(Skipping label #%d %s)\n",
5103 i, cx->blk_loop.label));
5106 DEBUG_l( deb("(Found label #%d %s)\n", i, label));
5113 dopoptosub(startingblock)
5117 register CONTEXT *cx;
5118 for (i = startingblock; i >= 0; i--) {
5120 switch (cx->cx_type) {
5125 DEBUG_l( deb("(Found sub #%d)\n", i));
5133 dopoptoeval(startingblock)
5137 register CONTEXT *cx;
5138 for (i = startingblock; i >= 0; i--) {
5140 switch (cx->cx_type) {
5144 DEBUG_l( deb("(Found eval #%d)\n", i));
5152 dopoptoloop(startingblock)
5156 register CONTEXT *cx;
5157 for (i = startingblock; i >= 0; i--) {
5159 switch (cx->cx_type) {
5162 warn("Exiting substitition via %s", op_name[op->op_type]);
5166 warn("Exiting subroutine via %s", op_name[op->op_type]);
5170 warn("Exiting eval via %s", op_name[op->op_type]);
5173 DEBUG_l( deb("(Found loop #%d)\n", i));
5184 register CONTEXT *cx;
5188 while (cxstack_ix > cxix) {
5189 cx = &cxstack[cxstack_ix--];
5190 DEBUG_l(fprintf(stderr, "Unwinding block %d, type %d\n", cxstack_ix+1,
5192 /* Note: we don't need to restore the base context info till the end. */
5193 switch (cx->cx_type) {
5224 message = mess(args);
5226 restartop = die_where(message);
5227 if (stack != mainstack)
5228 longjmp(top_env, 3);
5238 register CONTEXT *cx;
5242 sv_setpv(GvSV(gv_fetchpv("@",TRUE)),message);
5243 cxix = dopoptoeval(cxstack_ix);
5247 if (cxix < cxstack_ix)
5251 if (cx->cx_type != CXt_EVAL) {
5252 fprintf(stderr, "panic: die %s", message);
5257 if (gimme == G_SCALAR)
5258 *++newsp = &sv_undef;
5262 if (optype == OP_REQUIRE)
5263 DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE)), na));
5264 return pop_return();
5267 fputs(message, stderr);
5268 (void)fflush(stderr);
5270 (void)UNLINK(e_tmpname);
5272 my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
5283 RETURNOP(cLOGOP->op_other);
5294 RETURNOP(cLOGOP->op_other);
5302 RETURNOP(cCONDOP->op_true);
5304 RETURNOP(cCONDOP->op_false);
5313 RETURNOP(cLOGOP->op_other);
5322 RETURNOP(cLOGOP->op_other);
5334 if (SvTYPE(sv) != SVt_REF) {
5339 !(iogv = gv_fetchpv(SvPVX(sv), FALSE)) ||
5342 char *name = SvPVX(((SVOP*)cLOGOP->op_other)->op_sv);
5344 char* packname = SvPVX(sv);
5346 if (!isALPHA(*packname))
5347 DIE("Can't call method \"%s\" without a package or object reference", name);
5348 if (!(stash = fetch_stash(sv, FALSE)))
5349 DIE("Can't call method \"%s\" in empty package \"%s\"",
5351 gv = gv_fetchmethod(stash,name);
5353 DIE("Can't locate object method \"%s\" via package \"%s\"",
5359 if (!(ob = io->object)) {
5360 ob = sv_ref((SV*)newHV());
5361 SvSTORAGE(ob) = 'O';
5362 SvUPGRADE(ob, SVt_PVMG);
5363 iogv = gv_fetchpv("FILEHANDLE'flush", TRUE);
5364 SvSTASH(ob) = GvSTASH(iogv);
5370 ob = (SV*)SvANY(sv);
5373 if (!ob || SvSTORAGE(ob) != 'O') {
5374 char *name = SvPVX(((SVOP*)cLOGOP->op_other)->op_sv);
5375 DIE("Can't call method \"%s\" on unblessed reference", name);
5378 if (!gv) { /* nothing cached */
5379 char *name = SvPVX(((SVOP*)cLOGOP->op_other)->op_sv);
5380 gv = gv_fetchmethod(SvSTASH(ob),name);
5382 DIE("Can't locate object method \"%s\" via package \"%s\"",
5383 name, HvNAME(SvSTASH(ob)));
5397 register CV *cv = sv_2cv(*++MARK, &stash, &gv, 0);
5398 register I32 items = SP - MARK;
5399 I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
5400 register CONTEXT *cx;
5405 if (!(cv && (CvROOT(cv) || CvUSERSUB(cv)))) {
5407 SV *tmpstr = sv_mortalcopy(&sv_undef);
5408 gv_efullname(tmpstr, gv);
5409 DIE("Undefined subroutine \"%s\" called",SvPVX(tmpstr));
5412 DIE("Undefined subroutine called");
5413 DIE("Not a subroutine reference");
5415 if ((op->op_private & OPpSUBR_DB) && !CvUSERSUB(cv)) {
5418 gv_efullname(sv,gv);
5421 DIE("No DBsub routine");
5424 if (CvUSERSUB(cv)) {
5425 items = (*CvUSERSUB(cv))(CvUSERINDEX(cv), MARK - stack_base, items);
5426 sp = stack_base + items;
5432 AV* padlist = CvPADLIST(cv);
5433 SV** svp = AvARRAY(padlist);
5434 push_return(op->op_next);
5435 PUSHBLOCK(cx, CXt_SUB, MARK - 1);
5438 cx->blk_sub.savearray = GvAV(defgv);
5439 cx->blk_sub.argarray = av_fake(items, ++MARK);
5440 GvAV(defgv) = cx->blk_sub.argarray;
5443 if (CvDEPTH(cv) >= 2) { /* save temporaries on recursion? */
5444 if (CvDEPTH(cv) == 100 && dowarn)
5445 warn("Deep recursion on subroutine \"%s\"",GvENAME(gv));
5446 if (CvDEPTH(cv) > AvFILL(padlist)) {
5447 AV *newpad = newAV();
5448 I32 ix = AvFILL((AV*)svp[1]);
5449 svp = AvARRAY(svp[0]);
5452 char *name = SvPVX(svp[ix]); /* XXX */
5454 av_store(newpad, ix--, (SV*)newAV());
5455 else if (*name == '%')
5456 av_store(newpad, ix--, (SV*)newHV());
5458 av_store(newpad, ix--, NEWSV(0,0));
5461 av_store(newpad, ix--, NEWSV(0,0));
5463 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
5464 AvFILL(padlist) = CvDEPTH(cv);
5465 svp = AvARRAY(padlist);
5469 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
5470 RETURNOP(CvSTART(cv));
5480 register CONTEXT *cx;
5485 if (gimme == G_SCALAR) {
5488 *MARK = sv_mortalcopy(TOPs);
5496 for (mark = newsp + 1; mark <= SP; mark++)
5497 *mark = sv_mortalcopy(*mark);
5498 /* in case LEAVE wipes old return values */
5503 return pop_return();
5508 return pop_return();
5514 register I32 cxix = dopoptosub(cxstack_ix);
5516 register CONTEXT *cx;
5525 if (GIMME != G_ARRAY)
5529 nextcxix = dopoptosub(cxix - 1);
5530 if (DBsub && nextcxix >= 0 &&
5531 cxstack[nextcxix].blk_sub.cv == GvCV(DBsub))
5537 cx = &cxstack[cxix];
5538 if (cx->blk_oldcop == &compiling) {
5539 if (GIMME != G_ARRAY)
5543 if (GIMME != G_ARRAY) {
5546 sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash));
5551 PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0)));
5552 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
5553 PUSHs(sv_2mortal(newSVnv((double)cx->blk_oldcop->cop_line)));
5557 gv_efullname(sv, cx->blk_sub.gv);
5558 PUSHs(sv_2mortal(sv));
5559 PUSHs(sv_2mortal(newSVnv((double)cx->blk_sub.hasargs)));
5560 PUSHs(sv_2mortal(newSVnv((double)cx->blk_gimme)));
5561 if (cx->blk_sub.hasargs) {
5562 AV *ary = cx->blk_sub.argarray;
5565 dbargs = GvAV(gv_AVadd(gv_fetchpv("DB'args", TRUE)));
5566 if (AvMAX(dbargs) < AvFILL(ary))
5567 av_store(dbargs, AvFILL(ary), Nullsv);
5568 Copy(AvARRAY(ary), AvARRAY(dbargs), AvFILL(ary)+1, SV*);
5569 AvFILL(dbargs) = AvFILL(ary);
5579 I32 oldscopeix = scopestack_ix;
5581 GvSV(firstgv) = *str1;
5582 GvSV(secondgv) = *str2;
5583 stack_sp = stack_base;
5586 result = SvIVx(AvARRAY(stack)[1]);
5587 while (scopestack_ix > oldscopeix) {
5594 sortcmp(strp1, strp2)
5598 register SV *str1 = *strp1;
5599 register SV *str2 = *strp2;
5602 if (SvCUR(str1) < SvCUR(str2)) {
5604 if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1)))
5610 else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2)))
5612 else if (SvCUR(str1) == SvCUR(str2))
5622 if (SP - MARK != 1) {
5624 do_join(TARG, &sv_no, MARK, SP);
5625 tmps = SvPV(TARG, na);
5629 tmps = SvPV(TOPs, na);
5631 if (!tmps || !*tmps) {
5632 SV *error = GvSV(gv_fetchpv("@", TRUE));
5633 SvUPGRADE(error, SVt_PV);
5634 if (SvPOK(error) && SvCUR(error))
5635 sv_catpv(error, "\t...caught");
5636 tmps = SvPV(error, na);
5638 if (!tmps || !*tmps)
5639 tmps = "Warning: something's wrong";
5648 if (SP - MARK != 1) {
5650 do_join(TARG, &sv_no, MARK, SP);
5651 tmps = SvPV(TARG, na);
5655 tmps = SvPV(TOPs, na);
5657 if (!tmps || !*tmps) {
5658 SV *error = GvSV(gv_fetchpv("@", TRUE));
5659 SvUPGRADE(error, SVt_PV);
5660 if (SvPOK(error) && SvCUR(error))
5661 sv_catpv(error, "\t...propagated");
5662 tmps = SvPV(error, na);
5664 if (!tmps || !*tmps)
5679 sv_reset(tmps, curcop->cop_stash);
5692 TAINT_NOT; /* Each statement is presumed innocent */
5693 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
5701 TAINT_NOT; /* Each statement is presumed innocent */
5702 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
5705 if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
5709 register CONTEXT *cx;
5724 DIE("No DB'DB routine defined");
5726 push_return(op->op_next);
5727 PUSHBLOCK(cx, CXt_SUB, sp - 1);
5730 if (CvDEPTH(cv) >= 2)
5731 DIE("DB'DB called recursively");
5733 curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
5734 RETURNOP(CvSTART(cv));
5743 TAINT_NOT; /* Each statement is presumed innocent */
5744 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
5746 oldsave = scopestack[scopestack_ix - 1];
5747 if (savestack_ix > oldsave)
5748 leave_scope(oldsave);
5755 register CONTEXT *cx;
5760 PUSHBLOCK(cx,CXt_BLOCK,sp);
5768 register CONTEXT *cx;
5786 register CONTEXT *cx;
5787 SV **svp = &GvSV((GV*)POPs);
5794 PUSHBLOCK(cx,CXt_LOOP,SP);
5795 PUSHLOOP(cx, svp, MARK);
5796 cx->blk_loop.iterary = stack;
5797 cx->blk_loop.iterix = MARK - stack_base;
5805 register CONTEXT *cx;
5809 cx = &cxstack[cxstack_ix];
5810 if (cx->cx_type != CXt_LOOP)
5811 DIE("panic: pp_iter");
5813 if (cx->blk_loop.iterix >= cx->blk_oldsp)
5816 sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix];
5817 *cx->blk_loop.itervar = sv ? sv : &sv_undef;
5825 register CONTEXT *cx;
5832 PUSHBLOCK(cx, CXt_LOOP, SP);
5833 PUSHLOOP(cx, 0, SP);
5841 register CONTEXT *cx;
5849 if (gimme == G_SCALAR) {
5851 *++newsp = sv_mortalcopy(*SP);
5853 *++newsp = &sv_undef;
5857 *++newsp = sv_mortalcopy(*++mark);
5870 register CONTEXT *cx;
5875 if (stack == sortstack) {
5876 AvARRAY(stack)[1] = *SP;
5880 cxix = dopoptosub(cxstack_ix);
5882 DIE("Can't return outside a subroutine");
5883 if (cxix < cxstack_ix)
5887 switch (cx->cx_type) {
5895 DIE("panic: return");
5899 if (gimme == G_SCALAR) {
5901 *++newsp = sv_mortalcopy(*SP);
5903 *++newsp = &sv_undef;
5904 if (optype == OP_REQUIRE && !SvTRUE(*newsp))
5905 DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE)), na));
5908 if (optype == OP_REQUIRE && MARK == SP)
5909 DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE)), na));
5911 *++newsp = sv_mortalcopy(*++MARK);
5916 return pop_return();
5923 register CONTEXT *cx;
5928 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
5929 /* XXX The sp is probably not right yet... */
5931 if (op->op_flags & OPf_SPECIAL) {
5932 cxix = dopoptoloop(cxstack_ix);
5934 DIE("Can't \"last\" outside a block");
5937 cxix = dopoptolabel(cPVOP->op_pv);
5939 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
5941 if (cxix < cxstack_ix)
5945 switch (cx->cx_type) {
5948 nextop = cx->blk_loop.last_op->op_next;
5953 nextop = pop_return();
5957 nextop = pop_return();
5964 if (gimme == G_SCALAR) {
5966 *++newsp = sv_mortalcopy(*SP);
5968 *++newsp = &sv_undef;
5972 *++newsp = sv_mortalcopy(*++mark);
5984 register CONTEXT *cx;
5987 if (op->op_flags & OPf_SPECIAL) {
5988 cxix = dopoptoloop(cxstack_ix);
5990 DIE("Can't \"next\" outside a block");
5993 cxix = dopoptolabel(cPVOP->op_pv);
5995 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
5997 if (cxix < cxstack_ix)
6001 oldsave = scopestack[scopestack_ix - 1];
6002 if (savestack_ix > oldsave)
6003 leave_scope(oldsave);
6004 return cx->blk_loop.next_op;
6011 register CONTEXT *cx;
6014 if (op->op_flags & OPf_SPECIAL) {
6015 cxix = dopoptoloop(cxstack_ix);
6017 DIE("Can't \"redo\" outside a block");
6020 cxix = dopoptolabel(cPVOP->op_pv);
6022 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
6024 if (cxix < cxstack_ix)
6028 oldsave = scopestack[scopestack_ix - 1];
6029 if (savestack_ix > oldsave)
6030 leave_scope(oldsave);
6031 return cx->blk_loop.redo_op;
6034 static OP* lastgotoprobe;
6037 dofindlabel(op,label,opstack)
6045 if (op->op_type == OP_LEAVE ||
6046 op->op_type == OP_SCOPE ||
6047 op->op_type == OP_LEAVELOOP ||
6048 op->op_type == OP_LEAVETRY)
6049 *ops++ = cUNOP->op_first;
6051 if (op->op_flags & OPf_KIDS) {
6052 /* First try all the kids at this level, since that's likeliest. */
6053 for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
6054 if (kid->op_type == OP_NEXTSTATE && kCOP->cop_label &&
6055 strEQ(kCOP->cop_label, label))
6058 for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
6059 if (kid == lastgotoprobe)
6061 if (kid->op_type == OP_NEXTSTATE) {
6062 if (ops > opstack && ops[-1]->op_type == OP_NEXTSTATE)
6067 if (op = dofindlabel(kid,label,ops))
6077 return pp_goto(ARGS);
6086 register CONTEXT *cx;
6092 if (op->op_flags & OPf_SPECIAL) {
6093 if (op->op_type != OP_DUMP)
6094 DIE("goto must have label");
6097 label = cPVOP->op_pv;
6099 if (label && *label) {
6106 for (ix = cxstack_ix; ix >= 0; ix--) {
6108 switch (cx->cx_type) {
6110 gotoprobe = CvROOT(cx->blk_sub.cv);
6113 gotoprobe = eval_root; /* XXX not good for nested eval */
6116 gotoprobe = cx->blk_oldcop->op_sibling;
6122 gotoprobe = cx->blk_oldcop->op_sibling;
6124 gotoprobe = main_root;
6130 gotoprobe = main_root;
6133 retop = dofindlabel(gotoprobe, label, enterops);
6136 lastgotoprobe = gotoprobe;
6139 DIE("Can't find label %s", label);
6141 /* pop unwanted frames */
6143 if (ix < cxstack_ix) {
6150 oldsave = scopestack[scopestack_ix - 1];
6151 if (savestack_ix > oldsave)
6152 leave_scope(oldsave);
6155 /* push wanted frames */
6159 for (ix = 0 + (gotoprobe == main_root); enterops[ix]; ix++) {
6167 if (op->op_type == OP_DUMP) {
6173 restartop = 0; /* hmm, must be GNU unexec().. */
6197 double value = SvNVx(GvSV(cCOP->cop_gv));
6198 register I32 match = (I32)value;
6201 if (((double)match) > value)
6202 --match; /* was fractional--truncate other way */
6204 match -= cCOP->uop.scop.scop_offset;
6207 else if (match > cCOP->uop.scop.scop_max)
6208 match = cCOP->uop.scop.scop_max;
6209 op = cCOP->uop.scop.scop_next[match];
6219 op = op->op_next; /* can't assume anything */
6221 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
6222 match -= cCOP->uop.scop.scop_offset;
6225 else if (match > cCOP->uop.scop.scop_max)
6226 match = cCOP->uop.scop.scop_max;
6227 op = cCOP->uop.scop.scop_next[match];
6247 tmps = SvPV(sv, len);
6248 if (do_open(gv, tmps, len)) {
6249 GvIO(gv)->lines = 0;
6250 PUSHi( (I32)forkprocess );
6252 else if (forkprocess == 0) /* we are a new child */
6269 PUSHs( do_close(gv, TRUE) ? &sv_yes : &sv_no );
6293 do_close(rgv, FALSE);
6295 do_close(wgv, FALSE);
6300 rstio->ifp = fdopen(fd[0], "r");
6301 wstio->ofp = fdopen(fd[1], "w");
6302 wstio->ifp = wstio->ofp;
6306 if (!rstio->ifp || !wstio->ofp) {
6307 if (rstio->ifp) fclose(rstio->ifp);
6309 if (wstio->ofp) fclose(wstio->ofp);
6319 DIE(no_func, "pipe");
6332 if (!gv || !(io = GvIO(gv)) || !(fp = io->ifp))
6350 TAINT_PROPER("umask");
6353 DIE(no_func, "Unsupported function umask");
6371 if (!gv || !(io = GvIO(gv)) || !(fp = io->ifp))
6376 if (!fflush(fp) && (fp->_flag |= _IOBIN))
6381 if (setmode(fileno(fp), OP_BINARY) != -1)
6399 SV **mark = stack_base + *markstack_ptr + 1; /* reuse in entersubr */
6403 stash = fetch_stash(mark[1], FALSE);
6404 if (!stash || !(gv = gv_fetchmethod(stash, "new")) || !GvCV(gv))
6405 DIE("Can't tie to package %s", SvPV(mark[1],na));
6407 Zero(&myop, 1, BINOP);
6408 myop.op_last = (OP *) &myop;
6409 myop.op_next = Nullop;
6410 myop.op_flags = OPf_STACKED;
6419 if (op = pp_entersubr())
6424 if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV)
6425 sv_magic(varsv, sv, 'P', 0, 0);
6427 sv_magic(varsv, sv, 'p', 0, -1);
6436 if (SvTYPE(TOPs) == SVt_PVHV || SvTYPE(TOPs) == SVt_PVAV)
6437 sv_unmagic(TOPs, 'P');
6439 sv_unmagic(TOPs, 'p');
6455 sv = sv_mortalcopy(&sv_no);
6456 sv_setpv(sv, "Any_DBM_File");
6457 stash = fetch_stash(sv, FALSE);
6458 if (!stash || !(gv = gv_fetchmethod(stash, "new")) || !GvCV(gv))
6459 DIE("No dbm on this machine");
6461 Zero(&myop, 1, BINOP);
6462 myop.op_last = (OP *) &myop;
6463 myop.op_next = Nullop;
6464 myop.op_flags = OPf_STACKED;
6477 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
6479 PUSHs(sv_2mortal(newSViv(O_RDWR)));
6483 if (op = pp_entersubr())
6489 sv_magic((SV*)hv, sv, 'P', 0, 0);
6495 return pp_untie(ARGS);
6509 struct timeval timebuf;
6510 struct timeval *tbuf = &timebuf;
6513 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
6518 # if BYTEORDER & 0xf0000
6519 # define ORDERBYTE (0x88888888 - BYTEORDER)
6521 # define ORDERBYTE (0x4444 - BYTEORDER)
6527 for (i = 1; i <= 3; i++) {
6535 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
6536 growsize = maxlen; /* little endians can use vecs directly */
6544 masksize = NFDBITS / NBBY;
6546 masksize = sizeof(long); /* documented int, everyone seems to use long */
6548 growsize = maxlen + (masksize - (maxlen % masksize));
6549 Zero(&fd_sets[0], 4, char*);
6557 timebuf.tv_sec = (long)value;
6558 value -= (double)timebuf.tv_sec;
6559 timebuf.tv_usec = (long)(value * 1000000.0);
6562 tbuf = Null(struct timeval*);
6564 for (i = 1; i <= 3; i++) {
6572 Sv_Grow(sv, growsize);
6573 s = SvPV(sv, na) + j;
6574 while (++j <= growsize) {
6578 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
6580 New(403, fd_sets[i], growsize, char);
6581 for (offset = 0; offset < growsize; offset += masksize) {
6582 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
6583 fd_sets[i][j+offset] = s[(k % masksize) + offset];
6586 fd_sets[i] = SvPVX(sv);
6596 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
6597 for (i = 1; i <= 3; i++) {
6601 for (offset = 0; offset < growsize; offset += masksize) {
6602 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
6603 s[(k % masksize) + offset] = fd_sets[i][j+offset];
6605 Safefree(fd_sets[i]);
6611 if (GIMME == G_ARRAY && tbuf) {
6612 value = (double)(timebuf.tv_sec) +
6613 (double)(timebuf.tv_usec) / 1000000.0;
6614 PUSHs(sv = sv_mortalcopy(&sv_no));
6615 sv_setnv(sv, value);
6619 DIE("select not implemented");
6626 GV *oldgv = defoutgv;
6627 if (op->op_private > 0) {
6628 defoutgv = (GV*)POPs;
6629 if (!GvIO(defoutgv))
6630 GvIO(defoutgv) = newIO();
6631 curoutgv = defoutgv;
6633 gv_efullname(TARG, oldgv);
6649 if (!gv || do_eof(gv)) /* make sure we have fp with something */
6652 sv_setpv(TARG, " ");
6653 *SvPVX(TARG) = getc(GvIO(gv)->ifp); /* should never be EOF */
6660 return pp_sysread(ARGS);
6669 register CONTEXT *cx;
6675 PUSHBLOCK(cx, CXt_SUB, stack_sp);
6677 defoutgv = gv; /* locally select filehandle so $% et al work */
6712 SV *tmpstr = sv_mortalcopy(&sv_undef);
6713 gv_efullname(tmpstr, gv);
6714 DIE("Undefined format \"%s\" called",SvPVX(tmpstr));
6716 DIE("Not a format reference");
6719 return doform(cv,gv,op->op_next);
6725 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
6726 register IO *io = GvIO(gv);
6727 FILE *ofp = io->ofp;
6732 register CONTEXT *cx;
6734 DEBUG_f(fprintf(stderr,"left=%ld, todo=%ld\n",
6735 (long)io->lines_left, (long)FmLINES(formtarget)));
6736 if (io->lines_left < FmLINES(formtarget) &&
6737 formtarget != toptarget)
6743 if (!io->top_name) {
6745 io->fmt_name = savestr(GvNAME(gv));
6746 sprintf(tmpbuf, "%s_TOP", io->fmt_name);
6747 topgv = gv_fetchpv(tmpbuf,FALSE);
6748 if (topgv && GvFORM(topgv))
6749 io->top_name = savestr(tmpbuf);
6751 io->top_name = savestr("top");
6753 topgv = gv_fetchpv(io->top_name,FALSE);
6754 if (!topgv || !GvFORM(topgv)) {
6755 io->lines_left = 100000000;
6760 if (io->lines_left >= 0 && io->page > 0)
6761 fwrite(SvPVX(formfeed), SvCUR(formfeed), 1, ofp);
6762 io->lines_left = io->page_len;
6764 formtarget = toptarget;
6765 return doform(GvFORM(io->top_gv),gv,op);
6777 warn("Filehandle only opened for input");
6779 warn("Write on closed filehandle");
6784 if ((io->lines_left -= FmLINES(formtarget)) < 0) {
6786 warn("page overflow");
6788 if (!fwrite(SvPVX(formtarget), 1, SvCUR(formtarget), ofp) ||
6792 FmLINES(formtarget) = 0;
6793 SvCUR_set(formtarget, 0);
6794 if (io->flags & IOf_FLUSH)
6799 formtarget = bodytarget;
6801 return pop_return();
6806 dSP; dMARK; dORIGMARK;
6810 SV *sv = NEWSV(0,0);
6812 if (op->op_flags & OPf_STACKED)
6816 if (!(io = GvIO(gv))) {
6818 warn("Filehandle never opened");
6822 else if (!(fp = io->ofp)) {
6825 warn("Filehandle opened only for input");
6827 warn("printf on closed filehandle");
6833 do_sprintf(sv, SP - MARK, MARK + 1);
6834 if (!do_print(sv, fp))
6837 if (io->flags & IOf_FLUSH)
6838 if (fflush(fp) == EOF)
6855 dSP; dMARK; dORIGMARK;
6860 if (op->op_flags & OPf_STACKED)
6864 if (!(io = GvIO(gv))) {
6866 warn("Filehandle never opened");
6870 else if (!(fp = io->ofp)) {
6873 warn("Filehandle opened only for input");
6875 warn("print on closed filehandle");
6883 while (MARK <= SP) {
6884 if (!do_print(*MARK, fp))
6888 if (fwrite(ofs, 1, ofslen, fp) == 0 || ferror(fp)) {
6896 while (MARK <= SP) {
6897 if (!do_print(*MARK, fp))
6906 if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp))
6909 if (io->flags & IOf_FLUSH)
6910 if (fflush(fp) == EOF)
6926 dSP; dMARK; dORIGMARK; dTARGET;
6940 buffer = SvPV(bufstr, blen);
6941 length = SvIVx(*++MARK);
6942 if (SvREADONLY(bufstr))
6946 offset = SvIVx(*++MARK);
6950 warn("Too many args on read");
6952 if (!io || !io->ifp)
6955 if (op->op_type == OP_RECV) {
6956 bufsize = sizeof buf;
6957 SvGROW(bufstr, length+1), (buffer = SvPV(bufstr, blen)); /* sneaky */
6958 length = recvfrom(fileno(io->ifp), buffer, length, offset,
6962 SvCUR_set(bufstr, length);
6963 *SvEND(bufstr) = '\0';
6966 sv_setpvn(TARG, buf, bufsize);
6971 if (op->op_type == OP_RECV)
6972 DIE(no_sock_func, "recv");
6974 SvGROW(bufstr, length+offset+1), (buffer = SvPV(bufstr, blen)); /* sneaky */
6975 if (op->op_type == OP_SYSREAD) {
6976 length = read(fileno(io->ifp), buffer+offset, length);
6980 if (io->type == 's') {
6981 bufsize = sizeof buf;
6982 length = recvfrom(fileno(io->ifp), buffer+offset, length, 0,
6987 length = fread(buffer+offset, 1, length, io->ifp);
6990 SvCUR_set(bufstr, length+offset);
6991 *SvEND(bufstr) = '\0';
7004 return pp_send(ARGS);
7009 dSP; dMARK; dORIGMARK; dTARGET;
7022 buffer = SvPV(bufstr, blen);
7023 length = SvIVx(*++MARK);
7026 if (!io || !io->ifp) {
7029 if (op->op_type == OP_SYSWRITE)
7030 warn("Syswrite on closed filehandle");
7032 warn("Send on closed socket");
7035 else if (op->op_type == OP_SYSWRITE) {
7037 offset = SvIVx(*++MARK);
7041 warn("Too many args on syswrite");
7042 length = write(fileno(io->ifp), buffer+offset, length);
7045 else if (SP >= MARK) {
7048 warn("Too many args on send");
7049 buffer = SvPVx(*++MARK, mlen);
7050 length = sendto(fileno(io->ifp), buffer, blen, length, buffer, mlen);
7053 length = send(fileno(io->ifp), buffer, blen, length);
7056 DIE(no_sock_func, "send");
7071 return pp_sysread(ARGS);
7083 PUSHs(do_eof(gv) ? &sv_yes : &sv_no);
7096 PUSHi( do_tell(gv) );
7108 PUSHs( do_seek(gv, offset, whence) ? &sv_yes : &sv_no );
7115 off_t len = (off_t)POPn;
7120 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE)
7122 if (op->op_flags & OPf_SPECIAL) {
7123 tmpgv = gv_fetchpv(POPp,FALSE);
7124 if (!tmpgv || !GvIO(tmpgv) || !GvIO(tmpgv)->ifp ||
7125 ftruncate(fileno(GvIO(tmpgv)->ifp), len) < 0)
7128 else if (truncate(POPp, len) < 0)
7131 if (op->op_flags & OPf_SPECIAL) {
7132 tmpgv = gv_fetchpv(POPp,FALSE);
7133 if (!tmpgv || !GvIO(tmpgv) || !GvIO(tmpgv)->ifp ||
7134 chsize(fileno(GvIO(tmpgv)->ifp), len) < 0)
7140 if ((tmpfd = open(POPp, 0)) < 0)
7143 if (chsize(tmpfd, len) < 0)
7156 DIE("truncate not implemented");
7162 return pp_ioctl(ARGS);
7169 unsigned int func = U_I(POPn);
7170 int optype = op->op_type;
7176 if (!io || !argstr || !io->ifp) {
7177 errno = EBADF; /* well, sort of... */
7181 if (SvPOK(argstr) || !SvNIOK(argstr)) {
7184 s = SvPV(argstr, len);
7185 retval = IOCPARM_LEN(func);
7187 Sv_Grow(argstr, retval+1);
7188 SvCUR_set(argstr, retval);
7192 s[SvCUR(argstr)] = 17; /* a little sanity check here */
7195 retval = SvIV(argstr);
7197 s = (char*)(long)retval; /* ouch */
7199 s = (char*)retval; /* ouch */
7203 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
7205 if (optype == OP_IOCTL)
7206 retval = ioctl(fileno(io->ifp), func, s);
7209 DIE("fcntl is not implemented");
7212 retval = fcntl(fileno(io->ifp), func, s);
7214 DIE("fcntl is not implemented");
7218 if (SvPOK(argstr)) {
7219 if (s[SvCUR(argstr)] != 17)
7220 DIE("Return value overflowed string");
7221 s[SvCUR(argstr)] = 0; /* put our null back */
7230 PUSHp("0 but true", 10);
7253 value = (I32)(flock(fileno(fp), argtype) >= 0);
7260 DIE(no_func, "flock()");
7272 int protocol = POPi;
7286 do_close(gv, FALSE);
7288 TAINT_PROPER("socket");
7289 fd = socket(domain, type, protocol);
7292 io->ifp = fdopen(fd, "r"); /* stdio gets confused about sockets */
7293 io->ofp = fdopen(fd, "w");
7295 if (!io->ifp || !io->ofp) {
7296 if (io->ifp) fclose(io->ifp);
7297 if (io->ofp) fclose(io->ofp);
7298 if (!io->ifp && !io->ofp) close(fd);
7304 DIE(no_sock_func, "socket");
7311 #ifdef HAS_SOCKETPAIR
7316 int protocol = POPi;
7329 do_close(gv1, FALSE);
7331 do_close(gv2, FALSE);
7333 TAINT_PROPER("socketpair");
7334 if (socketpair(domain, type, protocol, fd) < 0)
7336 io1->ifp = fdopen(fd[0], "r");
7337 io1->ofp = fdopen(fd[0], "w");
7339 io2->ifp = fdopen(fd[1], "r");
7340 io2->ofp = fdopen(fd[1], "w");
7342 if (!io1->ifp || !io1->ofp || !io2->ifp || !io2->ofp) {
7343 if (io1->ifp) fclose(io1->ifp);
7344 if (io1->ofp) fclose(io1->ofp);
7345 if (!io1->ifp && !io1->ofp) close(fd[0]);
7346 if (io2->ifp) fclose(io2->ifp);
7347 if (io2->ofp) fclose(io2->ofp);
7348 if (!io2->ifp && !io2->ofp) close(fd[1]);
7354 DIE(no_sock_func, "socketpair");
7365 register IO *io = GvIOn(gv);
7368 if (!io || !io->ifp)
7371 addr = SvPV(addrstr, len);
7372 TAINT_PROPER("bind");
7373 if (bind(fileno(io->ifp), addr, len) >= 0)
7380 warn("bind() on closed fd");
7384 DIE(no_sock_func, "bind");
7395 register IO *io = GvIOn(gv);
7398 if (!io || !io->ifp)
7401 addr = SvPV(addrstr, len);
7402 TAINT_PROPER("connect");
7403 if (connect(fileno(io->ifp), addr, len) >= 0)
7410 warn("connect() on closed fd");
7414 DIE(no_sock_func, "connect");
7424 register IO *io = GvIOn(gv);
7426 if (!io || !io->ifp)
7429 if (listen(fileno(io->ifp), backlog) >= 0)
7436 warn("listen() on closed fd");
7440 DIE(no_sock_func, "listen");
7452 int len = sizeof buf;
7464 if (!gstio || !gstio->ifp)
7469 do_close(ngv, FALSE);
7471 fd = accept(fileno(gstio->ifp), (struct sockaddr *)buf, &len);
7474 nstio->ifp = fdopen(fd, "r");
7475 nstio->ofp = fdopen(fd, "w");
7477 if (!nstio->ifp || !nstio->ofp) {
7478 if (nstio->ifp) fclose(nstio->ifp);
7479 if (nstio->ofp) fclose(nstio->ofp);
7480 if (!nstio->ifp && !nstio->ofp) close(fd);
7489 warn("accept() on closed fd");
7496 DIE(no_sock_func, "accept");
7506 register IO *io = GvIOn(gv);
7508 if (!io || !io->ifp)
7511 PUSHi( shutdown(fileno(io->ifp), how) >= 0 );
7516 warn("shutdown() on closed fd");
7520 DIE(no_sock_func, "shutdown");
7527 return pp_ssockopt(ARGS);
7529 DIE(no_sock_func, "getsockopt");
7537 int optype = op->op_type;
7540 unsigned int optname;
7545 if (optype == OP_GSOCKOPT)
7546 sv = sv_2mortal(NEWSV(22, 257));
7549 optname = (unsigned int) POPi;
7550 lvl = (unsigned int) POPi;
7554 if (!io || !io->ifp)
7557 fd = fileno(io->ifp);
7562 if (getsockopt(fd, lvl, optname, SvPVX(sv), (int*)&SvCUR(sv)) < 0)
7567 if (setsockopt(fd, lvl, optname, SvPVX(sv), SvCUR(sv)) < 0)
7576 warn("[gs]etsockopt() on closed fd");
7582 DIE(no_sock_func, "setsockopt");
7589 return pp_getpeername(ARGS);
7591 DIE(no_sock_func, "getsockname");
7599 int optype = op->op_type;
7603 register IO *io = GvIOn(gv);
7605 if (!io || !io->ifp)
7608 sv = sv_2mortal(NEWSV(22, 257));
7611 fd = fileno(io->ifp);
7613 case OP_GETSOCKNAME:
7614 if (getsockname(fd, SvPVX(sv), (int*)&SvCUR(sv)) < 0)
7617 case OP_GETPEERNAME:
7618 if (getpeername(fd, SvPVX(sv), (int*)&SvCUR(sv)) < 0)
7627 warn("get{sock, peer}name() on closed fd");
7633 DIE(no_sock_func, "getpeername");
7641 return pp_stat(ARGS);
7650 if (op->op_flags & OPf_SPECIAL) {
7651 tmpgv = cGVOP->op_gv;
7652 if (tmpgv != defgv) {
7653 laststype = OP_STAT;
7655 sv_setpv(statname, "");
7656 if (!GvIO(tmpgv) || !GvIO(tmpgv)->ifp ||
7657 fstat(fileno(GvIO(tmpgv)->ifp), &statcache) < 0) {
7662 else if (laststatval < 0)
7666 sv_setpv(statname, POPp);
7669 laststype = op->op_type;
7670 if (op->op_type == OP_LSTAT)
7671 laststatval = lstat(SvPV(statname, na), &statcache);
7674 laststatval = stat(SvPV(statname, na), &statcache);
7675 if (laststatval < 0) {
7676 if (dowarn && strchr(SvPV(statname, na), '\n'))
7677 warn(warn_nl, "stat");
7683 if (GIMME != G_ARRAY) {
7690 PUSHs(sv_2mortal(newSVnv((double)statcache.st_dev)));
7691 PUSHs(sv_2mortal(newSVnv((double)statcache.st_ino)));
7692 PUSHs(sv_2mortal(newSVnv((double)statcache.st_mode)));
7693 PUSHs(sv_2mortal(newSVnv((double)statcache.st_nlink)));
7694 PUSHs(sv_2mortal(newSVnv((double)statcache.st_uid)));
7695 PUSHs(sv_2mortal(newSVnv((double)statcache.st_gid)));
7696 PUSHs(sv_2mortal(newSVnv((double)statcache.st_rdev)));
7697 PUSHs(sv_2mortal(newSVnv((double)statcache.st_size)));
7698 PUSHs(sv_2mortal(newSVnv((double)statcache.st_atime)));
7699 PUSHs(sv_2mortal(newSVnv((double)statcache.st_mtime)));
7700 PUSHs(sv_2mortal(newSVnv((double)statcache.st_ctime)));
7702 PUSHs(sv_2mortal(newSVnv((double)statcache.st_blksize)));
7703 PUSHs(sv_2mortal(newSVnv((double)statcache.st_blocks)));
7705 PUSHs(sv_2mortal(newSVpv("", 0)));
7706 PUSHs(sv_2mortal(newSVpv("", 0)));
7714 I32 result = my_stat(ARGS);
7718 if (cando(S_IRUSR, 0, &statcache))
7725 I32 result = my_stat(ARGS);
7729 if (cando(S_IWUSR, 0, &statcache))
7736 I32 result = my_stat(ARGS);
7740 if (cando(S_IXUSR, 0, &statcache))
7747 I32 result = my_stat(ARGS);
7751 if (cando(S_IRUSR, 1, &statcache))
7758 I32 result = my_stat(ARGS);
7762 if (cando(S_IWUSR, 1, &statcache))
7769 I32 result = my_stat(ARGS);
7773 if (cando(S_IXUSR, 1, &statcache))
7780 I32 result = my_stat(ARGS);
7789 return pp_ftrowned(ARGS);
7794 I32 result = my_stat(ARGS);
7798 if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
7805 I32 result = my_stat(ARGS);
7809 if (!statcache.st_size)
7816 I32 result = my_stat(ARGS);
7820 PUSHi(statcache.st_size);
7826 I32 result = my_stat(ARGS);
7830 PUSHn( (basetime - statcache.st_mtime) / 86400.0 );
7836 I32 result = my_stat(ARGS);
7840 PUSHn( (basetime - statcache.st_atime) / 86400.0 );
7846 I32 result = my_stat(ARGS);
7850 PUSHn( (basetime - statcache.st_ctime) / 86400.0 );
7856 I32 result = my_stat(ARGS);
7860 if (S_ISSOCK(statcache.st_mode))
7867 I32 result = my_stat(ARGS);
7871 if (S_ISCHR(statcache.st_mode))
7878 I32 result = my_stat(ARGS);
7882 if (S_ISBLK(statcache.st_mode))
7889 I32 result = my_stat(ARGS);
7893 if (S_ISREG(statcache.st_mode))
7900 I32 result = my_stat(ARGS);
7904 if (S_ISDIR(statcache.st_mode))
7911 I32 result = my_stat(ARGS);
7915 if (S_ISFIFO(statcache.st_mode))
7922 I32 result = my_lstat(ARGS);
7926 if (S_ISLNK(statcache.st_mode))
7935 I32 result = my_stat(ARGS);
7939 if (statcache.st_mode & S_ISUID)
7949 I32 result = my_stat(ARGS);
7953 if (statcache.st_mode & S_ISGID)
7963 I32 result = my_stat(ARGS);
7967 if (statcache.st_mode & S_ISVTX)
7979 if (op->op_flags & OPf_SPECIAL) {
7984 gv = gv_fetchpv(tmps = POPp, FALSE);
7985 if (gv && GvIO(gv) && GvIO(gv)->ifp)
7986 fd = fileno(GvIO(gv)->ifp);
7987 else if (isDIGIT(*tmps))
8003 register STDCHAR *s;
8007 if (op->op_flags & OPf_SPECIAL) {
8009 if (cGVOP->op_gv == defgv) {
8014 goto really_filename;
8018 statgv = cGVOP->op_gv;
8019 sv_setpv(statname, "");
8022 if (io && io->ifp) {
8023 #if defined(STDSTDIO) || defined(atarist) /* this will work with atariST */
8024 fstat(fileno(io->ifp), &statcache);
8025 if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
8026 if (op->op_type == OP_FTTEXT)
8030 if (io->ifp->_cnt <= 0) {
8033 (void)ungetc(i, io->ifp);
8035 if (io->ifp->_cnt <= 0) /* null file is anything */
8037 len = io->ifp->_cnt + (io->ifp->_ptr - io->ifp->_base);
8040 DIE("-T and -B not implemented on filehandles");
8045 warn("Test on unopened file <%s>",
8046 GvENAME(cGVOP->op_gv));
8054 sv_setpv(statname, SvPV(sv, na));
8056 i = open(SvPV(sv, na), 0);
8058 if (dowarn && strchr(SvPV(sv, na), '\n'))
8059 warn(warn_nl, "open");
8062 fstat(i, &statcache);
8063 len = read(i, tbuf, 512);
8066 if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
8067 RETPUSHNO; /* special case NFS directories */
8068 RETPUSHYES; /* null file is anything */
8073 /* now scan s to look for textiness */
8075 for (i = 0; i < len; i++, s++) {
8076 if (!*s) { /* null never allowed in text */
8083 *s != '\n' && *s != '\r' && *s != '\b' &&
8084 *s != '\t' && *s != '\f' && *s != 27)
8088 if ((odd * 10 > len) == (op->op_type == OP_FTTEXT)) /* allow 10% odd */
8096 return pp_fttext(ARGS);
8112 if (!tmps || !*tmps) {
8113 svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
8115 tmps = SvPV(*svp, na);
8117 if (!tmps || !*tmps) {
8118 svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
8120 tmps = SvPV(*svp, na);
8122 TAINT_PROPER("chdir");
8123 PUSHi( chdir(tmps) >= 0 );
8129 dSP; dMARK; dTARGET;
8132 value = (I32)apply(op->op_type, MARK, SP);
8137 DIE(no_func, "Unsupported function chown");
8147 tmps = SvPVx(GvSV(defgv), na);
8150 TAINT_PROPER("chroot");
8151 PUSHi( chroot(tmps) >= 0 );
8154 DIE(no_func, "chroot");
8160 dSP; dMARK; dTARGET;
8162 value = (I32)apply(op->op_type, MARK, SP);
8170 dSP; dMARK; dTARGET;
8172 value = (I32)apply(op->op_type, MARK, SP);
8180 dSP; dMARK; dTARGET;
8182 value = (I32)apply(op->op_type, MARK, SP);
8194 char *tmps = SvPV(TOPs, na);
8195 TAINT_PROPER("rename");
8197 anum = rename(tmps, tmps2);
8199 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
8202 if (euid || stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
8203 (void)UNLINK(tmps2);
8204 if (!(anum = link(tmps, tmps2)))
8205 anum = UNLINK(tmps);
8217 char *tmps = SvPV(TOPs, na);
8218 TAINT_PROPER("link");
8219 SETi( link(tmps, tmps2) >= 0 );
8221 DIE(no_func, "Unsupported function link");
8231 char *tmps = SvPV(TOPs, na);
8232 TAINT_PROPER("symlink");
8233 SETi( symlink(tmps, tmps2) >= 0 );
8236 DIE(no_func, "symlink");
8247 tmps = SvPVx(GvSV(defgv), na);
8250 len = readlink(tmps, buf, sizeof buf);
8258 RETSETUNDEF; /* just pretend it's a normal file */
8262 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
8264 dooneliner(cmd, filename)
8275 for (s = mybuf+strlen(mybuf); *filename; ) {
8280 myfp = my_popen(mybuf, "r");
8283 s = fgets(mybuf, sizeof mybuf, myfp);
8284 (void)my_pclose(myfp);
8286 for (errno = 1; errno < sys_nerr; errno++) {
8287 if (instr(mybuf, sys_errlist[errno])) /* you don't see this */
8292 #define EACCES EPERM
8294 if (instr(mybuf, "cannot make"))
8296 else if (instr(mybuf, "existing file"))
8298 else if (instr(mybuf, "ile exists"))
8300 else if (instr(mybuf, "non-exist"))
8302 else if (instr(mybuf, "does not exist"))
8304 else if (instr(mybuf, "not empty"))
8306 else if (instr(mybuf, "cannot access"))
8312 else { /* some mkdirs return no failure indication */
8313 tmps = SvPVx(st[1], na);
8314 anum = (stat(tmps, &statbuf) >= 0);
8315 if (op->op_type == OP_RMDIR)
8320 errno = EACCES; /* a guess */
8334 char *tmps = SvPV(TOPs, na);
8336 TAINT_PROPER("mkdir");
8338 SETi( mkdir(tmps, mode) >= 0 );
8340 SETi( dooneliner("mkdir", tmps) );
8343 chmod(tmps, (mode & ~oldumask) & 0777);
8354 tmps = SvPVx(GvSV(defgv), na);
8357 TAINT_PROPER("rmdir");
8359 XPUSHi( rmdir(tmps) >= 0 );
8361 XPUSHi( dooneliner("rmdir", tmps) );
8366 /* Directory calls. */
8371 #if defined(DIRENT) && defined(HAS_READDIR)
8372 char *dirname = POPp;
8374 register IO *io = GvIOn(gv);
8381 if (!(io->dirp = opendir(dirname)))
8390 DIE(no_dir_func, "opendir");
8397 #if defined(DIRENT) && defined(HAS_READDIR)
8399 struct DIRENT *readdir();
8401 register struct DIRENT *dp;
8403 register IO *io = GvIOn(gv);
8405 if (!io || !io->dirp)
8408 if (GIMME == G_ARRAY) {
8410 while (dp = readdir(io->dirp)) {
8412 XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
8414 XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
8419 if (!(dp = readdir(io->dirp)))
8422 XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
8424 XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
8432 if (GIMME == G_ARRAY)
8437 DIE(no_dir_func, "readdir");
8444 #if defined(HAS_TELLDIR) || defined(telldir)
8449 register IO *io = GvIOn(gv);
8451 if (!io || !io->dirp)
8454 PUSHi( telldir(io->dirp) );
8461 DIE(no_dir_func, "telldir");
8468 #if defined(HAS_SEEKDIR) || defined(seekdir)
8471 register IO *io = GvIOn(gv);
8473 if (!io || !io->dirp)
8476 (void)seekdir(io->dirp, along);
8484 DIE(no_dir_func, "seekdir");
8491 #if defined(HAS_REWINDDIR) || defined(rewinddir)
8493 register IO *io = GvIOn(gv);
8495 if (!io || !io->dirp)
8498 (void)rewinddir(io->dirp);
8505 DIE(no_dir_func, "rewinddir");
8512 #if defined(DIRENT) && defined(HAS_READDIR)
8514 register IO *io = GvIOn(gv);
8516 if (!io || !io->dirp)
8519 if (closedir(io->dirp) < 0)
8529 DIE(no_dir_func, "closedir");
8533 /* Process control. */
8548 if (tmpgv = gv_fetchpv("$", TRUE))
8549 sv_setiv(GvSV(tmpgv), (I32)getpid());
8550 hv_clear(pidstatus); /* no kids, so don't wait for 'em */
8555 DIE(no_func, "Unsupported function fork");
8568 childpid = wait(&argflags);
8570 pidgone(childpid, argflags);
8571 value = (I32)childpid;
8572 statusvalue = (U16)argflags;
8576 DIE(no_func, "Unsupported function wait");
8591 childpid = wait4pid(childpid, &argflags, optype);
8592 value = (I32)childpid;
8593 statusvalue = (U16)argflags;
8597 DIE(no_func, "Unsupported function wait");
8603 dSP; dMARK; dORIGMARK; dTARGET;
8608 VOIDRET (*ihand)(); /* place to save signal during system() */
8609 VOIDRET (*qhand)(); /* place to save signal during system() */
8612 if (SP - MARK == 1) {
8614 char *junk = SvPV(TOPs, na);
8616 TAINT_PROPER("system");
8619 while ((childpid = vfork()) == -1) {
8620 if (errno != EAGAIN) {
8629 ihand = signal(SIGINT, SIG_IGN);
8630 qhand = signal(SIGQUIT, SIG_IGN);
8631 result = wait4pid(childpid, &status, 0);
8632 (void)signal(SIGINT, ihand);
8633 (void)signal(SIGQUIT, qhand);
8634 statusvalue = (U16)status;
8638 value = (I32)((unsigned int)status & 0xffff);
8640 do_execfree(); /* free any memory child malloced on vfork */
8645 if (op->op_flags & OPf_STACKED) {
8646 SV *really = *++MARK;
8647 value = (I32)do_aexec(really, MARK, SP);
8649 else if (SP - MARK != 1)
8650 value = (I32)do_aexec(Nullsv, MARK, SP);
8652 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
8656 if ((op[1].op_type & A_MASK) == A_GV)
8657 value = (I32)do_aspawn(st[1], arglast);
8658 else if (arglast[2] - arglast[1] != 1)
8659 value = (I32)do_aspawn(Nullsv, arglast);
8661 value = (I32)do_spawn(SvPVx(sv_mortalcopy(st[2]), na));
8670 dSP; dMARK; dORIGMARK; dTARGET;
8673 if (op->op_flags & OPf_STACKED) {
8674 SV *really = *++MARK;
8675 value = (I32)do_aexec(really, MARK, SP);
8677 else if (SP - MARK != 1)
8678 value = (I32)do_aexec(Nullsv, MARK, SP);
8681 char *junk = SvPV(*SP, na);
8683 TAINT_PROPER("exec");
8685 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
8694 dSP; dMARK; dTARGET;
8697 value = (I32)apply(op->op_type, MARK, SP);
8702 DIE(no_func, "Unsupported function kill");
8710 XPUSHi( getppid() );
8713 DIE(no_func, "getppid");
8728 #ifdef _POSIX_SOURCE
8730 DIE("POSIX getpgrp can't take an argument");
8731 value = (I32)getpgrp();
8733 value = (I32)getpgrp(pid);
8738 DIE(no_func, "getpgrp()");
8749 TAINT_PROPER("setpgrp");
8750 SETi( setpgrp(pid, pgrp) >= 0 );
8753 DIE(no_func, "setpgrp()");
8762 #ifdef HAS_GETPRIORITY
8765 SETi( getpriority(which, who) );
8768 DIE(no_func, "getpriority()");
8778 #ifdef HAS_SETPRIORITY
8782 TAINT_PROPER("setpriority");
8783 SETi( setpriority(which, who, niceval) >= 0 );
8786 DIE(no_func, "setpriority()");
8795 XPUSHi( time(Null(long*)) );
8808 DIE("times not implemented");
8812 (void)times(×buf);
8814 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
8815 if (GIMME == G_ARRAY) {
8816 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
8817 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
8818 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
8826 return pp_gmtime(ARGS);
8834 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
8835 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
8836 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
8841 when = (time_t)SvIVx(POPs);
8843 if (op->op_type == OP_LOCALTIME)
8844 tmbuf = localtime(&when);
8846 tmbuf = gmtime(&when);
8849 if (GIMME != G_ARRAY) {
8854 sprintf(mybuf, "%s %s %2d %02d:%02d:%02d %d",
8855 dayname[tmbuf->tm_wday],
8856 monname[tmbuf->tm_mon],
8861 tmbuf->tm_year + 1900);
8862 PUSHp(mybuf, strlen(mybuf));
8865 PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_sec)));
8866 PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_min)));
8867 PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_hour)));
8868 PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_mday)));
8869 PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_mon)));
8870 PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_year)));
8871 PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_wday)));
8872 PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_yday)));
8873 PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_isdst)));
8884 anum = SvIVx(GvSV(defgv));
8887 anum = alarm((unsigned int)anum);
8894 DIE(no_func, "Unsupported function alarm");
8907 (void)time(&lasttime);
8912 sleep((unsigned int)duration);
8915 XPUSHi(when - lasttime);
8919 /* Shared memory. */
8923 return pp_semget(ARGS);
8928 return pp_semctl(ARGS);
8933 return pp_shmwrite(ARGS);
8938 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
8939 dSP; dMARK; dTARGET;
8940 I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
8949 /* Message passing. */
8953 return pp_semget(ARGS);
8958 return pp_semctl(ARGS);
8963 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
8964 dSP; dMARK; dTARGET;
8965 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
8976 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
8977 dSP; dMARK; dTARGET;
8978 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
8991 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
8992 dSP; dMARK; dTARGET;
8993 int anum = do_ipcget(op->op_type, MARK, SP);
9000 DIE("System V IPC is not implemented on this machine");
9006 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
9007 dSP; dMARK; dTARGET;
9008 int anum = do_ipcctl(op->op_type, MARK, SP);
9016 PUSHp("0 but true",10);
9026 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
9027 dSP; dMARK; dTARGET;
9028 I32 value = (I32)(do_semop(MARK, SP) >= 0);
9040 save_lines(array, sv)
9044 register char *s = SvPVX(sv);
9045 register char *send = SvPVX(sv) + SvCUR(sv);
9047 register I32 line = 1;
9049 while (s && s < send) {
9050 SV *tmpstr = NEWSV(85,0);
9052 sv_upgrade(tmpstr, SVt_PVMG);
9053 t = strchr(s, '\n');
9059 sv_setpvn(tmpstr, s, t - s);
9060 av_store(array, line++, tmpstr);
9074 /* set up a scratch pad */
9079 SAVESPTR(comppadname);
9080 SAVEINT(comppadnamefill);
9082 comppadname = newAV();
9083 comppadnamefill = -1;
9084 av_push(comppad, Nullsv);
9085 curpad = AvARRAY(comppad);
9088 /* make sure we compile in the right package */
9090 newstash = curcop->cop_stash;
9091 if (curstash != newstash) {
9093 curstash = newstash;
9098 /* try to compile it */
9102 curcop = &compiling;
9108 if (yyparse() || error_count || !eval_root) {
9124 if (optype == OP_REQUIRE)
9125 DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE)), na));
9129 rspara = (nrslen == 2);
9136 rspara = (nrslen == 2);
9137 compiling.cop_line = 0;
9139 DEBUG_x(dump_eval());
9141 /* compiled okay, so do it */
9148 sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
9149 RETURNOP(eval_start);
9155 register CONTEXT *cx;
9157 char *name = SvPV(sv, na);
9160 I32 gimme = G_SCALAR;
9162 if (op->op_type == OP_REQUIRE &&
9163 (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
9167 /* prepare to compile file */
9169 sv_setpv(linestr,"");
9171 SAVESPTR(rsfp); /* in case we're in a BEGIN */
9172 tmpname = savestr(name);
9173 if (*tmpname == '/' ||
9175 (tmpname[1] == '/' ||
9176 (tmpname[1] == '.' && tmpname[2] == '/'))))
9178 rsfp = fopen(tmpname,"r");
9181 AV *ar = GvAVn(incgv);
9184 for (i = 0; i <= AvFILL(ar); i++) {
9185 (void)sprintf(buf, "%s/%s",
9186 SvPVx(*av_fetch(ar, i, TRUE), na), name);
9187 rsfp = fopen(buf, "r");
9191 if (*s == '.' && s[1] == '/')
9194 tmpname = savestr(s);
9199 compiling.cop_filegv = gv_fetchfile(tmpname);
9203 if (op->op_type == OP_REQUIRE) {
9204 sprintf(tokenbuf,"Can't locate %s in @INC", name);
9205 if (instr(tokenbuf,".h "))
9206 strcat(tokenbuf," (change .h to .ph maybe?)");
9207 if (instr(tokenbuf,".ph "))
9208 strcat(tokenbuf," (did you run h2ph?)");
9218 /* switch to eval mode */
9220 push_return(op->op_next);
9221 PUSHBLOCK(cx,CXt_EVAL,SP);
9222 PUSHEVAL(cx,savestr(name));
9224 if (curcop->cop_line == 0) /* don't debug debugger... */
9226 compiling.cop_line = 0;
9234 return pp_require(ARGS);
9240 register CONTEXT *cx;
9247 /* switch to eval mode */
9249 push_return(op->op_next);
9250 PUSHBLOCK(cx,CXt_EVAL,SP);
9253 /* prepare to compile string */
9256 sv_setsv(linestr, sv);
9257 sv_catpv(linestr, "\n;");
9258 compiling.cop_filegv = gv_fetchfile("(eval)");
9259 compiling.cop_line = 1;
9261 save_lines(GvAV(curcop->cop_filegv), linestr);
9272 register CONTEXT *cx;
9275 OP *eroot = eval_root;
9279 retop = pop_return();
9281 if (gimme == G_SCALAR) {
9284 *MARK = sv_mortalcopy(TOPs);
9292 for (mark = newsp + 1; mark <= SP; mark++)
9293 *mark = sv_mortalcopy(*mark);
9294 /* in case LEAVE wipes old return values */
9297 if (optype != OP_ENTEREVAL) {
9298 char *name = cx->blk_eval.old_name;
9300 if (gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp) {
9301 (void)hv_store(GvHVn(incgv), name,
9302 strlen(name), newSVsv(GvSV(curcop->cop_filegv)), 0 );
9304 else if (optype == OP_REQUIRE)
9305 retop = die("%s did not return a true value", name);
9310 av_free(comppadname);
9313 sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
9322 SP = do_eval(st[1], OP_EVAL, curcop->cop_stash, TRUE,
9325 sv_free(cSVOP->op_sv);
9326 op[1].arg_ptr.arg_cmd = eval_root;
9327 op[1].op_type = (A_CMD|A_DONT);
9328 op[0].op_type = OP_TRY;
9339 register CONTEXT *cx;
9345 push_return(cLOGOP->op_other->op_next);
9346 PUSHBLOCK(cx,CXt_EVAL,SP);
9350 sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
9360 register CONTEXT *cx;
9367 if (gimme == G_SCALAR) {
9370 *MARK = sv_mortalcopy(TOPs);
9378 for (mark = newsp + 1; mark <= SP; mark++)
9379 *mark = sv_mortalcopy(*mark);
9380 /* in case LEAVE wipes old return values */
9384 sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
9388 /* Get system info. */
9393 return pp_ghostent(ARGS);
9395 DIE(no_sock_func, "gethostbyname");
9402 return pp_ghostent(ARGS);
9404 DIE(no_sock_func, "gethostbyaddr");
9412 I32 which = op->op_type;
9413 register char **elem;
9415 struct hostent *gethostbyname();
9416 struct hostent *gethostbyaddr();
9417 #ifdef HAS_GETHOSTENT
9418 struct hostent *gethostent();
9420 struct hostent *hent;
9424 if (which == OP_GHBYNAME) {
9425 hent = gethostbyname(POPp);
9427 else if (which == OP_GHBYADDR) {
9428 int addrtype = POPi;
9430 char *addr = SvPV(addrstr, na);
9432 hent = gethostbyaddr(addr, SvCUR(addrstr), addrtype);
9435 #ifdef HAS_GETHOSTENT
9436 hent = gethostent();
9438 DIE("gethostent not implemented");
9441 #ifdef HOST_NOT_FOUND
9443 statusvalue = (U16)h_errno & 0xffff;
9446 if (GIMME != G_ARRAY) {
9447 PUSHs(sv = sv_mortalcopy(&sv_undef));
9449 if (which == OP_GHBYNAME) {
9450 sv_setpvn(sv, hent->h_addr, hent->h_length);
9453 sv_setpv(sv, hent->h_name);
9459 PUSHs(sv = sv_mortalcopy(&sv_no));
9460 sv_setpv(sv, hent->h_name);
9461 PUSHs(sv = sv_mortalcopy(&sv_no));
9462 for (elem = hent->h_aliases; *elem; elem++) {
9463 sv_catpv(sv, *elem);
9465 sv_catpvn(sv, " ", 1);
9467 PUSHs(sv = sv_mortalcopy(&sv_no));
9468 sv_setiv(sv, (I32)hent->h_addrtype);
9469 PUSHs(sv = sv_mortalcopy(&sv_no));
9470 len = hent->h_length;
9471 sv_setiv(sv, (I32)len);
9473 for (elem = hent->h_addr_list; *elem; elem++) {
9474 XPUSHs(sv = sv_mortalcopy(&sv_no));
9475 sv_setpvn(sv, *elem, len);
9478 PUSHs(sv = sv_mortalcopy(&sv_no));
9479 sv_setpvn(sv, hent->h_addr, len);
9484 DIE(no_sock_func, "gethostent");
9491 return pp_gnetent(ARGS);
9493 DIE(no_sock_func, "getnetbyname");
9500 return pp_gnetent(ARGS);
9502 DIE(no_sock_func, "getnetbyaddr");
9510 I32 which = op->op_type;
9511 register char **elem;
9513 struct netent *getnetbyname();
9514 struct netent *getnetbyaddr();
9515 struct netent *getnetent();
9516 struct netent *nent;
9518 if (which == OP_GNBYNAME)
9519 nent = getnetbyname(POPp);
9520 else if (which == OP_GNBYADDR) {
9521 int addrtype = POPi;
9522 unsigned long addr = U_L(POPn);
9523 nent = getnetbyaddr((long)addr, addrtype);
9529 if (GIMME != G_ARRAY) {
9530 PUSHs(sv = sv_mortalcopy(&sv_undef));
9532 if (which == OP_GNBYNAME)
9533 sv_setiv(sv, (I32)nent->n_net);
9535 sv_setpv(sv, nent->n_name);
9541 PUSHs(sv = sv_mortalcopy(&sv_no));
9542 sv_setpv(sv, nent->n_name);
9543 PUSHs(sv = sv_mortalcopy(&sv_no));
9544 for (elem = nent->n_aliases; *elem; elem++) {
9545 sv_catpv(sv, *elem);
9547 sv_catpvn(sv, " ", 1);
9549 PUSHs(sv = sv_mortalcopy(&sv_no));
9550 sv_setiv(sv, (I32)nent->n_addrtype);
9551 PUSHs(sv = sv_mortalcopy(&sv_no));
9552 sv_setiv(sv, (I32)nent->n_net);
9557 DIE(no_sock_func, "getnetent");
9564 return pp_gprotoent(ARGS);
9566 DIE(no_sock_func, "getprotobyname");
9573 return pp_gprotoent(ARGS);
9575 DIE(no_sock_func, "getprotobynumber");
9583 I32 which = op->op_type;
9584 register char **elem;
9586 struct protoent *getprotobyname();
9587 struct protoent *getprotobynumber();
9588 struct protoent *getprotoent();
9589 struct protoent *pent;
9591 if (which == OP_GPBYNAME)
9592 pent = getprotobyname(POPp);
9593 else if (which == OP_GPBYNUMBER)
9594 pent = getprotobynumber(POPi);
9596 pent = getprotoent();
9599 if (GIMME != G_ARRAY) {
9600 PUSHs(sv = sv_mortalcopy(&sv_undef));
9602 if (which == OP_GPBYNAME)
9603 sv_setiv(sv, (I32)pent->p_proto);
9605 sv_setpv(sv, pent->p_name);
9611 PUSHs(sv = sv_mortalcopy(&sv_no));
9612 sv_setpv(sv, pent->p_name);
9613 PUSHs(sv = sv_mortalcopy(&sv_no));
9614 for (elem = pent->p_aliases; *elem; elem++) {
9615 sv_catpv(sv, *elem);
9617 sv_catpvn(sv, " ", 1);
9619 PUSHs(sv = sv_mortalcopy(&sv_no));
9620 sv_setiv(sv, (I32)pent->p_proto);
9625 DIE(no_sock_func, "getprotoent");
9632 return pp_gservent(ARGS);
9634 DIE(no_sock_func, "getservbyname");
9641 return pp_gservent(ARGS);
9643 DIE(no_sock_func, "getservbyport");
9651 I32 which = op->op_type;
9652 register char **elem;
9654 struct servent *getservbyname();
9655 struct servent *getservbynumber();
9656 struct servent *getservent();
9657 struct servent *sent;
9659 if (which == OP_GSBYNAME) {
9663 if (proto && !*proto)
9666 sent = getservbyname(name, proto);
9668 else if (which == OP_GSBYPORT) {
9672 sent = getservbyport(port, proto);
9675 sent = getservent();
9678 if (GIMME != G_ARRAY) {
9679 PUSHs(sv = sv_mortalcopy(&sv_undef));
9681 if (which == OP_GSBYNAME) {
9683 sv_setiv(sv, (I32)ntohs(sent->s_port));
9685 sv_setiv(sv, (I32)(sent->s_port));
9689 sv_setpv(sv, sent->s_name);
9695 PUSHs(sv = sv_mortalcopy(&sv_no));
9696 sv_setpv(sv, sent->s_name);
9697 PUSHs(sv = sv_mortalcopy(&sv_no));
9698 for (elem = sent->s_aliases; *elem; elem++) {
9699 sv_catpv(sv, *elem);
9701 sv_catpvn(sv, " ", 1);
9703 PUSHs(sv = sv_mortalcopy(&sv_no));
9705 sv_setiv(sv, (I32)ntohs(sent->s_port));
9707 sv_setiv(sv, (I32)(sent->s_port));
9709 PUSHs(sv = sv_mortalcopy(&sv_no));
9710 sv_setpv(sv, sent->s_proto);
9715 DIE(no_sock_func, "getservent");
9726 DIE(no_sock_func, "sethostent");
9737 DIE(no_sock_func, "setnetent");
9748 DIE(no_sock_func, "setprotoent");
9759 DIE(no_sock_func, "setservent");
9771 DIE(no_sock_func, "endhostent");
9783 DIE(no_sock_func, "endnetent");
9795 DIE(no_sock_func, "endprotoent");
9807 DIE(no_sock_func, "endservent");
9814 return pp_gpwent(ARGS);
9816 DIE(no_func, "getpwnam");
9823 return pp_gpwent(ARGS);
9825 DIE(no_func, "getpwuid");
9833 I32 which = op->op_type;
9834 register AV *ary = stack;
9836 struct passwd *getpwnam();
9837 struct passwd *getpwuid();
9838 struct passwd *getpwent();
9839 struct passwd *pwent;
9841 if (which == OP_GPWNAM)
9842 pwent = getpwnam(POPp);
9843 else if (which == OP_GPWUID)
9844 pwent = getpwuid(POPi);
9849 if (GIMME != G_ARRAY) {
9850 PUSHs(sv = sv_mortalcopy(&sv_undef));
9852 if (which == OP_GPWNAM)
9853 sv_setiv(sv, (I32)pwent->pw_uid);
9855 sv_setpv(sv, pwent->pw_name);
9861 PUSHs(sv = sv_mortalcopy(&sv_no));
9862 sv_setpv(sv, pwent->pw_name);
9863 PUSHs(sv = sv_mortalcopy(&sv_no));
9864 sv_setpv(sv, pwent->pw_passwd);
9865 PUSHs(sv = sv_mortalcopy(&sv_no));
9866 sv_setiv(sv, (I32)pwent->pw_uid);
9867 PUSHs(sv = sv_mortalcopy(&sv_no));
9868 sv_setiv(sv, (I32)pwent->pw_gid);
9869 PUSHs(sv = sv_mortalcopy(&sv_no));
9871 sv_setiv(sv, (I32)pwent->pw_change);
9874 sv_setiv(sv, (I32)pwent->pw_quota);
9877 sv_setpv(sv, pwent->pw_age);
9881 PUSHs(sv = sv_mortalcopy(&sv_no));
9883 sv_setpv(sv, pwent->pw_class);
9886 sv_setpv(sv, pwent->pw_comment);
9889 PUSHs(sv = sv_mortalcopy(&sv_no));
9890 sv_setpv(sv, pwent->pw_gecos);
9891 PUSHs(sv = sv_mortalcopy(&sv_no));
9892 sv_setpv(sv, pwent->pw_dir);
9893 PUSHs(sv = sv_mortalcopy(&sv_no));
9894 sv_setpv(sv, pwent->pw_shell);
9896 PUSHs(sv = sv_mortalcopy(&sv_no));
9897 sv_setiv(sv, (I32)pwent->pw_expire);
9902 DIE(no_func, "getpwent");
9913 DIE(no_func, "setpwent");
9924 DIE(no_func, "endpwent");
9931 return pp_ggrent(ARGS);
9933 DIE(no_func, "getgrnam");
9940 return pp_ggrent(ARGS);
9942 DIE(no_func, "getgrgid");
9950 I32 which = op->op_type;
9951 register char **elem;
9953 struct group *getgrnam();
9954 struct group *getgrgid();
9955 struct group *getgrent();
9956 struct group *grent;
9958 if (which == OP_GGRNAM)
9959 grent = getgrnam(POPp);
9960 else if (which == OP_GGRGID)
9961 grent = getgrgid(POPi);
9966 if (GIMME != G_ARRAY) {
9967 PUSHs(sv = sv_mortalcopy(&sv_undef));
9969 if (which == OP_GGRNAM)
9970 sv_setiv(sv, (I32)grent->gr_gid);
9972 sv_setpv(sv, grent->gr_name);
9978 PUSHs(sv = sv_mortalcopy(&sv_no));
9979 sv_setpv(sv, grent->gr_name);
9980 PUSHs(sv = sv_mortalcopy(&sv_no));
9981 sv_setpv(sv, grent->gr_passwd);
9982 PUSHs(sv = sv_mortalcopy(&sv_no));
9983 sv_setiv(sv, (I32)grent->gr_gid);
9984 PUSHs(sv = sv_mortalcopy(&sv_no));
9985 for (elem = grent->gr_mem; *elem; elem++) {
9986 sv_catpv(sv, *elem);
9988 sv_catpvn(sv, " ", 1);
9994 DIE(no_func, "getgrent");
10005 DIE(no_func, "setgrent");
10016 DIE(no_func, "endgrent");
10023 #ifdef HAS_GETLOGIN
10026 if (!(tmps = getlogin()))
10028 PUSHp(tmps, strlen(tmps));
10031 DIE(no_func, "getlogin");
10035 /* Miscellaneous. */
10040 dSP; dMARK; dORIGMARK; dTARGET;
10041 register I32 items = SP - MARK;
10042 unsigned long a[20];
10043 register I32 i = 0;
10047 while (++MARK <= SP) {
10048 if (SvMAGICAL(*MARK) && mg_find(*MARK, 't'))
10052 TAINT_PROPER("syscall");
10055 /* This probably won't work on machines where sizeof(long) != sizeof(int)
10056 * or where sizeof(long) != sizeof(char*). But such machines will
10057 * not likely have syscall implemented either, so who cares?
10059 while (++MARK <= SP) {
10060 if (SvNIOK(*MARK) || !i)
10061 a[i++] = SvIV(*MARK);
10063 a[i++] = (unsigned long)SvPVX(*MARK);
10069 DIE("Too many args to syscall");
10071 DIE("Too few args to syscall");
10073 retval = syscall(a[0]);
10076 retval = syscall(a[0],a[1]);
10079 retval = syscall(a[0],a[1],a[2]);
10082 retval = syscall(a[0],a[1],a[2],a[3]);
10085 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
10088 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
10091 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
10094 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
10098 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
10101 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
10104 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
10108 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
10112 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
10113 a[10],a[11],a[12]);
10116 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
10117 a[10],a[11],a[12],a[13]);
10119 #endif /* atarist */
10125 DIE(no_func, "syscall");