pp.c

   1 /***********************************************************
   2  *
   3  * $Header: /usr/src/local/lwall/perl5/RCS/pp.c, v 4.1 92/08/07 18:26:21 lwall Exp Locker: lwall $
   4  *
   5  * Description:
   6  *      Push/Pop code.
   7  *
   8  * Standards:
   9  *
  10  * Created:
  11  *      Mon Jun 15 16:45:59 1992
  12  *
  13  * Author:
  14  *      Larry Wall <lwall@netlabs.com>
  15  *
  16  * $Log:        pp.c, v $
  17  * Revision 4.1  92/08/07  18:26:21  lwall
  18  *
  19  *
  20  **********************************************************/
  21
  22 #include "EXTERN.h"
  23 #include "perl.h"
  24
  25 #ifdef HAS_SOCKET
  26 #include <sys/socket.h>
  27 #include <netdb.h>
  28 #ifndef ENOTSOCK
  29 #include <net/errno.h>
  30 #endif
  31 #endif
  32
  33 #ifdef HAS_SELECT
  34 #ifdef I_SYS_SELECT
  35 #ifndef I_SYS_TIME
  36 #include <sys/select.h>
  37 #endif
  38 #endif
  39 #endif
  40
  41 #ifdef HOST_NOT_FOUND
  42 extern int h_errno;
  43 #endif
  44
  45 #ifdef I_PWD
  46 #include <pwd.h>
  47 #endif
  48 #ifdef I_GRP
  49 #include <grp.h>
  50 #endif
  51 #ifdef I_UTIME
  52 #include <utime.h>
  53 #endif
  54 #ifdef I_FCNTL
  55 #include <fcntl.h>
  56 #endif
  57 #ifdef I_SYS_FILE
  58 #include <sys/file.h>
  59 #endif
  60
  61 #ifdef I_VARARGS
  62 #  include <varargs.h>
  63 #endif
  64
  65 /* Nothing. */
  66
  67 PP(pp_null)
  68 {
  69     return NORMAL;
  70 }
  71
  72 PP(pp_scalar)
  73 {
  74     return NORMAL;
  75 }
  76
  77 /* Pushy stuff. */
  78
  79 PP(pp_pushmark)
  80 {
  81     if (++markstack_ptr == markstack_max) {
  82         I32 oldmax = markstack_max - markstack;
  83         I32 newmax = oldmax * 3 / 2;
  84
  85         Renew(markstack, newmax, I32);
  86         markstack_ptr = markstack + oldmax;
  87         markstack_max = markstack + newmax;
  88     }
  89     *markstack_ptr = stack_sp - stack_base;
  90     return NORMAL;
  91 }
  92
  93 PP(pp_wantarray)
  94 {
  95     dSP;
  96     I32 cxix;
  97     EXTEND(SP, 1);
  98
  99     cxix = dopoptosub(cxstack_ix);
 100     if (cxix < 0)
 101         RETPUSHUNDEF;
 102
 103     if (cxstack[cxix].blk_gimme == G_ARRAY)
 104         RETPUSHYES;
 105     else
 106         RETPUSHNO;
 107 }
 108
 109 PP(pp_word)
 110 {
 111     DIE("PP_WORD");
 112 }
 113
 114 PP(pp_const)
 115 {
 116     dSP;
 117     XPUSHs(cSVOP->op_sv);
 118     RETURN;
 119 }
 120
 121 static void
 122 ucase(s,send)
 123 register char *s;
 124 register char *send;
 125 {
 126     while (s < send) {
 127         if (isLOWER(*s))
 128             *s = toupper(*s);
 129         s++;
 130     }
 131 }
 132
 133 static void
 134 lcase(s,send)
 135 register char *s;
 136 register char *send;
 137 {
 138     while (s < send) {
 139         if (isUPPER(*s))
 140             *s = tolower(*s);
 141         s++;
 142     }
 143 }
 144
 145 PP(pp_interp)
 146 {
 147     DIE("panic: pp_interp");
 148 }
 149
 150 PP(pp_gvsv)
 151 {
 152     dSP;
 153     EXTEND(sp,1);
 154     if (op->op_flags & OPf_LOCAL)
 155         PUSHs(save_scalar(cGVOP->op_gv));
 156     else
 157         PUSHs(GvSV(cGVOP->op_gv));
 158     RETURN;
 159 }
 160
 161 PP(pp_gv)
 162 {
 163     dSP;
 164     XPUSHs((SV*)cGVOP->op_gv);
 165     RETURN;
 166 }
 167
 168 PP(pp_pushre)
 169 {
 170     dSP;
 171     XPUSHs((SV*)op);
 172     RETURN;
 173 }
 174
 175 /* Translations. */
 176
 177 PP(pp_rv2gv)
 178 {
 179     dSP; dTOPss;
 180     if (SvTYPE(sv) == SVt_REF) {
 181         sv = (SV*)SvANY(sv);
 182         if (SvTYPE(sv) != SVt_PVGV)
 183             DIE("Not a glob reference");
 184     }
 185     else {
 186         if (SvTYPE(sv) != SVt_PVGV)
 187             sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
 188     }
 189     if (op->op_flags & OPf_LOCAL) {
 190         GP *ogp = GvGP(sv);
 191
 192         SSCHECK(3);
 193         SSPUSHPTR(sv);
 194         SSPUSHPTR(ogp);
 195         SSPUSHINT(SAVEt_GP);
 196
 197         if (op->op_flags & OPf_SPECIAL)
 198             GvGP(sv)->gp_refcnt++;              /* will soon be assigned */
 199         else {
 200             GP *gp;
 201             Newz(602,gp, 1, GP);
 202             GvGP(sv) = gp;
 203             GvREFCNT(sv) = 1;
 204             GvSV(sv) = NEWSV(72,0);
 205             GvLINE(sv) = curcop->cop_line;
 206             GvEGV(sv) = sv;
 207         }
 208     }
 209     SETs(sv);
 210     RETURN;
 211 }
 212
 213 PP(pp_sv2len)
 214 {
 215     dSP; dTARGET;
 216     dPOPss;
 217     PUSHi(sv_len(sv));
 218     RETURN;
 219 }
 220
 221 PP(pp_rv2sv)
 222 {
 223     dSP; dTOPss;
 224
 225     if (SvTYPE(sv) == SVt_REF) {
 226         sv = (SV*)SvANY(sv);
 227         switch (SvTYPE(sv)) {
 228         case SVt_PVAV:
 229         case SVt_PVHV:
 230         case SVt_PVCV:
 231             DIE("Not a scalar reference");
 232         }
 233     }
 234     else {
 235         if (SvTYPE(sv) != SVt_PVGV)
 236             sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
 237         sv = GvSV(sv);
 238     }
 239     if (op->op_flags & OPf_LOCAL)
 240         SETs(save_scalar((GV*)TOPs));
 241     else
 242         SETs(sv);
 243     RETURN;
 244 }
 245
 246 PP(pp_av2arylen)
 247 {
 248     dSP;
 249     AV *av = (AV*)TOPs;
 250     SV *sv = AvARYLEN(av);
 251     if (!sv) {
 252         AvARYLEN(av) = sv = NEWSV(0,0);
 253         sv_upgrade(sv, SVt_IV);
 254         sv_magic(sv, (SV*)av, '#', Nullch, 0);
 255     }
 256     SETs(sv);
 257     RETURN;
 258 }
 259
 260 PP(pp_rv2cv)
 261 {
 262     dSP;
 263     SV *sv;
 264     GV *gv;
 265     HV *stash;
 266     CV *cv = sv_2cv(TOPs, &stash, &gv, 0);
 267
 268     SETs((SV*)cv);
 269     RETURN;
 270 }
 271
 272 PP(pp_refgen)
 273 {
 274     dSP; dTOPss;
 275     SV* rv;
 276     if (!sv)
 277         RETSETUNDEF;
 278     rv = sv_mortalcopy(&sv_undef);
 279     sv_upgrade(rv, SVt_REF);
 280     SvANY(rv) = (void*)sv_ref(sv);
 281     SETs(rv);
 282     RETURN;
 283 }
 284
 285 PP(pp_ref)
 286 {
 287     dSP; dTARGET; dTOPss;
 288     char *pv;
 289
 290     if (SvTYPE(sv) != SVt_REF)
 291         RETSETUNDEF;
 292
 293     sv = (SV*)SvANY(sv);
 294     if (SvSTORAGE(sv) == 'O')
 295         pv = HvNAME(SvSTASH(sv));
 296     else {
 297         switch (SvTYPE(sv)) {
 298         case SVt_REF:           pv = "REF";             break;
 299         case SVt_NULL:
 300         case SVt_IV:
 301         case SVt_NV:
 302         case SVt_PV:
 303         case SVt_PVIV:
 304         case SVt_PVNV:
 305         case SVt_PVMG:
 306         case SVt_PVBM:          pv = "SCALAR";          break;
 307         case SVt_PVLV:          pv = "LVALUE";          break;
 308         case SVt_PVAV:          pv = "ARRAY";           break;
 309         case SVt_PVHV:          pv = "HASH";            break;
 310         case SVt_PVCV:          pv = "CODE";            break;
 311         case SVt_PVGV:          pv = "GLOB";            break;
 312         case SVt_PVFM:          pv = "FORMLINE";        break;
 313         default:                pv = "UNKNOWN";         break;
 314         }
 315     }
 316     SETp(pv, strlen(pv));
 317     RETURN;
 318 }
 319
 320 PP(pp_bless)
 321 {
 322     dSP; dTOPss;
 323     register SV* ref;
 324
 325     if (SvTYPE(sv) != SVt_REF)
 326         RETSETUNDEF;
 327
 328     ref = (SV*)SvANY(sv);
 329     if (SvSTORAGE(ref) && SvSTORAGE(ref) != 'O')
 330         DIE("Can't bless temporary scalar");
 331     SvSTORAGE(ref) = 'O';
 332     SvUPGRADE(ref, SVt_PVMG);
 333     SvSTASH(ref) = curcop->cop_stash;
 334     RETURN;
 335 }
 336
 337 /* Pushy I/O. */
 338
 339 PP(pp_backtick)
 340 {
 341     dSP; dTARGET;
 342     FILE *fp;
 343     char *tmps = POPp;
 344 #ifdef TAINT
 345     TAINT_PROPER("``");
 346 #endif
 347     fp = my_popen(tmps, "r");
 348     if (fp) {
 349         sv_setpv(TARG, "");     /* note that this preserves previous buffer */
 350         if (GIMME == G_SCALAR) {
 351             while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
 352                 /*SUPPRESS 530*/
 353                 ;
 354             XPUSHs(TARG);
 355         }
 356         else {
 357             SV *sv;
 358
 359             for (;;) {
 360                 sv = NEWSV(56, 80);
 361                 if (sv_gets(sv, fp, 0) == Nullch) {
 362                     sv_free(sv);
 363                     break;
 364                 }
 365                 XPUSHs(sv_2mortal(sv));
 366                 if (SvLEN(sv) - SvCUR(sv) > 20) {
 367                     SvLEN_set(sv, SvCUR(sv)+1);
 368                     Renew(SvPV(sv), SvLEN(sv), char);
 369                 }
 370             }
 371         }
 372         statusvalue = my_pclose(fp);
 373     }
 374     else {
 375         statusvalue = -1;
 376         if (GIMME == G_SCALAR)
 377             RETPUSHUNDEF;
 378     }
 379
 380     RETURN;
 381 }
 382
 383 OP *
 384 do_readline()
 385 {
 386     dSP; dTARGETSTACKED;
 387     register SV *sv;
 388     STRLEN tmplen;
 389     STRLEN offset;
 390     FILE *fp;
 391     register IO *io = GvIO(last_in_gv);
 392     register I32 type = op->op_type;
 393
 394     fp = Nullfp;
 395     if (io) {
 396         fp = io->ifp;
 397         if (!fp) {
 398             if (io->flags & IOf_ARGV) {
 399                 if (io->flags & IOf_START) {
 400                     io->flags &= ~IOf_START;
 401                     io->lines = 0;
 402                     if (av_len(GvAVn(last_in_gv)) < 0) {
 403                         SV *tmpstr = newSVpv("-", 1); /* assume stdin */
 404                         (void)av_push(GvAVn(last_in_gv), tmpstr);
 405                     }
 406                 }
 407                 fp = nextargv(last_in_gv);
 408                 if (!fp) { /* Note: fp != io->ifp */
 409                     (void)do_close(last_in_gv, FALSE); /* now it does*/
 410                     io->flags |= IOf_START;
 411                 }
 412             }
 413             else if (type == OP_GLOB) {
 414                 SV *tmpcmd = NEWSV(55, 0);
 415                 SV *tmpglob = POPs;
 416 #ifdef DOSISH
 417                 sv_setpv(tmpcmd, "perlglob ");
 418                 sv_catsv(tmpcmd, tmpglob);
 419                 sv_catpv(tmpcmd, " |");
 420 #else
 421 #ifdef CSH
 422                 sv_setpvn(tmpcmd, cshname, cshlen);
 423                 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
 424                 sv_catsv(tmpcmd, tmpglob);
 425                 sv_catpv(tmpcmd, "'|");
 426 #else
 427                 sv_setpv(tmpcmd, "echo ");
 428                 sv_catsv(tmpcmd, tmpglob);
 429                 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
 430 #endif /* !CSH */
 431 #endif /* !MSDOS */
 432                 (void)do_open(last_in_gv, SvPV(tmpcmd), SvCUR(tmpcmd));
 433                 fp = io->ifp;
 434                 sv_free(tmpcmd);
 435             }
 436         }
 437         else if (type == OP_GLOB)
 438             SP--;
 439     }
 440     if (!fp) {
 441         if (dowarn)
 442             warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
 443         if (GIMME == G_SCALAR)
 444             RETPUSHUNDEF;
 445         RETURN;
 446     }
 447     if (GIMME == G_ARRAY) {
 448         sv = sv_2mortal(NEWSV(57, 80));
 449         offset = 0;
 450     }
 451     else {
 452         sv = TARG;
 453         SvUPGRADE(sv, SVt_PV);
 454         tmplen = SvLEN(sv);     /* remember if already alloced */
 455         if (!tmplen)
 456             Sv_Grow(sv, 80);    /* try short-buffering it */
 457         if (type == OP_RCATLINE)
 458             offset = SvCUR(sv);
 459         else
 460             offset = 0;
 461     }
 462     for (;;) {
 463         if (!sv_gets(sv, fp, offset)) {
 464             clearerr(fp);
 465             if (io->flags & IOf_ARGV) {
 466                 fp = nextargv(last_in_gv);
 467                 if (fp)
 468                     continue;
 469                 (void)do_close(last_in_gv, FALSE);
 470                 io->flags |= IOf_START;
 471             }
 472             else if (type == OP_GLOB) {
 473                 (void)do_close(last_in_gv, FALSE);
 474             }
 475             if (GIMME == G_SCALAR)
 476                 RETPUSHUNDEF;
 477             RETURN;
 478         }
 479         io->lines++;
 480         XPUSHs(sv);
 481 #ifdef TAINT
 482         sv->sv_tainted = 1; /* Anything from the outside world...*/
 483 #endif
 484         if (type == OP_GLOB) {
 485             char *tmps;
 486
 487             if (SvCUR(sv) > 0)
 488                 SvCUR(sv)--;
 489             if (*SvEND(sv) == rschar)
 490                 *SvEND(sv) = '\0';
 491             else
 492                 SvCUR(sv)++;
 493             for (tmps = SvPV(sv); *tmps; tmps++)
 494                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
 495                     index("$&*(){}[]'\";\\|?<>~`", *tmps))
 496                         break;
 497             if (*tmps && stat(SvPV(sv), &statbuf) < 0) {
 498                 POPs;           /* Unmatched wildcard?  Chuck it... */
 499                 continue;
 500             }
 501         }
 502         if (GIMME == G_ARRAY) {
 503             if (SvLEN(sv) - SvCUR(sv) > 20) {
 504                 SvLEN_set(sv, SvCUR(sv)+1);
 505                 Renew(SvPV(sv), SvLEN(sv), char);
 506             }
 507             sv = sv_2mortal(NEWSV(58, 80));
 508             continue;
 509         }
 510         else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
 511             /* try to reclaim a bit of scalar space (only on 1st alloc) */
 512             if (SvCUR(sv) < 60)
 513                 SvLEN_set(sv, 80);
 514             else
 515                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
 516             Renew(SvPV(sv), SvLEN(sv), char);
 517         }
 518         RETURN;
 519     }
 520 }
 521
 522 PP(pp_glob)
 523 {
 524     OP *result;
 525     ENTER;
 526     SAVEINT(rschar);
 527     SAVEINT(rslen);
 528
 529     SAVESPTR(last_in_gv);       /* We don't want this to be permanent. */
 530     last_in_gv = (GV*)*stack_sp--;
 531
 532     rslen = 1;
 533 #ifdef DOSISH
 534     rschar = 0;
 535 #else
 536 #ifdef CSH
 537     rschar = 0;
 538 #else
 539     rschar = '\n';
 540 #endif  /* !CSH */
 541 #endif  /* !MSDOS */
 542     result = do_readline();
 543     LEAVE;
 544     return result;
 545 }
 546
 547 PP(pp_readline)
 548 {
 549     last_in_gv = (GV*)(*stack_sp--);
 550     return do_readline();
 551 }
 552
 553 PP(pp_indread)
 554 {
 555     last_in_gv = gv_fetchpv(SvPVnx(GvSV((GV*)(*stack_sp--))), TRUE);
 556     return do_readline();
 557 }
 558
 559 PP(pp_rcatline)
 560 {
 561     last_in_gv = cGVOP->op_gv;
 562     return do_readline();
 563 }
 564
 565 PP(pp_regcomp) {
 566     dSP;
 567     register PMOP *pm = (PMOP*)cLOGOP->op_other;
 568     register char *t;
 569     I32 global;
 570     SV *tmpstr;
 571     register REGEXP *rx = pm->op_pmregexp;
 572
 573     global = pm->op_pmflags & PMf_GLOBAL;
 574     tmpstr = POPs;
 575     t = SvPVn(tmpstr);
 576     if (!global && rx)
 577         regfree(rx);
 578     pm->op_pmregexp = Null(REGEXP*);    /* crucial if regcomp aborts */
 579     pm->op_pmregexp = regcomp(t, t+SvCUR(tmpstr),
 580         pm->op_pmflags & PMf_FOLD);
 581     if (!pm->op_pmregexp->prelen && curpm)
 582         pm = curpm;
 583     if (pm->op_pmflags & PMf_KEEP) {
 584         if (!(pm->op_pmflags & PMf_FOLD))
 585             scan_prefix(pm, pm->op_pmregexp->precomp,
 586                 pm->op_pmregexp->prelen);
 587         pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */
 588         hoistmust(pm);
 589         op->op_type = OP_NULL;
 590         op->op_ppaddr = ppaddr[OP_NULL];
 591         /* XXX delete push code */
 592     }
 593     RETURN;
 594 }
 595
 596 PP(pp_match)
 597 {
 598     dSP; dTARG;
 599     register PMOP *pm = cPMOP;
 600     register char *t;
 601     register char *s;
 602     char *strend;
 603     SV *tmpstr;
 604     char *myhint = hint;
 605     I32 global;
 606     I32 safebase;
 607     char *truebase;
 608     register REGEXP *rx = pm->op_pmregexp;
 609     I32 gimme = GIMME;
 610
 611     hint = Nullch;
 612     global = pm->op_pmflags & PMf_GLOBAL;
 613     safebase = (gimme == G_ARRAY) || global;
 614
 615     if (op->op_flags & OPf_STACKED)
 616         TARG = POPs;
 617     else {
 618         TARG = GvSV(defgv);
 619         EXTEND(SP,1);
 620     }
 621     s = SvPVn(TARG);
 622     strend = s + SvCUR(TARG);
 623     if (!s)
 624         DIE("panic: do_match");
 625
 626     if (pm->op_pmflags & PMf_USED) {
 627         if (gimme == G_ARRAY)
 628             RETURN;
 629         RETPUSHNO;
 630     }
 631
 632     if (!rx->prelen && curpm) {
 633         pm = curpm;
 634         rx = pm->op_pmregexp;
 635     }
 636     truebase = t = s;
 637 play_it_again:
 638     if (global && rx->startp[0]) {
 639         t = s = rx->endp[0];
 640         if (s == rx->startp[0])
 641             s++, t++;
 642         if (s > strend)
 643             goto nope;
 644     }
 645     if (myhint) {
 646         if (myhint < s || myhint > strend)
 647             DIE("panic: hint in do_match");
 648         s = myhint;
 649         if (rx->regback >= 0) {
 650             s -= rx->regback;
 651             if (s < t)
 652                 s = t;
 653         }
 654         else
 655             s = t;
 656     }
 657     else if (pm->op_pmshort) {
 658         if (pm->op_pmflags & PMf_SCANFIRST) {
 659             if (SvSCREAM(TARG)) {
 660                 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
 661                     goto nope;
 662                 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
 663                     goto nope;
 664                 else if (pm->op_pmflags & PMf_ALL)
 665                     goto yup;
 666             }
 667             else if (!(s = fbm_instr((unsigned char*)s,
 668               (unsigned char*)strend, pm->op_pmshort)))
 669                 goto nope;
 670             else if (pm->op_pmflags & PMf_ALL)
 671                 goto yup;
 672             if (s && rx->regback >= 0) {
 673                 ++BmUSEFUL(pm->op_pmshort);
 674                 s -= rx->regback;
 675                 if (s < t)
 676                     s = t;
 677             }
 678             else
 679                 s = t;
 680         }
 681         else if (!multiline) {
 682             if (*SvPV(pm->op_pmshort) != *s ||
 683               bcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) ) {
 684                 if (pm->op_pmflags & PMf_FOLD) {
 685                     if (ibcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) )
 686                         goto nope;
 687                 }
 688                 else
 689                     goto nope;
 690             }
 691         }
 692         if (--BmUSEFUL(pm->op_pmshort) < 0) {
 693             sv_free(pm->op_pmshort);
 694             pm->op_pmshort = Nullsv;    /* opt is being useless */
 695         }
 696     }
 697     if (!rx->nparens && !global) {
 698         gimme = G_SCALAR;                       /* accidental array context? */
 699         safebase = FALSE;
 700     }
 701     if (regexec(rx, s, strend, truebase, 0,
 702       SvSCREAM(TARG) ? TARG : Nullsv,
 703       safebase)) {
 704         curpm = pm;
 705         if (pm->op_pmflags & PMf_ONCE)
 706             pm->op_pmflags |= PMf_USED;
 707         goto gotcha;
 708     }
 709     else {
 710         if (global)
 711             rx->startp[0] = Nullch;
 712         if (gimme == G_ARRAY)
 713             RETURN;
 714         RETPUSHNO;
 715     }
 716     /*NOTREACHED*/
 717
 718   gotcha:
 719     if (gimme == G_ARRAY) {
 720         I32 iters, i, len;
 721
 722         iters = rx->nparens;
 723         if (global && !iters)
 724             i = 1;
 725         else
 726             i = 0;
 727         EXTEND(SP, iters + i);
 728         for (i = !i; i <= iters; i++) {
 729             PUSHs(sv_mortalcopy(&sv_no));
 730             /*SUPPRESS 560*/
 731             if (s = rx->startp[i]) {
 732                 len = rx->endp[i] - s;
 733                 if (len > 0)
 734                     sv_setpvn(*SP, s, len);
 735             }
 736         }
 737         if (global) {
 738             truebase = rx->subbeg;
 739             goto play_it_again;
 740         }
 741         RETURN;
 742     }
 743     else {
 744         RETPUSHYES;
 745     }
 746
 747 yup:
 748     ++BmUSEFUL(pm->op_pmshort);
 749     curpm = pm;
 750     if (pm->op_pmflags & PMf_ONCE)
 751         pm->op_pmflags |= PMf_USED;
 752     if (global) {
 753         rx->subbeg = t;
 754         rx->subend = strend;
 755         rx->startp[0] = s;
 756         rx->endp[0] = s + SvCUR(pm->op_pmshort);
 757         goto gotcha;
 758     }
 759     if (sawampersand) {
 760         char *tmps;
 761
 762         if (rx->subbase)
 763             Safefree(rx->subbase);
 764         tmps = rx->subbase = nsavestr(t, strend-t);
 765         rx->subbeg = tmps;
 766         rx->subend = tmps + (strend-t);
 767         tmps = rx->startp[0] = tmps + (s - t);
 768         rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
 769     }
 770     RETPUSHYES;
 771
 772 nope:
 773     rx->startp[0] = Nullch;
 774     if (pm->op_pmshort)
 775         ++BmUSEFUL(pm->op_pmshort);
 776     if (gimme == G_ARRAY)
 777         RETURN;
 778     RETPUSHNO;
 779 }
 780
 781 PP(pp_subst)
 782 {
 783     dSP; dTARG;
 784     register PMOP *pm = cPMOP;
 785     PMOP *rpm = pm;
 786     register SV *dstr;
 787     register char *s;
 788     char *strend;
 789     register char *m;
 790     char *c;
 791     register char *d;
 792     I32 clen;
 793     I32 iters = 0;
 794     I32 maxiters;
 795     register I32 i;
 796     bool once;
 797     char *orig;
 798     I32 safebase;
 799     register REGEXP *rx = pm->op_pmregexp;
 800
 801     if (pm->op_pmflags & PMf_CONST)     /* known replacement string? */
 802         dstr = POPs;
 803     if (op->op_flags & OPf_STACKED)
 804         TARG = POPs;
 805     else {
 806         TARG = GvSV(defgv);
 807         EXTEND(SP,1);
 808     }
 809     s = SvPVn(TARG);
 810     if (!pm || !s)
 811         DIE("panic: do_subst");
 812
 813     strend = s + SvCUR(TARG);
 814     maxiters = (strend - s) + 10;
 815
 816     if (!rx->prelen && curpm) {
 817         pm = curpm;
 818         rx = pm->op_pmregexp;
 819     }
 820     safebase = ((!rx || !rx->nparens) && !sawampersand);
 821     orig = m = s;
 822     if (hint) {
 823         if (hint < s || hint > strend)
 824             DIE("panic: hint in do_match");
 825         s = hint;
 826         hint = Nullch;
 827         if (rx->regback >= 0) {
 828             s -= rx->regback;
 829             if (s < m)
 830                 s = m;
 831         }
 832         else
 833             s = m;
 834     }
 835     else if (pm->op_pmshort) {
 836         if (pm->op_pmflags & PMf_SCANFIRST) {
 837             if (SvSCREAM(TARG)) {
 838                 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
 839                     goto nope;
 840                 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
 841                     goto nope;
 842             }
 843             else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
 844               pm->op_pmshort)))
 845                 goto nope;
 846             if (s && rx->regback >= 0) {
 847                 ++BmUSEFUL(pm->op_pmshort);
 848                 s -= rx->regback;
 849                 if (s < m)
 850                     s = m;
 851             }
 852             else
 853                 s = m;
 854         }
 855         else if (!multiline) {
 856             if (*SvPV(pm->op_pmshort) != *s ||
 857               bcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) ) {
 858                 if (pm->op_pmflags & PMf_FOLD) {
 859                     if (ibcmp(SvPV(pm->op_pmshort), s, pm->op_pmslen) )
 860                         goto nope;
 861                 }
 862                 else
 863                     goto nope;
 864             }
 865         }
 866         if (--BmUSEFUL(pm->op_pmshort) < 0) {
 867             sv_free(pm->op_pmshort);
 868             pm->op_pmshort = Nullsv;    /* opt is being useless */
 869         }
 870     }
 871     once = !(rpm->op_pmflags & PMf_GLOBAL);
 872     if (rpm->op_pmflags & PMf_CONST) {  /* known replacement string? */
 873         c = SvPVn(dstr);
 874         clen = SvCUR(dstr);
 875         if (clen <= rx->minlen) {
 876                                         /* can do inplace substitution */
 877             if (regexec(rx, s, strend, orig, 0,
 878               SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
 879                 if (rx->subbase)        /* oops, no we can't */
 880                     goto long_way;
 881                 d = s;
 882                 curpm = pm;
 883                 SvSCREAM_off(TARG);     /* disable possible screamer */
 884                 if (once) {
 885                     m = rx->startp[0];
 886                     d = rx->endp[0];
 887                     s = orig;
 888                     if (m - s > strend - d) {   /* faster to shorten from end */
 889                         if (clen) {
 890                             Copy(c, m, clen, char);
 891                             m += clen;
 892                         }
 893                         i = strend - d;
 894                         if (i > 0) {
 895                             Move(d, m, i, char);
 896                             m += i;
 897                         }
 898                         *m = '\0';
 899                         SvCUR_set(TARG, m - s);
 900                         SvNOK_off(TARG);
 901                         SvSETMAGIC(TARG);
 902                         PUSHs(&sv_yes);
 903                         RETURN;
 904                     }
 905                     /*SUPPRESS 560*/
 906                     else if (i = m - s) {       /* faster from front */
 907                         d -= clen;
 908                         m = d;
 909                         sv_chop(TARG, d-i);
 910                         s += i;
 911                         while (i--)
 912                             *--d = *--s;
 913                         if (clen)
 914                             Copy(c, m, clen, char);
 915                         SvNOK_off(TARG);
 916                         SvSETMAGIC(TARG);
 917                         PUSHs(&sv_yes);
 918                         RETURN;
 919                     }
 920                     else if (clen) {
 921                         d -= clen;
 922                         sv_chop(TARG, d);
 923                         Copy(c, d, clen, char);
 924                         SvNOK_off(TARG);
 925                         SvSETMAGIC(TARG);
 926                         PUSHs(&sv_yes);
 927                         RETURN;
 928                     }
 929                     else {
 930                         sv_chop(TARG, d);
 931                         SvNOK_off(TARG);
 932                         SvSETMAGIC(TARG);
 933                         PUSHs(&sv_yes);
 934                         RETURN;
 935                     }
 936                     /* NOTREACHED */
 937                 }
 938                 do {
 939                     if (iters++ > maxiters)
 940                         DIE("Substitution loop");
 941                     m = rx->startp[0];
 942                     /*SUPPRESS 560*/
 943                     if (i = m - s) {
 944                         if (s != d)
 945                             Move(s, d, i, char);
 946                         d += i;
 947                     }
 948                     if (clen) {
 949                         Copy(c, d, clen, char);
 950                         d += clen;
 951                     }
 952                     s = rx->endp[0];
 953                 } while (regexec(rx, s, strend, orig, s == m,
 954                     Nullsv, TRUE));     /* (don't match same null twice) */
 955                 if (s != d) {
 956                     i = strend - s;
 957                     SvCUR_set(TARG, d - SvPV(TARG) + i);
 958                     Move(s, d, i+1, char);              /* include the Null */
 959                 }
 960                 SvNOK_off(TARG);
 961                 SvSETMAGIC(TARG);
 962                 PUSHs(sv_2mortal(newSVnv((double)iters)));
 963                 RETURN;
 964             }
 965             PUSHs(&sv_no);
 966             RETURN;
 967         }
 968     }
 969     else
 970         c = Nullch;
 971     if (regexec(rx, s, strend, orig, 0,
 972       SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
 973     long_way:
 974         dstr = NEWSV(25, sv_len(TARG));
 975         sv_setpvn(dstr, m, s-m);
 976         curpm = pm;
 977         if (!c) {
 978             register CONTEXT *cx;
 979             PUSHSUBST(cx);
 980             RETURNOP(cPMOP->op_pmreplroot);
 981         }
 982         do {
 983             if (iters++ > maxiters)
 984                 DIE("Substitution loop");
 985             if (rx->subbase && rx->subbase != orig) {
 986                 m = s;
 987                 s = orig;
 988                 orig = rx->subbase;
 989                 s = orig + (m - s);
 990                 strend = s + (strend - m);
 991             }
 992             m = rx->startp[0];
 993             sv_catpvn(dstr, s, m-s);
 994             s = rx->endp[0];
 995             if (clen)
 996                 sv_catpvn(dstr, c, clen);
 997             if (once)
 998                 break;
 999         } while (regexec(rx, s, strend, orig, s == m, Nullsv,
1000             safebase));
1001         sv_catpvn(dstr, s, strend - s);
1002         sv_replace(TARG, dstr);
1003         SvNOK_off(TARG);
1004         SvSETMAGIC(TARG);
1005         PUSHs(sv_2mortal(newSVnv((double)iters)));
1006         RETURN;
1007     }
1008     PUSHs(&sv_no);
1009     RETURN;
1010
1011 nope:
1012     ++BmUSEFUL(pm->op_pmshort);
1013     PUSHs(&sv_no);
1014     RETURN;
1015 }
1016
1017 PP(pp_substcont)
1018 {
1019     dSP;
1020     register PMOP *pm = (PMOP*) cLOGOP->op_other;
1021     register CONTEXT *cx = &cxstack[cxstack_ix];
1022     register SV *dstr = cx->sb_dstr;
1023     register char *s = cx->sb_s;
1024     register char *m = cx->sb_m;
1025     char *orig = cx->sb_orig;
1026     register REGEXP *rx = pm->op_pmregexp;
1027
1028     if (cx->sb_iters++) {
1029         if (cx->sb_iters > cx->sb_maxiters)
1030             DIE("Substitution loop");
1031
1032         sv_catsv(dstr, POPs);
1033         if (rx->subbase)
1034             Safefree(rx->subbase);
1035         rx->subbase = cx->sb_subbase;
1036
1037         /* Are we done */
1038         if (cx->sb_once || !regexec(rx, s, cx->sb_strend, orig,
1039                                 s == m, Nullsv, cx->sb_safebase))
1040         {
1041             SV *targ = cx->sb_targ;
1042             sv_catpvn(dstr, s, cx->sb_strend - s);
1043             sv_replace(targ, dstr);
1044             SvNOK_off(targ);
1045             SvSETMAGIC(targ);
1046             PUSHs(sv_2mortal(newSVnv((double)(cx->sb_iters - 1))));
1047             POPSUBST(cx);
1048             RETURNOP(pm->op_next);
1049         }
1050     }
1051     if (rx->subbase && rx->subbase != orig) {
1052         m = s;
1053         s = orig;
1054         cx->sb_orig = orig = rx->subbase;
1055         s = orig + (m - s);
1056         cx->sb_strend = s + (cx->sb_strend - m);
1057     }
1058     cx->sb_m = m = rx->startp[0];
1059     sv_catpvn(dstr, s, m-s);
1060     cx->sb_s = rx->endp[0];
1061     cx->sb_subbase = rx->subbase;
1062
1063     rx->subbase = Nullch;       /* so recursion works */
1064     RETURNOP(pm->op_pmreplstart);
1065 }
1066
1067 PP(pp_trans)
1068 {
1069     dSP; dTARG;
1070     SV *sv;
1071
1072     if (op->op_flags & OPf_STACKED)
1073         sv = POPs;
1074     else {
1075         sv = GvSV(defgv);
1076         EXTEND(SP,1);
1077     }
1078     TARG = NEWSV(27,0);
1079     PUSHi(do_trans(sv, op));
1080     RETURN;
1081 }
1082
1083 /* Lvalue operators. */
1084
1085 PP(pp_sassign)
1086 {
1087     dSP; dPOPTOPssrl;
1088 #ifdef TAINT
1089     if (tainted && !lstr->sv_tainted)
1090         TAINT_NOT;
1091 #endif
1092     SvSetSV(rstr, lstr);
1093     SvSETMAGIC(rstr);
1094     SETs(rstr);
1095     RETURN;
1096 }
1097
1098 PP(pp_aassign)
1099 {
1100     dSP;
1101     SV **lastlelem = stack_sp;
1102     SV **lastrelem = stack_base + POPMARK;
1103     SV **firstrelem = stack_base + POPMARK + 1;
1104     SV **firstlelem = lastrelem + 1;
1105
1106     register SV **relem;
1107     register SV **lelem;
1108
1109     register SV *sv;
1110     register AV *ary;
1111
1112     HV *hash;
1113     I32 i;
1114
1115     delaymagic = DM_DELAY;              /* catch simultaneous items */
1116
1117     /* If there's a common identifier on both sides we have to take
1118      * special care that assigning the identifier on the left doesn't
1119      * clobber a value on the right that's used later in the list.
1120      */
1121     if (op->op_private & OPpASSIGN_COMMON) {
1122         for (relem = firstrelem; relem <= lastrelem; relem++) {
1123             /*SUPPRESS 560*/
1124             if (sv = *relem)
1125                 *relem = sv_mortalcopy(sv);
1126         }
1127     }
1128
1129     relem = firstrelem;
1130     lelem = firstlelem;
1131     ary = Null(AV*);
1132     hash = Null(HV*);
1133     while (lelem <= lastlelem) {
1134         sv = *lelem++;
1135         switch (SvTYPE(sv)) {
1136         case SVt_PVAV:
1137             ary = (AV*)sv;
1138             AvREAL_on(ary);
1139             AvFILL(ary) = -1;
1140             i = 0;
1141             while (relem <= lastrelem) {        /* gobble up all the rest */
1142                 sv = NEWSV(28,0);
1143                 if (*relem)
1144                     sv_setsv(sv,*relem);
1145                 *(relem++) = sv;
1146                 (void)av_store(ary,i++,sv);
1147             }
1148             break;
1149         case SVt_PVHV: {
1150                 char *tmps;
1151                 SV *tmpstr;
1152                 MAGIC* magic = 0;
1153                 I32 magictype;
1154
1155                 hash = (HV*)sv;
1156                 hv_clear(hash, TRUE);           /* wipe any dbm file too */
1157
1158                 while (relem < lastrelem) {     /* gobble up all the rest */
1159                     if (*relem)
1160                         sv = *(relem++);
1161                     else
1162                         sv = &sv_no, relem++;
1163                     tmps = SvPVn(sv);
1164                     tmpstr = NEWSV(29,0);
1165                     if (*relem)
1166                         sv_setsv(tmpstr,*relem);        /* value */
1167                     *(relem++) = tmpstr;
1168                     (void)hv_store(hash,tmps,SvCUR(sv),tmpstr,0);
1169                 }
1170             }
1171             break;
1172         default:
1173             if (SvREADONLY(sv)) {
1174                 if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
1175                     DIE(no_modify);
1176                 if (relem <= lastrelem)
1177                     relem++;
1178                 break;
1179             }
1180             if (relem <= lastrelem) {
1181                 sv_setsv(sv, *relem);
1182                 *(relem++) = sv;
1183             }
1184             else
1185                 sv_setsv(sv, &sv_undef);
1186             SvSETMAGIC(sv);
1187             break;
1188         }
1189     }
1190     if (delaymagic & ~DM_DELAY) {
1191         if (delaymagic & DM_UID) {
1192 #ifdef HAS_SETREUID
1193             (void)setreuid(uid,euid);
1194 #else /* not HAS_SETREUID */
1195 #ifdef HAS_SETRUID
1196             if ((delaymagic & DM_UID) == DM_RUID) {
1197                 (void)setruid(uid);
1198                 delaymagic =~ DM_RUID;
1199             }
1200 #endif /* HAS_SETRUID */
1201 #ifdef HAS_SETEUID
1202             if ((delaymagic & DM_UID) == DM_EUID) {
1203                 (void)seteuid(uid);
1204                 delaymagic =~ DM_EUID;
1205             }
1206 #endif /* HAS_SETEUID */
1207             if (delaymagic & DM_UID) {
1208                 if (uid != euid)
1209                     DIE("No setreuid available");
1210                 (void)setuid(uid);
1211             }
1212 #endif /* not HAS_SETREUID */
1213             uid = (int)getuid();
1214             euid = (int)geteuid();
1215         }
1216         if (delaymagic & DM_GID) {
1217 #ifdef HAS_SETREGID
1218             (void)setregid(gid,egid);
1219 #else /* not HAS_SETREGID */
1220 #ifdef HAS_SETRGID
1221             if ((delaymagic & DM_GID) == DM_RGID) {
1222                 (void)setrgid(gid);
1223                 delaymagic =~ DM_RGID;
1224             }
1225 #endif /* HAS_SETRGID */
1226 #ifdef HAS_SETEGID
1227             if ((delaymagic & DM_GID) == DM_EGID) {
1228                 (void)setegid(gid);
1229                 delaymagic =~ DM_EGID;
1230             }
1231 #endif /* HAS_SETEGID */
1232             if (delaymagic & DM_GID) {
1233                 if (gid != egid)
1234                     DIE("No setregid available");
1235                 (void)setgid(gid);
1236             }
1237 #endif /* not HAS_SETREGID */
1238             gid = (int)getgid();
1239             egid = (int)getegid();
1240         }
1241     }
1242     delaymagic = 0;
1243     if (GIMME == G_ARRAY) {
1244         if (ary || hash)
1245             SP = lastrelem;
1246         else
1247             SP = firstrelem + (lastlelem - firstlelem);
1248         RETURN;
1249     }
1250     else {
1251         dTARGET;
1252         SP = firstrelem;
1253         SETi(lastrelem - firstrelem + 1);
1254         RETURN;
1255     }
1256 }
1257
1258 PP(pp_schop)
1259 {
1260     dSP; dTARGET;
1261     SV *sv;
1262
1263     if (MAXARG < 1)
1264         sv = GvSV(defgv);
1265     else
1266         sv = POPs;
1267     do_chop(TARG, sv);
1268     PUSHTARG;
1269     RETURN;
1270 }
1271
1272 PP(pp_chop)
1273 {
1274     dSP; dMARK; dTARGET;
1275     while (SP > MARK)
1276         do_chop(TARG, POPs);
1277     PUSHTARG;
1278     RETURN;
1279 }
1280
1281 PP(pp_defined)
1282 {
1283     dSP;
1284     register SV* sv;
1285
1286     if (MAXARG < 1) {
1287         sv = GvSV(defgv);
1288         EXTEND(SP, 1);
1289     }
1290     else
1291         sv = POPs;
1292     if (!sv || !SvANY(sv))
1293         RETPUSHNO;
1294     switch (SvTYPE(sv)) {
1295     case SVt_PVAV:
1296         if (AvMAX(sv) >= 0)
1297             RETPUSHYES;
1298         break;
1299     case SVt_PVHV:
1300         if (HvARRAY(sv))
1301             RETPUSHYES;
1302         break;
1303     case SVt_PVCV:
1304         if (CvROOT(sv))
1305             RETPUSHYES;
1306         break;
1307     default:
1308         if (SvOK(sv))
1309             RETPUSHYES;
1310     }
1311     RETPUSHNO;
1312 }
1313
1314 PP(pp_undef)
1315 {
1316     dSP;
1317     SV *sv;
1318
1319     if (!op->op_private)
1320         RETPUSHUNDEF;
1321
1322     sv = POPs;
1323     if (SvREADONLY(sv))
1324         RETPUSHUNDEF;
1325
1326     switch (SvTYPE(sv)) {
1327     case SVt_NULL:
1328         break;
1329     case SVt_PVAV:
1330         av_undef((AV*)sv);
1331         break;
1332     case SVt_PVHV:
1333         hv_undef((HV*)sv);
1334         break;
1335     case SVt_PVCV: {
1336         CV *cv = (CV*)sv;
1337         op_free(CvROOT(cv));
1338         CvROOT(cv) = 0;
1339         break;
1340     }
1341     default:
1342         if (sv != GvSV(defgv)) {
1343             if (SvPOK(sv) && SvLEN(sv)) {
1344                 SvOOK_off(sv);
1345                 Safefree(SvPV(sv));
1346                 SvPV_set(sv, Nullch);
1347                 SvLEN_set(sv, 0);
1348             }
1349             SvOK_off(sv);
1350             SvSETMAGIC(sv);
1351         }
1352     }
1353
1354     RETPUSHUNDEF;
1355 }
1356
1357 PP(pp_study)
1358 {
1359     dSP; dTARGET;
1360     register unsigned char *s;
1361     register I32 pos;
1362     register I32 ch;
1363     register I32 *sfirst;
1364     register I32 *snext;
1365     I32 retval;
1366
1367     s = (unsigned char*)(SvPVn(TARG));
1368     pos = SvCUR(TARG);
1369     if (lastscream)
1370         SvSCREAM_off(lastscream);
1371     lastscream = TARG;
1372     if (pos <= 0) {
1373         retval = 0;
1374         goto ret;
1375     }
1376     if (pos > maxscream) {
1377         if (maxscream < 0) {
1378             maxscream = pos + 80;
1379             New(301, screamfirst, 256, I32);
1380             New(302, screamnext, maxscream, I32);
1381         }
1382         else {
1383             maxscream = pos + pos / 4;
1384             Renew(screamnext, maxscream, I32);
1385         }
1386     }
1387
1388     sfirst = screamfirst;
1389     snext = screamnext;
1390
1391     if (!sfirst || !snext)
1392         DIE("do_study: out of memory");
1393
1394     for (ch = 256; ch; --ch)
1395         *sfirst++ = -1;
1396     sfirst -= 256;
1397
1398     while (--pos >= 0) {
1399         ch = s[pos];
1400         if (sfirst[ch] >= 0)
1401             snext[pos] = sfirst[ch] - pos;
1402         else
1403             snext[pos] = -pos;
1404         sfirst[ch] = pos;
1405
1406         /* If there were any case insensitive searches, we must assume they
1407          * all are.  This speeds up insensitive searches much more than
1408          * it slows down sensitive ones.
1409          */
1410         if (sawi)
1411             sfirst[fold[ch]] = pos;
1412     }
1413
1414     SvSCREAM_on(TARG);
1415     retval = 1;
1416   ret:
1417     XPUSHs(sv_2mortal(newSVnv((double)retval)));
1418     RETURN;
1419 }
1420
1421 PP(pp_preinc)
1422 {
1423     dSP;
1424     sv_inc(TOPs);
1425     SvSETMAGIC(TOPs);
1426     return NORMAL;
1427 }
1428
1429 PP(pp_predec)
1430 {
1431     dSP;
1432     sv_dec(TOPs);
1433     SvSETMAGIC(TOPs);
1434     return NORMAL;
1435 }
1436
1437 PP(pp_postinc)
1438 {
1439     dSP; dTARGET;
1440     sv_setsv(TARG, TOPs);
1441     sv_inc(TOPs);
1442     SvSETMAGIC(TOPs);
1443     SETs(TARG);
1444     return NORMAL;
1445 }
1446
1447 PP(pp_postdec)
1448 {
1449     dSP; dTARGET;
1450     sv_setsv(TARG, TOPs);
1451     sv_dec(TOPs);
1452     SvSETMAGIC(TOPs);
1453     SETs(TARG);
1454     return NORMAL;
1455 }
1456
1457 /* Ordinary operators. */
1458
1459 PP(pp_pow)
1460 {
1461     dSP; dATARGET; dPOPTOPnnrl;
1462     SETn( pow( left, right) );
1463     RETURN;
1464 }
1465
1466 PP(pp_multiply)
1467 {
1468     dSP; dATARGET; dPOPTOPnnrl;
1469     SETn( left * right );
1470     RETURN;
1471 }
1472
1473 PP(pp_divide)
1474 {
1475     dSP; dATARGET; dPOPnv;
1476     if (value == 0.0)
1477         DIE("Illegal division by zero");
1478 #ifdef SLOPPYDIVIDE
1479     /* insure that 20./5. == 4. */
1480     {
1481         double x;
1482         I32    k;
1483         x =  POPn;
1484         if ((double)(I32)x     == x &&
1485             (double)(I32)value == value &&
1486             (k = (I32)x/(I32)value)*(I32)value == (I32)x) {
1487             value = k;
1488         } else {
1489             value = x/value;
1490         }
1491     }
1492 #else
1493     value = POPn / value;
1494 #endif
1495     PUSHn( value );
1496     RETURN;
1497 }
1498
1499 PP(pp_modulo)
1500 {
1501     dSP; dATARGET;
1502     register unsigned long tmpulong;
1503     register long tmplong;
1504     I32 value;
1505
1506     tmpulong = (unsigned long) POPn;
1507     if (tmpulong == 0L)
1508         DIE("Illegal modulus zero");
1509     value = TOPn;
1510     if (value >= 0.0)
1511         value = (I32)(((unsigned long)value) % tmpulong);
1512     else {
1513         tmplong = (long)value;
1514         value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
1515     }
1516     SETi(value);
1517     RETURN;
1518 }
1519
1520 PP(pp_repeat)
1521 {
1522     dSP; dATARGET;
1523     register I32 count = POPi;
1524     if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
1525         dMARK;
1526         I32 items = SP - MARK;
1527         I32 max;
1528
1529         max = items * count;
1530         MEXTEND(MARK, max);
1531         if (count > 1) {
1532             while (SP > MARK) {
1533                 if (*SP)
1534                     SvTEMP_off((*SP));
1535                 SP--;
1536             }
1537             MARK++;
1538             repeatcpy(MARK + items, MARK, items * sizeof(SV*), count - 1);
1539         }
1540         SP += max;
1541     }
1542     else {      /* Note: mark already snarfed by pp_list */
1543         SV *tmpstr;
1544         char *tmps;
1545
1546         tmpstr = POPs;
1547         SvSetSV(TARG, tmpstr);
1548         if (count >= 1) {
1549             tmpstr = NEWSV(50, 0);
1550             tmps = SvPVn(TARG);
1551             sv_setpvn(tmpstr, tmps, SvCUR(TARG));
1552             tmps = SvPVn(tmpstr);       /* force to be string */
1553             SvGROW(TARG, (count * SvCUR(TARG)) + 1);
1554             repeatcpy(SvPV(TARG), tmps, SvCUR(tmpstr), count);
1555             SvCUR(TARG) *= count;
1556             *SvEND(TARG) = '\0';
1557             SvNOK_off(TARG);
1558             sv_free(tmpstr);
1559         }
1560         else {
1561             if (dowarn && SvPOK(SP[1]) && !looks_like_number(SP[1]))
1562                 warn("Right operand of x is not numeric");
1563             sv_setsv(TARG, &sv_no);
1564         }
1565         PUSHTARG;
1566     }
1567     RETURN;
1568 }
1569
1570 PP(pp_add)
1571 {
1572     dSP; dATARGET; dPOPTOPnnrl;
1573     SETn( left + right );
1574     RETURN;
1575 }
1576
1577 PP(pp_intadd)
1578 {
1579     dSP; dATARGET; dPOPTOPiirl;
1580     SETi( left + right );
1581     RETURN;
1582 }
1583
1584 PP(pp_subtract)
1585 {
1586     dSP; dATARGET; dPOPTOPnnrl;
1587     SETn( left - right );
1588     RETURN;
1589 }
1590
1591 PP(pp_concat)
1592 {
1593     dSP; dATARGET; dPOPTOPssrl;
1594     SvSetSV(TARG, lstr);
1595     sv_catsv(TARG, rstr);
1596     SETTARG;
1597     RETURN;
1598 }
1599
1600 PP(pp_left_shift)
1601 {
1602     dSP; dATARGET;
1603     I32 anum = POPi;
1604     double value = TOPn;
1605     SETi( U_L(value) << anum );
1606     RETURN;
1607 }
1608
1609 PP(pp_right_shift)
1610 {
1611     dSP; dATARGET;
1612     I32 anum = POPi;
1613     double value = TOPn;
1614     SETi( U_L(value) >> anum );
1615     RETURN;
1616 }
1617
1618 PP(pp_lt)
1619 {
1620     dSP; dPOPnv;
1621     SETs((TOPn < value) ? &sv_yes : &sv_no);
1622     RETURN;
1623 }
1624
1625 PP(pp_gt)
1626 {
1627     dSP; dPOPnv;
1628     SETs((TOPn > value) ? &sv_yes : &sv_no);
1629     RETURN;
1630 }
1631
1632 PP(pp_le)
1633 {
1634     dSP; dPOPnv;
1635     SETs((TOPn <= value) ? &sv_yes : &sv_no);
1636     RETURN;
1637 }
1638
1639 PP(pp_ge)
1640 {
1641     dSP; dPOPnv;
1642     SETs((TOPn >= value) ? &sv_yes : &sv_no);
1643     RETURN;
1644 }
1645
1646 PP(pp_eq)
1647 {
1648     dSP; double value;
1649
1650     if (dowarn) {
1651         if ((!SvNIOK(SP[ 0]) && !looks_like_number(SP[ 0])) ||
1652             (!SvNIOK(SP[-1]) && !looks_like_number(SP[-1])) )
1653             warn("Possible use of == on string value");
1654     }
1655
1656     value = POPn;
1657     SETs((TOPn == value) ? &sv_yes : &sv_no);
1658     RETURN;
1659 }
1660
1661 PP(pp_ne)
1662 {
1663     dSP; dPOPnv;
1664     SETs((TOPn != value) ? &sv_yes : &sv_no);
1665     RETURN;
1666 }
1667
1668 PP(pp_ncmp)
1669 {
1670     dSP; dTARGET; dPOPTOPnnrl;
1671     I32 value;
1672
1673     if (left > right)
1674         value = 1;
1675     else if (left < right)
1676         value = -1;
1677     else
1678         value = 0;
1679     SETi(value);
1680     RETURN;
1681 }
1682
1683 PP(pp_slt)
1684 {
1685     dSP; dPOPTOPssrl;
1686     SETs( sv_cmp(lstr, rstr) < 0 ? &sv_yes : &sv_no );
1687     RETURN;
1688 }
1689
1690 PP(pp_sgt)
1691 {
1692     dSP; dPOPTOPssrl;
1693     SETs( sv_cmp(lstr, rstr) > 0 ? &sv_yes : &sv_no );
1694     RETURN;
1695 }
1696
1697 PP(pp_sle)
1698 {
1699     dSP; dPOPTOPssrl;
1700     SETs( sv_cmp(lstr, rstr) <= 0 ? &sv_yes : &sv_no );
1701     RETURN;
1702 }
1703
1704 PP(pp_sge)
1705 {
1706     dSP; dPOPTOPssrl;
1707     SETs( sv_cmp(lstr, rstr) >= 0 ? &sv_yes : &sv_no );
1708     RETURN;
1709 }
1710
1711 PP(pp_seq)
1712 {
1713     dSP; dPOPTOPssrl;
1714     SETs( sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
1715     RETURN;
1716 }
1717
1718 PP(pp_sne)
1719 {
1720     dSP; dPOPTOPssrl;
1721     SETs( !sv_eq(lstr, rstr) ? &sv_yes : &sv_no );
1722     RETURN;
1723 }
1724
1725 PP(pp_scmp)
1726 {
1727     dSP; dTARGET;
1728     dPOPTOPssrl;
1729     SETi( sv_cmp(lstr, rstr) );
1730     RETURN;
1731 }
1732
1733 PP(pp_bit_and)
1734 {
1735     dSP; dATARGET; dPOPTOPssrl;
1736     if (SvNIOK(lstr) || SvNIOK(rstr)) {
1737         I32 value = SvIVn(lstr);
1738         value = value & SvIVn(rstr);
1739         SETi(value);
1740     }
1741     else {
1742         do_vop(op->op_type, TARG, lstr, rstr);
1743         SETTARG;
1744     }
1745     RETURN;
1746 }
1747
1748 PP(pp_xor)
1749 {
1750     dSP; dATARGET; dPOPTOPssrl;
1751     if (SvNIOK(lstr) || SvNIOK(rstr)) {
1752         I32 value = SvIVn(lstr);
1753         value = value ^ SvIVn(rstr);
1754         SETi(value);
1755     }
1756     else {
1757         do_vop(op->op_type, TARG, lstr, rstr);
1758         SETTARG;
1759     }
1760     RETURN;
1761 }
1762
1763 PP(pp_bit_or)
1764 {
1765     dSP; dATARGET; dPOPTOPssrl;
1766     if (SvNIOK(lstr) || SvNIOK(rstr)) {
1767         I32 value = SvIVn(lstr);
1768         value = value | SvIVn(rstr);
1769         SETi(value);
1770     }
1771     else {
1772         do_vop(op->op_type, TARG, lstr, rstr);
1773         SETTARG;
1774     }
1775     RETURN;
1776 }
1777
1778 PP(pp_negate)
1779 {
1780     dSP; dTARGET;
1781     SETn(-TOPn);
1782     RETURN;
1783 }
1784
1785 PP(pp_not)
1786 {
1787     *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
1788     return NORMAL;
1789 }
1790
1791 PP(pp_complement)
1792 {
1793     dSP; dTARGET; dTOPss;
1794     register I32 anum;
1795
1796     if (SvNIOK(sv)) {
1797         SETi(  ~SvIVn(sv) );
1798     }
1799     else {
1800         register char *tmps;
1801         register long *tmpl;
1802
1803         SvSetSV(TARG, sv);
1804         tmps = SvPVn(TARG);
1805         anum = SvCUR(TARG);
1806 #ifdef LIBERAL
1807         for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1808             *tmps = ~*tmps;
1809         tmpl = (long*)tmps;
1810         for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1811             *tmpl = ~*tmpl;
1812         tmps = (char*)tmpl;
1813 #endif
1814         for ( ; anum > 0; anum--, tmps++)
1815             *tmps = ~*tmps;
1816
1817         SETs(TARG);
1818     }
1819     RETURN;
1820 }
1821
1822 /* High falutin' math. */
1823
1824 PP(pp_atan2)
1825 {
1826     dSP; dTARGET; dPOPTOPnnrl;
1827     SETn(atan2(left, right));
1828     RETURN;
1829 }
1830
1831 PP(pp_sin)
1832 {
1833     dSP; dTARGET;
1834     double value;
1835     if (MAXARG < 1)
1836         value = SvNVnx(GvSV(defgv));
1837     else
1838         value = POPn;
1839     value = sin(value);
1840     XPUSHn(value);
1841     RETURN;
1842 }
1843
1844 PP(pp_cos)
1845 {
1846     dSP; dTARGET;
1847     double value;
1848     if (MAXARG < 1)
1849         value = SvNVnx(GvSV(defgv));
1850     else
1851         value = POPn;
1852     value = cos(value);
1853     XPUSHn(value);
1854     RETURN;
1855 }
1856
1857 PP(pp_rand)
1858 {
1859     dSP; dTARGET;
1860     double value;
1861     if (MAXARG < 1)
1862         value = 1.0;
1863     else
1864         value = POPn;
1865     if (value == 0.0)
1866         value = 1.0;
1867 #if RANDBITS == 31
1868     value = rand() * value / 2147483648.0;
1869 #else
1870 #if RANDBITS == 16
1871     value = rand() * value / 65536.0;
1872 #else
1873 #if RANDBITS == 15
1874     value = rand() * value / 32768.0;
1875 #else
1876     value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1877 #endif
1878 #endif
1879 #endif
1880     XPUSHn(value);
1881     RETURN;
1882 }
1883
1884 PP(pp_srand)
1885 {
1886     dSP;
1887     I32 anum;
1888     time_t when;
1889
1890     if (MAXARG < 1) {
1891         (void)time(&when);
1892         anum = when;
1893     }
1894     else
1895         anum = POPi;
1896     (void)srand(anum);
1897     EXTEND(SP, 1);
1898     RETPUSHYES;
1899 }
1900
1901 PP(pp_exp)
1902 {
1903     dSP; dTARGET;
1904     double value;
1905     if (MAXARG < 1)
1906         value = SvNVnx(GvSV(defgv));
1907     else
1908         value = POPn;
1909     value = exp(value);
1910     XPUSHn(value);
1911     RETURN;
1912 }
1913
1914 PP(pp_log)
1915 {
1916     dSP; dTARGET;
1917     double value;
1918     if (MAXARG < 1)
1919         value = SvNVnx(GvSV(defgv));
1920     else
1921         value = POPn;
1922     if (value <= 0.0)
1923         DIE("Can't take log of %g\n", value);
1924     value = log(value);
1925     XPUSHn(value);
1926     RETURN;
1927 }
1928
1929 PP(pp_sqrt)
1930 {
1931     dSP; dTARGET;
1932     double value;
1933     if (MAXARG < 1)
1934         value = SvNVnx(GvSV(defgv));
1935     else
1936         value = POPn;
1937     if (value < 0.0)
1938         DIE("Can't take sqrt of %g\n", value);
1939     value = sqrt(value);
1940     XPUSHn(value);
1941     RETURN;
1942 }
1943
1944 PP(pp_int)
1945 {
1946     dSP; dTARGET;
1947     double value;
1948     if (MAXARG < 1)
1949         value = SvNVnx(GvSV(defgv));
1950     else
1951         value = POPn;
1952     if (value >= 0.0)
1953         (void)modf(value, &value);
1954     else {
1955         (void)modf(-value, &value);
1956         value = -value;
1957     }
1958     XPUSHn(value);
1959     RETURN;
1960 }
1961
1962 PP(pp_hex)
1963 {
1964     dSP; dTARGET;
1965     char *tmps;
1966     I32 argtype;
1967
1968     if (MAXARG < 1)
1969         tmps = SvPVnx(GvSV(defgv));
1970     else
1971         tmps = POPp;
1972     XPUSHi( scan_hex(tmps, 99, &argtype) );
1973     RETURN;
1974 }
1975
1976 PP(pp_oct)
1977 {
1978     dSP; dTARGET;
1979     I32 value;
1980     I32 argtype;
1981     char *tmps;
1982
1983     if (MAXARG < 1)
1984         tmps = SvPVnx(GvSV(defgv));
1985     else
1986         tmps = POPp;
1987     while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
1988         tmps++;
1989     if (*tmps == 'x')
1990         value = (I32)scan_hex(++tmps, 99, &argtype);
1991     else
1992         value = (I32)scan_oct(tmps, 99, &argtype);
1993     XPUSHi(value);
1994     RETURN;
1995 }
1996
1997 /* String stuff. */
1998
1999 PP(pp_length)
2000 {
2001     dSP; dTARGET;
2002     if (MAXARG < 1) {
2003         XPUSHi( sv_len(GvSV(defgv)) );
2004     }
2005     else
2006         SETi( sv_len(TOPs) );
2007     RETURN;
2008 }
2009
2010 PP(pp_substr)
2011 {
2012     dSP; dTARGET;
2013     SV *sv;
2014     I32 len;
2015     I32 curlen;
2016     I32 pos;
2017     I32 rem;
2018     I32 lvalue = op->op_flags & OPf_LVAL;
2019     char *tmps;
2020
2021     if (MAXARG > 2)
2022         len = POPi;
2023     pos = POPi - arybase;
2024     sv = POPs;
2025     tmps = SvPVn(sv);           /* force conversion to string */
2026     curlen = SvCUR(sv);
2027     if (pos < 0)
2028         pos += curlen + arybase;
2029     if (pos < 0 || pos > curlen)
2030         sv_setpvn(TARG, "", 0);
2031     else {
2032         if (MAXARG < 3)
2033             len = curlen;
2034         if (len < 0)
2035             len = 0;
2036         tmps += pos;
2037         rem = curlen - pos;     /* rem=how many bytes left*/
2038         if (rem > len)
2039             rem = len;
2040         sv_setpvn(TARG, tmps, rem);
2041         if (lvalue) {                   /* it's an lvalue! */
2042             LvTYPE(TARG) = 's';
2043             LvTARG(TARG) = sv;
2044             LvTARGOFF(TARG) = tmps - SvPVn(sv);
2045             LvTARGLEN(TARG) = rem;
2046         }
2047     }
2048     PUSHs(TARG);                /* avoid SvSETMAGIC here */
2049     RETURN;
2050 }
2051
2052 PP(pp_vec)
2053 {
2054     dSP; dTARGET;
2055     register I32 size = POPi;
2056     register I32 offset = POPi;
2057     register SV *src = POPs;
2058     I32 lvalue = op->op_flags & OPf_LVAL;
2059     unsigned char *s = (unsigned char*)SvPVn(src);
2060     unsigned long retnum;
2061     I32 len;
2062
2063     offset *= size;             /* turn into bit offset */
2064     len = (offset + size + 7) / 8;
2065     if (offset < 0 || size < 1)
2066         retnum = 0;
2067     else if (!lvalue && len > SvCUR(src))
2068         retnum = 0;
2069     else {
2070         if (len > SvCUR(src)) {
2071             SvGROW(src, len);
2072             (void)memzero(SvPV(src) + SvCUR(src), len - SvCUR(src));
2073             SvCUR_set(src, len);
2074         }
2075         s = (unsigned char*)SvPVn(src);
2076         if (size < 8)
2077             retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2078         else {
2079             offset >>= 3;
2080             if (size == 8)
2081                 retnum = s[offset];
2082             else if (size == 16)
2083                 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2084             else if (size == 32)
2085                 retnum = ((unsigned long) s[offset] << 24) +
2086                         ((unsigned long) s[offset + 1] << 16) +
2087                         (s[offset + 2] << 8) + s[offset+3];
2088         }
2089
2090         if (lvalue) {                      /* it's an lvalue! */
2091             LvTYPE(TARG) = 'v';
2092             LvTARG(TARG) = src;
2093             LvTARGOFF(TARG) = offset;
2094             LvTARGLEN(TARG) = size;
2095         }
2096     }
2097
2098     sv_setiv(TARG, (I32)retnum);
2099     PUSHs(TARG);
2100     RETURN;
2101 }
2102
2103 PP(pp_index)
2104 {
2105     dSP; dTARGET;
2106     SV *big;
2107     SV *little;
2108     I32 offset;
2109     I32 retval;
2110     char *tmps;
2111     char *tmps2;
2112
2113     if (MAXARG < 3)
2114         offset = 0;
2115     else
2116         offset = POPi - arybase;
2117     little = POPs;
2118     big = POPs;
2119     tmps = SvPVn(big);
2120     if (offset < 0)
2121         offset = 0;
2122     else if (offset > SvCUR(big))
2123         offset = SvCUR(big);
2124     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2125       (unsigned char*)tmps + SvCUR(big), little)))
2126         retval = -1 + arybase;
2127     else
2128         retval = tmps2 - tmps + arybase;
2129     PUSHi(retval);
2130     RETURN;
2131 }
2132
2133 PP(pp_rindex)
2134 {
2135     dSP; dTARGET;
2136     SV *big;
2137     SV *little;
2138     SV *offstr;
2139     I32 offset;
2140     I32 retval;
2141     char *tmps;
2142     char *tmps2;
2143
2144     if (MAXARG == 3)
2145         offstr = POPs;
2146     little = POPs;
2147     big = POPs;
2148     tmps2 = SvPVn(little);
2149     tmps = SvPVn(big);
2150     if (MAXARG < 3)
2151         offset = SvCUR(big);
2152     else
2153         offset = SvIVn(offstr) - arybase + SvCUR(little);
2154     if (offset < 0)
2155         offset = 0;
2156     else if (offset > SvCUR(big))
2157         offset = SvCUR(big);
2158     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2159                           tmps2, tmps2 + SvCUR(little))))
2160         retval = -1 + arybase;
2161     else
2162         retval = tmps2 - tmps + arybase;
2163     PUSHi(retval);
2164     RETURN;
2165 }
2166
2167 PP(pp_sprintf)
2168 {
2169     dSP; dMARK; dORIGMARK; dTARGET;
2170     do_sprintf(TARG, SP-MARK, MARK+1);
2171     SP = ORIGMARK;
2172     PUSHTARG;
2173     RETURN;
2174 }
2175
2176 static void
2177 doparseform(sv)
2178 SV *sv;
2179 {
2180     register char *s = SvPVn(sv);
2181     register char *send = s + SvCUR(sv);
2182     register char *base;
2183     register I32 skipspaces = 0;
2184     bool noblank;
2185     bool repeat;
2186     bool postspace = FALSE;
2187     U16 *fops;
2188     register U16 *fpc;
2189     U16 *linepc;
2190     register I32 arg;
2191     bool ischop;
2192
2193     New(804, fops, send - s, U16);      /* Almost certainly too long... */
2194     fpc = fops;
2195
2196     if (s < send) {
2197         linepc = fpc;
2198         *fpc++ = FF_LINEMARK;
2199         noblank = repeat = FALSE;
2200         base = s;
2201     }
2202
2203     while (s <= send) {
2204         switch (*s++) {
2205         default:
2206             skipspaces = 0;
2207             continue;
2208
2209         case '~':
2210             if (*s == '~') {
2211                 repeat = TRUE;
2212                 *s = ' ';
2213             }
2214             noblank = TRUE;
2215             s[-1] = ' ';
2216             /* FALL THROUGH */
2217         case ' ': case '\t':
2218             skipspaces++;
2219             continue;
2220
2221         case '\n': case 0:
2222             arg = s - base;
2223             skipspaces++;
2224             arg -= skipspaces;
2225             if (arg) {
2226                 if (postspace) {
2227                     *fpc++ = FF_SPACE;
2228                     postspace = FALSE;
2229                 }
2230                 *fpc++ = FF_LITERAL;
2231                 *fpc++ = arg;
2232             }
2233             if (s <= send)
2234                 skipspaces--;
2235             if (skipspaces) {
2236                 *fpc++ = FF_SKIP;
2237                 *fpc++ = skipspaces;
2238             }
2239             skipspaces = 0;
2240             if (s <= send)
2241                 *fpc++ = FF_NEWLINE;
2242             if (noblank) {
2243                 *fpc++ = FF_BLANK;
2244                 if (repeat)
2245                     arg = fpc - linepc + 1;
2246                 else
2247                     arg = 0;
2248                 *fpc++ = arg;
2249             }
2250             if (s < send) {
2251                 linepc = fpc;
2252                 *fpc++ = FF_LINEMARK;
2253                 noblank = repeat = FALSE;
2254                 base = s;
2255             }
2256             else
2257                 s++;
2258             continue;
2259
2260         case '@':
2261         case '^':
2262             ischop = s[-1] == '^';
2263
2264             if (postspace) {
2265                 *fpc++ = FF_SPACE;
2266                 postspace = FALSE;
2267             }
2268             arg = (s - base) - 1;
2269             if (arg) {
2270                 *fpc++ = FF_LITERAL;
2271                 *fpc++ = arg;
2272             }
2273
2274             base = s - 1;
2275             *fpc++ = FF_FETCH;
2276             if (*s == '*') {
2277                 s++;
2278                 *fpc++ = 0;
2279                 *fpc++ = FF_LINEGLOB;
2280             }
2281             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2282                 arg = ischop ? 512 : 0;
2283                 base = s - 1;
2284                 while (*s == '#')
2285                     s++;
2286                 if (*s == '.') {
2287                     char *f;
2288                     s++;
2289                     f = s;
2290                     while (*s == '#')
2291                         s++;
2292                     arg |= 256 + (s - f);
2293                 }
2294                 *fpc++ = s - base;              /* fieldsize for FETCH */
2295                 *fpc++ = FF_DECIMAL;
2296                 *fpc++ = arg;
2297             }
2298             else {
2299                 I32 prespace = 0;
2300                 bool ismore = FALSE;
2301
2302                 if (*s == '>') {
2303                     while (*++s == '>') ;
2304                     prespace = FF_SPACE;
2305                 }
2306                 else if (*s == '|') {
2307                     while (*++s == '|') ;
2308                     prespace = FF_HALFSPACE;
2309                     postspace = TRUE;
2310                 }
2311                 else {
2312                     if (*s == '<')
2313                         while (*++s == '<') ;
2314                     postspace = TRUE;
2315                 }
2316                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2317                     s += 3;
2318                     ismore = TRUE;
2319                 }
2320                 *fpc++ = s - base;              /* fieldsize for FETCH */
2321
2322                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2323
2324                 if (prespace)
2325                     *fpc++ = prespace;
2326                 *fpc++ = FF_ITEM;
2327                 if (ismore)
2328                     *fpc++ = FF_MORE;
2329                 if (ischop)
2330                     *fpc++ = FF_CHOP;
2331             }
2332             base = s;
2333             skipspaces = 0;
2334             continue;
2335         }
2336     }
2337     *fpc++ = FF_END;
2338
2339     arg = fpc - fops;
2340     SvGROW(sv, SvCUR(sv) + arg * sizeof(U16) + 4);
2341
2342     s = SvPV(sv) + SvCUR(sv);
2343     s += 2 + (SvCUR(sv) & 1);
2344
2345     Copy(fops, s, arg, U16);
2346     Safefree(fops);
2347 }
2348
2349 PP(pp_formline)
2350 {
2351     dSP; dMARK; dORIGMARK;
2352     register SV *form = *++MARK;
2353     register U16 *fpc;
2354     register char *t;
2355     register char *f;
2356     register char *s;
2357     register char *send;
2358     register I32 arg;
2359     register SV *sv;
2360     I32 itemsize;
2361     I32 fieldsize;
2362     I32 lines = 0;
2363     bool chopspace = (index(chopset, ' ') != Nullch);
2364     char *chophere;
2365     char *linemark;
2366     char *formmark;
2367     SV **markmark;
2368     double value;
2369     bool gotsome;
2370
2371     if (!SvCOMPILED(form))
2372         doparseform(form);
2373
2374     SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
2375     t = SvPVn(formtarget);
2376     t += SvCUR(formtarget);
2377     f = SvPVn(form);
2378
2379     s = f + SvCUR(form);
2380     s += 2 + (SvCUR(form) & 1);
2381
2382     fpc = (U16*)s;
2383
2384     for (;;) {
2385         DEBUG_f( {
2386             char *name = "???";
2387             arg = -1;
2388             switch (*fpc) {
2389             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
2390             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
2391             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
2392             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
2393             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
2394
2395             case FF_CHECKNL:    name = "CHECKNL";       break;
2396             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
2397             case FF_SPACE:      name = "SPACE";         break;
2398             case FF_HALFSPACE:  name = "HALFSPACE";     break;
2399             case FF_ITEM:       name = "ITEM";          break;
2400             case FF_CHOP:       name = "CHOP";          break;
2401             case FF_LINEGLOB:   name = "LINEGLOB";      break;
2402             case FF_NEWLINE:    name = "NEWLINE";       break;
2403             case FF_MORE:       name = "MORE";          break;
2404             case FF_LINEMARK:   name = "LINEMARK";      break;
2405             case FF_END:        name = "END";           break;
2406             }
2407             if (arg >= 0)
2408                 fprintf(stderr, "%-16s%d\n", name, arg);
2409             else
2410                 fprintf(stderr, "%-16s\n", name);
2411         } )
2412         switch (*fpc++) {
2413         case FF_LINEMARK:
2414             linemark = t;
2415             formmark = f;
2416             markmark = MARK;
2417             lines++;
2418             gotsome = FALSE;
2419             break;
2420
2421         case FF_LITERAL:
2422             arg = *fpc++;
2423             while (arg--)
2424                 *t++ = *f++;
2425             break;
2426
2427         case FF_SKIP:
2428             f += *fpc++;
2429             break;
2430
2431         case FF_FETCH:
2432             arg = *fpc++;
2433             f += arg;
2434             fieldsize = arg;
2435
2436             if (MARK < SP)
2437                 sv = *++MARK;
2438             else {
2439                 sv = &sv_no;
2440                 if (dowarn)
2441                     warn("Not enough format arguments");
2442             }
2443             break;
2444
2445         case FF_CHECKNL:
2446             s = SvPVn(sv);
2447             itemsize = SvCUR(sv);
2448             if (itemsize > fieldsize)
2449                 itemsize = fieldsize;
2450             send = chophere = s + itemsize;
2451             while (s < send) {
2452                 if (*s & ~31)
2453                     gotsome = TRUE;
2454                 else if (*s == '\n')
2455                     break;
2456                 s++;
2457             }
2458             itemsize = s - SvPV(sv);
2459             break;
2460
2461         case FF_CHECKCHOP:
2462             s = SvPVn(sv);
2463             itemsize = SvCUR(sv);
2464             if (itemsize > fieldsize)
2465                 itemsize = fieldsize;
2466             send = chophere = s + itemsize;
2467             while (s < send || (s == send && isSPACE(*s))) {
2468                 if (isSPACE(*s)) {
2469                     if (chopspace)
2470                         chophere = s;
2471                     if (*s == '\r')
2472                         break;
2473                 }
2474                 else {
2475                     if (*s & ~31)
2476                         gotsome = TRUE;
2477                     if (index(chopset, *s))
2478                         chophere = s + 1;
2479                 }
2480                 s++;
2481             }
2482             itemsize = chophere - SvPV(sv);
2483             break;
2484
2485         case FF_SPACE:
2486             arg = fieldsize - itemsize;
2487             if (arg) {
2488                 fieldsize -= arg;
2489                 while (arg-- > 0)
2490                     *t++ = ' ';
2491             }
2492             break;
2493
2494         case FF_HALFSPACE:
2495             arg = fieldsize - itemsize;
2496             if (arg) {
2497                 arg /= 2;
2498                 fieldsize -= arg;
2499                 while (arg-- > 0)
2500                     *t++ = ' ';
2501             }
2502             break;
2503
2504         case FF_ITEM:
2505             arg = itemsize;
2506             s = SvPV(sv);
2507             while (arg--) {
2508                 if ((*t++ = *s++) < ' ')
2509                     t[-1] = ' ';
2510             }
2511             break;
2512
2513         case FF_CHOP:
2514             s = chophere;
2515             if (chopspace) {
2516                 while (*s && isSPACE(*s))
2517                     s++;
2518             }
2519             sv_chop(sv,s);
2520             break;
2521
2522         case FF_LINEGLOB:
2523             s = SvPVn(sv);
2524             itemsize = SvCUR(sv);
2525             if (itemsize) {
2526                 gotsome = TRUE;
2527                 send = s + itemsize;
2528                 while (s < send) {
2529                     if (*s++ == '\n') {
2530                         if (s == send)
2531                             itemsize--;
2532                         else
2533                             lines++;
2534                     }
2535                 }
2536                 SvCUR_set(formtarget, t - SvPV(formtarget));
2537                 sv_catpvn(formtarget, SvPV(sv), itemsize);
2538                 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
2539                 t = SvPV(formtarget) + SvCUR(formtarget);
2540             }
2541             break;
2542
2543         case FF_DECIMAL:
2544             /* If the field is marked with ^ and the value is undefined,
2545                blank it out. */
2546             arg = *fpc++;
2547             if ((arg & 512) && !SvOK(sv)) {
2548                 arg = fieldsize;
2549                 while (arg--)
2550                     *t++ = ' ';
2551                 break;
2552             }
2553             gotsome = TRUE;
2554             value = SvNVn(sv);
2555             if (arg & 256) {
2556                 sprintf(t, "%#*.*f", fieldsize, arg & 255, value);
2557             } else {
2558                 sprintf(t, "%*.0f", fieldsize, value);
2559             }
2560             t += fieldsize;
2561             break;
2562
2563         case FF_NEWLINE:
2564             f++;
2565             while (t-- > linemark && *t == ' ') ;
2566             t++;
2567             *t++ = '\n';
2568             break;
2569
2570         case FF_BLANK:
2571             arg = *fpc++;
2572             if (gotsome) {
2573                 if (arg) {              /* repeat until fields exhausted? */
2574                     fpc -= arg;
2575                     f = formmark;
2576                     MARK = markmark;
2577                     if (lines == 200) {
2578                         arg = t - linemark;
2579                         if (strnEQ(linemark, linemark - t, arg))
2580                             DIE("Runaway format");
2581                     }
2582                     arg = t - SvPV(formtarget);
2583                     SvGROW(formtarget,
2584                         (t - SvPV(formtarget)) + (f - formmark) + 1);
2585                     t = SvPV(formtarget) + arg;
2586                 }
2587             }
2588             else {
2589                 t = linemark;
2590                 lines--;
2591             }
2592             break;
2593
2594         case FF_MORE:
2595             if (SvCUR(sv)) {
2596                 arg = fieldsize - itemsize;
2597                 if (arg) {
2598                     fieldsize -= arg;
2599                     while (arg-- > 0)
2600                         *t++ = ' ';
2601                 }
2602                 s = t - 3;
2603                 if (strnEQ(s,"   ",3)) {
2604                     while (s > SvPV(formtarget) && isSPACE(s[-1]))
2605                         s--;
2606                 }
2607                 *s++ = '.';
2608                 *s++ = '.';
2609                 *s++ = '.';
2610             }
2611             break;
2612
2613         case FF_END:
2614             *t = '\0';
2615             SvCUR_set(formtarget, t - SvPV(formtarget));
2616             FmLINES(formtarget) += lines;
2617             SP = ORIGMARK;
2618             RETPUSHYES;
2619         }
2620     }
2621 }
2622
2623 PP(pp_ord)
2624 {
2625     dSP; dTARGET;
2626     I32 value;
2627     char *tmps;
2628     I32 anum;
2629
2630     if (MAXARG < 1)
2631         tmps = SvPVnx(GvSV(defgv));
2632     else
2633         tmps = POPp;
2634 #ifndef I286
2635     value = (I32) (*tmps & 255);
2636 #else
2637     anum = (I32) *tmps;
2638     value = (I32) (anum & 255);
2639 #endif
2640     XPUSHi(value);
2641     RETURN;
2642 }
2643
2644 PP(pp_crypt)
2645 {
2646     dSP; dTARGET; dPOPTOPssrl;
2647 #ifdef HAS_CRYPT
2648     char *tmps = SvPVn(lstr);
2649 #ifdef FCRYPT
2650     sv_setpv(TARG, fcrypt(tmps, SvPVn(rstr)));
2651 #else
2652     sv_setpv(TARG, crypt(tmps, SvPVn(rstr)));
2653 #endif
2654 #else
2655     DIE(
2656       "The crypt() function is unimplemented due to excessive paranoia.");
2657 #endif
2658     SETs(TARG);
2659     RETURN;
2660 }
2661
2662 PP(pp_ucfirst)
2663 {
2664     dSP;
2665     SV *sv = TOPs;
2666     register char *s;
2667
2668     if (SvSTORAGE(sv) != 'T') {
2669         dTARGET;
2670         sv_setsv(TARG, sv);
2671         sv = TARG;
2672         SETs(sv);
2673     }
2674     s = SvPVn(sv);
2675     if (isascii(*s) && islower(*s))
2676         *s = toupper(*s);
2677
2678     RETURN;
2679 }
2680
2681 PP(pp_lcfirst)
2682 {
2683     dSP;
2684     SV *sv = TOPs;
2685     register char *s;
2686
2687     if (SvSTORAGE(sv) != 'T') {
2688         dTARGET;
2689         sv_setsv(TARG, sv);
2690         sv = TARG;
2691         SETs(sv);
2692     }
2693     s = SvPVn(sv);
2694     if (isascii(*s) && isupper(*s))
2695         *s = tolower(*s);
2696
2697     SETs(sv);
2698     RETURN;
2699 }
2700
2701 PP(pp_uc)
2702 {
2703     dSP;
2704     SV *sv = TOPs;
2705     register char *s;
2706     register char *send;
2707
2708     if (SvSTORAGE(sv) != 'T') {
2709         dTARGET;
2710         sv_setsv(TARG, sv);
2711         sv = TARG;
2712         SETs(sv);
2713     }
2714     s = SvPVn(sv);
2715     send = s + SvCUR(sv);
2716     while (s < send) {
2717         if (isascii(*s) && islower(*s))
2718             *s = toupper(*s);
2719         s++;
2720     }
2721     RETURN;
2722 }
2723
2724 PP(pp_lc)
2725 {
2726     dSP;
2727     SV *sv = TOPs;
2728     register char *s;
2729     register char *send;
2730
2731     if (SvSTORAGE(sv) != 'T') {
2732         dTARGET;
2733         sv_setsv(TARG, sv);
2734         sv = TARG;
2735         SETs(sv);
2736     }
2737     s = SvPVn(sv);
2738     send = s + SvCUR(sv);
2739     while (s < send) {
2740         if (isascii(*s) && isupper(*s))
2741             *s = tolower(*s);
2742         s++;
2743     }
2744     RETURN;
2745 }
2746
2747 /* Arrays. */
2748
2749 PP(pp_rv2av)
2750 {
2751     dSP; dPOPss;
2752
2753     AV *av;
2754
2755     if (SvTYPE(sv) == SVt_REF) {
2756         av = (AV*)SvANY(sv);
2757         if (SvTYPE(av) != SVt_PVAV)
2758             DIE("Not an array reference");
2759         if (op->op_flags & OPf_LVAL) {
2760             if (op->op_flags & OPf_LOCAL)
2761                 av = (AV*)save_svref(sv);
2762             PUSHs((SV*)av);
2763             RETURN;
2764         }
2765     }
2766     else {
2767         if (SvTYPE(sv) != SVt_PVGV)
2768             sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
2769         av = GvAVn(sv);
2770         if (op->op_flags & OPf_LVAL) {
2771             if (op->op_flags & OPf_LOCAL)
2772                 av = save_ary(sv);
2773             PUSHs((SV*)av);
2774             RETURN;
2775         }
2776     }
2777
2778     if (GIMME == G_ARRAY) {
2779         I32 maxarg = AvFILL(av) + 1;
2780         EXTEND(SP, maxarg);
2781         Copy(AvARRAY(av), SP+1, maxarg, SV*);
2782         SP += maxarg;
2783     }
2784     else {
2785         dTARGET;
2786         I32 maxarg = AvFILL(av) + 1;
2787         PUSHi(maxarg);
2788     }
2789     RETURN;
2790 }
2791
2792 PP(pp_aelemfast)
2793 {
2794     dSP;
2795     AV *av = (AV*)cSVOP->op_sv;
2796     SV** svp = av_fetch(av, op->op_private - arybase, FALSE);
2797     PUSHs(svp ? *svp : &sv_undef);
2798     RETURN;
2799 }
2800
2801 PP(pp_aelem)
2802 {
2803     dSP;
2804     SV** svp;
2805     I32 elem = POPi - arybase;
2806     AV *av = (AV*)POPs;
2807
2808     if (op->op_flags & OPf_LVAL) {
2809         svp = av_fetch(av, elem, TRUE);
2810         if (!svp || *svp == &sv_undef)
2811             DIE("Assignment to non-creatable value, subscript %d", elem);
2812         if (op->op_flags & OPf_LOCAL)
2813             save_svref(svp);
2814         else if (!SvOK(*svp)) {
2815             if (op->op_private == OP_RV2HV) {
2816                 sv_free(*svp);
2817                 *svp = (SV*)newHV(COEFFSIZE);
2818             }
2819             else if (op->op_private == OP_RV2AV) {
2820                 sv_free(*svp);
2821                 *svp = (SV*)newAV();
2822             }
2823         }
2824     }
2825     else
2826         svp = av_fetch(av, elem, FALSE);
2827     PUSHs(svp ? *svp : &sv_undef);
2828     RETURN;
2829 }
2830
2831 PP(pp_aslice)
2832 {
2833     dSP; dMARK; dORIGMARK;
2834     register SV** svp;
2835     register AV* av = (AV*)POPs;
2836     register I32 lval = op->op_flags & OPf_LVAL;
2837     I32 is_something_there = lval;
2838
2839     while (++MARK <= SP) {
2840         I32 elem = SvIVnx(*MARK);
2841
2842         if (lval) {
2843             svp = av_fetch(av, elem, TRUE);
2844             if (!svp || *svp == &sv_undef)
2845                 DIE("Assignment to non-creatable value, subscript \"%d\"",elem);
2846             if (op->op_flags & OPf_LOCAL)
2847                 save_svref(svp);
2848         }
2849         else {
2850             svp = av_fetch(av, elem, FALSE);
2851             if (!is_something_there && svp && SvOK(*svp))
2852                 is_something_there = TRUE;
2853         }
2854         *MARK = svp ? *svp : &sv_undef;
2855     }
2856     if (!is_something_there)
2857         SP = ORIGMARK;
2858     RETURN;
2859 }
2860
2861 /* Associative arrays. */
2862
2863 PP(pp_each)
2864 {
2865     dSP; dTARGET;
2866     HV *hash = (HV*)POPs;
2867     HE *entry = hv_iternext(hash);
2868     I32 i;
2869     char *tmps;
2870
2871     if (mystrk) {
2872         sv_free(mystrk);
2873         mystrk = Nullsv;
2874     }
2875
2876     EXTEND(SP, 2);
2877     if (entry) {
2878         if (GIMME == G_ARRAY) {
2879             tmps = hv_iterkey(entry, &i);
2880             if (!i)
2881                 tmps = "";
2882             mystrk = newSVpv(tmps, i);
2883             PUSHs(mystrk);
2884         }
2885         sv_setsv(TARG, hv_iterval(hash, entry));
2886         PUSHs(TARG);
2887     }
2888     else if (GIMME == G_SCALAR)
2889         RETPUSHUNDEF;
2890
2891     RETURN;
2892 }
2893
2894 PP(pp_values)
2895 {
2896     return do_kv(ARGS);
2897 }
2898
2899 PP(pp_keys)
2900 {
2901     return do_kv(ARGS);
2902 }
2903
2904 PP(pp_delete)
2905 {
2906     dSP;
2907     SV *sv;
2908     SV *tmpsv = POPs;
2909     HV *hv = (HV*)POPs;
2910     char *tmps;
2911     if (!hv) {
2912         DIE("Not an associative array reference");
2913     }
2914     tmps = SvPVn(tmpsv);
2915     sv = hv_delete(hv, tmps, SvCUR(tmpsv));
2916     if (!sv)
2917         RETPUSHUNDEF;
2918     PUSHs(sv);
2919     RETURN;
2920 }
2921
2922 PP(pp_rv2hv)
2923 {
2924
2925     dSP; dTOPss;
2926
2927     HV *hv;
2928
2929     if (SvTYPE(sv) == SVt_REF) {
2930         hv = (HV*)SvANY(sv);
2931         if (SvTYPE(hv) != SVt_PVHV)
2932             DIE("Not an associative array reference");
2933         if (op->op_flags & OPf_LVAL) {
2934             if (op->op_flags & OPf_LOCAL)
2935                 hv = (HV*)save_svref(sv);
2936             SETs((SV*)hv);
2937             RETURN;
2938         }
2939     }
2940     else {
2941         if (SvTYPE(sv) != SVt_PVGV)
2942             sv = (SV*)gv_fetchpv(SvPVn(sv), TRUE);
2943         hv = GvHVn(sv);
2944         if (op->op_flags & OPf_LVAL) {
2945             if (op->op_flags & OPf_LOCAL)
2946                 hv = save_hash(sv);
2947             SETs((SV*)hv);
2948             RETURN;
2949         }
2950     }
2951
2952     if (GIMME == G_ARRAY) { /* array wanted */
2953         *stack_sp = (SV*)hv;
2954         return do_kv(ARGS);
2955     }
2956     else {
2957         dTARGET;
2958         if (HvFILL(hv))
2959             sv_setiv(TARG, 0);
2960         else {
2961             sprintf(buf, "%d/%d", HvFILL(hv),
2962                 HvFILL(hv)+1);
2963             sv_setpv(TARG, buf);
2964         }
2965         SETTARG;
2966         RETURN;
2967     }
2968 }
2969
2970 PP(pp_helem)
2971 {
2972     dSP;
2973     SV** svp;
2974     SV *keysv = POPs;
2975     char *key = SvPVn(keysv);
2976     I32 keylen = SvPOK(keysv) ? SvCUR(keysv) : 0;
2977     HV *hv = (HV*)POPs;
2978
2979     if (op->op_flags & OPf_LVAL) {
2980         svp = hv_fetch(hv, key, keylen, TRUE);
2981         if (!svp || *svp == &sv_undef)
2982             DIE("Assignment to non-creatable value, subscript \"%s\"", key);
2983         if (op->op_flags & OPf_LOCAL)
2984             save_svref(svp);
2985         else if (!SvOK(*svp)) {
2986             if (op->op_private == OP_RV2HV) {
2987                 sv_free(*svp);
2988                 *svp = (SV*)newHV(COEFFSIZE);
2989             }
2990             else if (op->op_private == OP_RV2AV) {
2991                 sv_free(*svp);
2992                 *svp = (SV*)newAV();
2993             }
2994         }
2995     }
2996     else
2997         svp = hv_fetch(hv, key, keylen, FALSE);
2998     PUSHs(svp ? *svp : &sv_undef);
2999     RETURN;
3000 }
3001
3002 PP(pp_hslice)
3003 {
3004     dSP; dMARK; dORIGMARK;
3005     register SV **svp;
3006     register HV *hv = (HV*)POPs;
3007     register I32 lval = op->op_flags & OPf_LVAL;
3008     I32 is_something_there = lval;
3009
3010     while (++MARK <= SP) {
3011         char *key = SvPVnx(*MARK);
3012         I32 keylen = SvPOK(*MARK) ? SvCUR(*MARK) : 0;
3013
3014         if (lval) {
3015             svp = hv_fetch(hv, key, keylen, TRUE);
3016             if (!svp || *svp == &sv_undef)
3017                 DIE("Assignment to non-creatable value, subscript \"%s\"", key);
3018             if (op->op_flags & OPf_LOCAL)
3019                 save_svref(svp);
3020         }
3021         else {
3022             svp = hv_fetch(hv, key, keylen, FALSE);
3023             if (!is_something_there && svp && SvOK(*svp))
3024                 is_something_there = TRUE;
3025         }
3026         *MARK = svp ? *svp : &sv_undef;
3027     }
3028     if (!is_something_there)
3029         SP = ORIGMARK;
3030     RETURN;
3031 }
3032
3033 /* Explosives and implosives. */
3034
3035 PP(pp_unpack)
3036 {
3037     dSP;
3038     dPOPPOPssrl;
3039     SV *sv;
3040     register char *pat = SvPVn(lstr);
3041     register char *s = SvPVn(rstr);
3042     char *strend = s + SvCUR(rstr);
3043     char *strbeg = s;
3044     register char *patend = pat + SvCUR(lstr);
3045     I32 datumtype;
3046     register I32 len;
3047     register I32 bits;
3048
3049     /* These must not be in registers: */
3050     I16 ashort;
3051     int aint;
3052     I32 along;
3053 #ifdef QUAD
3054     quad aquad;
3055 #endif
3056     U16 aushort;
3057     unsigned int auint;
3058     U32 aulong;
3059 #ifdef QUAD
3060     unsigned quad auquad;
3061 #endif
3062     char *aptr;
3063     float afloat;
3064     double adouble;
3065     I32 checksum = 0;
3066     register U32 culong;
3067     double cdouble;
3068     static char* bitcount = 0;
3069
3070     if (GIMME != G_ARRAY) {             /* arrange to do first one only */
3071         /*SUPPRESS 530*/
3072         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3073         if (index("aAbBhH", *patend) || *pat == '%') {
3074             patend++;
3075             while (isDIGIT(*patend) || *patend == '*')
3076                 patend++;
3077         }
3078         else
3079             patend++;
3080     }
3081     while (pat < patend) {
3082       reparse:
3083         datumtype = *pat++;
3084         if (pat >= patend)
3085             len = 1;
3086         else if (*pat == '*') {
3087             len = strend - strbeg;      /* long enough */
3088             pat++;
3089         }
3090         else if (isDIGIT(*pat)) {
3091             len = *pat++ - '0';
3092             while (isDIGIT(*pat))
3093                 len = (len * 10) + (*pat++ - '0');
3094         }
3095         else
3096             len = (datumtype != '@');
3097         switch(datumtype) {
3098         default:
3099             break;
3100         case '%':
3101             if (len == 1 && pat[-1] != '1')
3102                 len = 16;
3103             checksum = len;
3104             culong = 0;
3105             cdouble = 0;
3106             if (pat < patend)
3107                 goto reparse;
3108             break;
3109         case '@':
3110             if (len > strend - strbeg)
3111                 DIE("@ outside of string");
3112             s = strbeg + len;
3113             break;
3114         case 'X':
3115             if (len > s - strbeg)
3116                 DIE("X outside of string");
3117             s -= len;
3118             break;
3119         case 'x':
3120             if (len > strend - s)
3121                 DIE("x outside of string");
3122             s += len;
3123             break;
3124         case 'A':
3125         case 'a':
3126             if (len > strend - s)
3127                 len = strend - s;
3128             if (checksum)
3129                 goto uchar_checksum;
3130             sv = NEWSV(35, len);
3131             sv_setpvn(sv, s, len);
3132             s += len;
3133             if (datumtype == 'A') {
3134                 aptr = s;       /* borrow register */
3135                 s = SvPV(sv) + len - 1;
3136                 while (s >= SvPV(sv) && (!*s || isSPACE(*s)))
3137                     s--;
3138                 *++s = '\0';
3139                 SvCUR_set(sv, s - SvPV(sv));
3140                 s = aptr;       /* unborrow register */
3141             }
3142             XPUSHs(sv_2mortal(sv));
3143             break;
3144         case 'B':
3145         case 'b':
3146             if (pat[-1] == '*' || len > (strend - s) * 8)
3147                 len = (strend - s) * 8;
3148             if (checksum) {
3149                 if (!bitcount) {
3150                     Newz(601, bitcount, 256, char);
3151                     for (bits = 1; bits < 256; bits++) {
3152                         if (bits & 1)   bitcount[bits]++;
3153                         if (bits & 2)   bitcount[bits]++;
3154                         if (bits & 4)   bitcount[bits]++;
3155                         if (bits & 8)   bitcount[bits]++;
3156                         if (bits & 16)  bitcount[bits]++;
3157                         if (bits & 32)  bitcount[bits]++;
3158                         if (bits & 64)  bitcount[bits]++;
3159                         if (bits & 128) bitcount[bits]++;
3160                     }
3161                 }
3162                 while (len >= 8) {
3163                     culong += bitcount[*(unsigned char*)s++];
3164                     len -= 8;
3165                 }
3166                 if (len) {
3167                     bits = *s;
3168                     if (datumtype == 'b') {
3169                         while (len-- > 0) {
3170                             if (bits & 1) culong++;
3171                             bits >>= 1;
3172                         }
3173                     }
3174                     else {
3175                         while (len-- > 0) {
3176                             if (bits & 128) culong++;
3177                             bits <<= 1;
3178                         }
3179                     }
3180                 }
3181                 break;
3182             }
3183             sv = NEWSV(35, len + 1);
3184             SvCUR_set(sv, len);
3185             SvPOK_on(sv);
3186             aptr = pat;                 /* borrow register */
3187             pat = SvPV(sv);
3188             if (datumtype == 'b') {
3189                 aint = len;
3190                 for (len = 0; len < aint; len++) {
3191                     if (len & 7)                /*SUPPRESS 595*/
3192                         bits >>= 1;
3193                     else
3194                         bits = *s++;
3195                     *pat++ = '0' + (bits & 1);
3196                 }
3197             }
3198             else {
3199                 aint = len;
3200                 for (len = 0; len < aint; len++) {
3201                     if (len & 7)
3202                         bits <<= 1;
3203                     else
3204                         bits = *s++;
3205                     *pat++ = '0' + ((bits & 128) != 0);
3206                 }
3207             }
3208             *pat = '\0';
3209             pat = aptr;                 /* unborrow register */
3210             XPUSHs(sv_2mortal(sv));
3211             break;
3212         case 'H':
3213         case 'h':
3214             if (pat[-1] == '*' || len > (strend - s) * 2)
3215                 len = (strend - s) * 2;
3216             sv = NEWSV(35, len + 1);
3217             SvCUR_set(sv, len);
3218             SvPOK_on(sv);
3219             aptr = pat;                 /* borrow register */
3220             pat = SvPV(sv);
3221             if (datumtype == 'h') {
3222                 aint = len;
3223                 for (len = 0; len < aint; len++) {
3224                     if (len & 1)
3225                         bits >>= 4;
3226                     else
3227                         bits = *s++;
3228                     *pat++ = hexdigit[bits & 15];
3229                 }
3230             }
3231             else {
3232                 aint = len;
3233                 for (len = 0; len < aint; len++) {
3234                     if (len & 1)
3235                         bits <<= 4;
3236                     else
3237                         bits = *s++;
3238                     *pat++ = hexdigit[(bits >> 4) & 15];
3239                 }
3240             }
3241             *pat = '\0';
3242             pat = aptr;                 /* unborrow register */
3243             XPUSHs(sv_2mortal(sv));
3244             break;
3245         case 'c':
3246             if (len > strend - s)
3247                 len = strend - s;
3248             if (checksum) {
3249                 while (len-- > 0) {
3250                     aint = *s++;
3251                     if (aint >= 128)    /* fake up signed chars */
3252                         aint -= 256;
3253                     culong += aint;
3254                 }
3255             }
3256             else {
3257                 EXTEND(SP, len);
3258                 while (len-- > 0) {
3259                     aint = *s++;
3260                     if (aint >= 128)    /* fake up signed chars */
3261                         aint -= 256;
3262                     sv = NEWSV(36, 0);
3263                     sv_setiv(sv, (I32)aint);
3264                     PUSHs(sv_2mortal(sv));
3265                 }
3266             }
3267             break;
3268         case 'C':
3269             if (len > strend - s)
3270                 len = strend - s;
3271             if (checksum) {
3272               uchar_checksum:
3273                 while (len-- > 0) {
3274                     auint = *s++ & 255;
3275                     culong += auint;
3276                 }
3277             }
3278             else {
3279                 EXTEND(SP, len);
3280                 while (len-- > 0) {
3281                     auint = *s++ & 255;
3282                     sv = NEWSV(37, 0);
3283                     sv_setiv(sv, (I32)auint);
3284                     PUSHs(sv_2mortal(sv));
3285                 }
3286             }
3287             break;
3288         case 's':
3289             along = (strend - s) / sizeof(I16);
3290             if (len > along)
3291                 len = along;
3292             if (checksum) {
3293                 while (len-- > 0) {
3294                     Copy(s, &ashort, 1, I16);
3295                     s += sizeof(I16);
3296                     culong += ashort;
3297                 }
3298             }
3299             else {
3300                 EXTEND(SP, len);
3301                 while (len-- > 0) {
3302                     Copy(s, &ashort, 1, I16);
3303                     s += sizeof(I16);
3304                     sv = NEWSV(38, 0);
3305                     sv_setiv(sv, (I32)ashort);
3306                     PUSHs(sv_2mortal(sv));
3307                 }
3308             }
3309             break;
3310         case 'v':
3311         case 'n':
3312         case 'S':
3313             along = (strend - s) / sizeof(U16);
3314             if (len > along)
3315                 len = along;
3316             if (checksum) {
3317                 while (len-- > 0) {
3318                     Copy(s, &aushort, 1, U16);
3319                     s += sizeof(U16);
3320 #ifdef HAS_NTOHS
3321                     if (datumtype == 'n')
3322                         aushort = ntohs(aushort);
3323 #endif
3324 #ifdef HAS_VTOHS
3325                     if (datumtype == 'v')
3326                         aushort = vtohs(aushort);
3327 #endif
3328                     culong += aushort;
3329                 }
3330             }
3331             else {
3332                 EXTEND(SP, len);
3333                 while (len-- > 0) {
3334                     Copy(s, &aushort, 1, U16);
3335                     s += sizeof(U16);
3336                     sv = NEWSV(39, 0);
3337 #ifdef HAS_NTOHS
3338                     if (datumtype == 'n')
3339                         aushort = ntohs(aushort);
3340 #endif
3341 #ifdef HAS_VTOHS
3342                     if (datumtype == 'v')
3343                         aushort = vtohs(aushort);
3344 #endif
3345                     sv_setiv(sv, (I32)aushort);
3346                     PUSHs(sv_2mortal(sv));
3347                 }
3348             }
3349             break;
3350         case 'i':
3351             along = (strend - s) / sizeof(int);
3352             if (len > along)
3353                 len = along;
3354             if (checksum) {
3355                 while (len-- > 0) {
3356                     Copy(s, &aint, 1, int);
3357                     s += sizeof(int);
3358                     if (checksum > 32)
3359                         cdouble += (double)aint;
3360                     else
3361                         culong += aint;
3362                 }
3363             }
3364             else {
3365                 EXTEND(SP, len);
3366                 while (len-- > 0) {
3367                     Copy(s, &aint, 1, int);
3368                     s += sizeof(int);
3369                     sv = NEWSV(40, 0);
3370                     sv_setiv(sv, (I32)aint);
3371                     PUSHs(sv_2mortal(sv));
3372                 }
3373             }
3374             break;
3375         case 'I':
3376             along = (strend - s) / sizeof(unsigned int);
3377             if (len > along)
3378                 len = along;
3379             if (checksum) {
3380                 while (len-- > 0) {
3381                     Copy(s, &auint, 1, unsigned int);
3382                     s += sizeof(unsigned int);
3383                     if (checksum > 32)
3384                         cdouble += (double)auint;
3385                     else
3386                         culong += auint;
3387                 }
3388             }
3389             else {
3390                 EXTEND(SP, len);
3391                 while (len-- > 0) {
3392                     Copy(s, &auint, 1, unsigned int);
3393                     s += sizeof(unsigned int);
3394                     sv = NEWSV(41, 0);
3395                     sv_setiv(sv, (I32)auint);
3396                     PUSHs(sv_2mortal(sv));
3397                 }
3398             }
3399             break;
3400         case 'l':
3401             along = (strend - s) / sizeof(I32);
3402             if (len > along)
3403                 len = along;
3404             if (checksum) {
3405                 while (len-- > 0) {
3406                     Copy(s, &along, 1, I32);
3407                     s += sizeof(I32);
3408                     if (checksum > 32)
3409                         cdouble += (double)along;
3410                     else
3411                         culong += along;
3412                 }
3413             }
3414             else {
3415                 EXTEND(SP, len);
3416                 while (len-- > 0) {
3417                     Copy(s, &along, 1, I32);
3418                     s += sizeof(I32);
3419                     sv = NEWSV(42, 0);
3420                     sv_setiv(sv, (I32)along);
3421                     PUSHs(sv_2mortal(sv));
3422                 }
3423             }
3424             break;
3425         case 'V':
3426         case 'N':
3427         case 'L':
3428             along = (strend - s) / sizeof(U32);
3429             if (len > along)
3430                 len = along;
3431             if (checksum) {
3432                 while (len-- > 0) {
3433                     Copy(s, &aulong, 1, U32);
3434                     s += sizeof(U32);
3435 #ifdef HAS_NTOHL
3436                     if (datumtype == 'N')
3437                         aulong = ntohl(aulong);
3438 #endif
3439 #ifdef HAS_VTOHL
3440                     if (datumtype == 'V')
3441                         aulong = vtohl(aulong);
3442 #endif
3443                     if (checksum > 32)
3444                         cdouble += (double)aulong;
3445                     else
3446                         culong += aulong;
3447                 }
3448             }
3449             else {
3450                 EXTEND(SP, len);
3451                 while (len-- > 0) {
3452                     Copy(s, &aulong, 1, U32);
3453                     s += sizeof(U32);
3454                     sv = NEWSV(43, 0);
3455 #ifdef HAS_NTOHL
3456                     if (datumtype == 'N')
3457                         aulong = ntohl(aulong);
3458 #endif
3459 #ifdef HAS_VTOHL
3460                     if (datumtype == 'V')
3461                         aulong = vtohl(aulong);
3462 #endif
3463                     sv_setnv(sv, (double)aulong);
3464                     PUSHs(sv_2mortal(sv));
3465                 }
3466             }
3467             break;
3468         case 'p':
3469             along = (strend - s) / sizeof(char*);
3470             if (len > along)
3471                 len = along;
3472             EXTEND(SP, len);
3473             while (len-- > 0) {
3474                 if (sizeof(char*) > strend - s)
3475                     break;
3476                 else {
3477                     Copy(s, &aptr, 1, char*);
3478                     s += sizeof(char*);
3479                 }
3480                 sv = NEWSV(44, 0);
3481                 if (aptr)
3482                     sv_setpv(sv, aptr);
3483                 PUSHs(sv_2mortal(sv));
3484             }
3485             break;
3486 #ifdef QUAD
3487         case 'q':
3488             EXTEND(SP, len);
3489             while (len-- > 0) {
3490                 if (s + sizeof(quad) > strend)
3491                     aquad = 0;
3492                 else {
3493                     Copy(s, &aquad, 1, quad);
3494                     s += sizeof(quad);
3495                 }
3496                 sv = NEWSV(42, 0);
3497                 sv_setnv(sv, (double)aquad);
3498                 PUSHs(sv_2mortal(sv));
3499             }
3500             break;
3501         case 'Q':
3502             EXTEND(SP, len);
3503             while (len-- > 0) {
3504                 if (s + sizeof(unsigned quad) > strend)
3505                     auquad = 0;
3506                 else {
3507                     Copy(s, &auquad, 1, unsigned quad);
3508                     s += sizeof(unsigned quad);
3509                 }
3510                 sv = NEWSV(43, 0);
3511                 sv_setnv(sv, (double)auquad);
3512                 PUSHs(sv_2mortal(sv));
3513             }
3514             break;
3515 #endif
3516         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3517         case 'f':
3518         case 'F':
3519             along = (strend - s) / sizeof(float);
3520             if (len > along)
3521                 len = along;
3522             if (checksum) {
3523                 while (len-- > 0) {
3524                     Copy(s, &afloat, 1, float);
3525                     s += sizeof(float);
3526                     cdouble += afloat;
3527                 }
3528             }
3529             else {
3530                 EXTEND(SP, len);
3531                 while (len-- > 0) {
3532                     Copy(s, &afloat, 1, float);
3533                     s += sizeof(float);
3534                     sv = NEWSV(47, 0);
3535                     sv_setnv(sv, (double)afloat);
3536                     PUSHs(sv_2mortal(sv));
3537                 }
3538             }
3539             break;
3540         case 'd':
3541         case 'D':
3542             along = (strend - s) / sizeof(double);
3543             if (len > along)
3544                 len = along;
3545             if (checksum) {
3546                 while (len-- > 0) {
3547                     Copy(s, &adouble, 1, double);
3548                     s += sizeof(double);
3549                     cdouble += adouble;
3550                 }
3551             }
3552             else {
3553                 EXTEND(SP, len);
3554                 while (len-- > 0) {
3555                     Copy(s, &adouble, 1, double);
3556                     s += sizeof(double);
3557                     sv = NEWSV(48, 0);
3558                     sv_setnv(sv, (double)adouble);
3559                     PUSHs(sv_2mortal(sv));
3560                 }
3561             }
3562             break;
3563         case 'u':
3564             along = (strend - s) * 3 / 4;
3565             sv = NEWSV(42, along);
3566             while (s < strend && *s > ' ' && *s < 'a') {
3567                 I32 a, b, c, d;
3568                 char hunk[4];
3569
3570                 hunk[3] = '\0';
3571                 len = (*s++ - ' ') & 077;
3572                 while (len > 0) {
3573                     if (s < strend && *s >= ' ')
3574                         a = (*s++ - ' ') & 077;
3575                     else
3576                         a = 0;
3577                     if (s < strend && *s >= ' ')
3578                         b = (*s++ - ' ') & 077;
3579                     else
3580                         b = 0;
3581                     if (s < strend && *s >= ' ')
3582                         c = (*s++ - ' ') & 077;
3583                     else
3584                         c = 0;
3585                     if (s < strend && *s >= ' ')
3586                         d = (*s++ - ' ') & 077;
3587                     else
3588                         d = 0;
3589                     hunk[0] = a << 2 | b >> 4;
3590                     hunk[1] = b << 4 | c >> 2;
3591                     hunk[2] = c << 6 | d;
3592                     sv_catpvn(sv, hunk, len > 3 ? 3 : len);
3593                     len -= 3;
3594                 }
3595                 if (*s == '\n')
3596                     s++;
3597                 else if (s[1] == '\n')          /* possible checksum byte */
3598                     s += 2;
3599             }
3600             XPUSHs(sv_2mortal(sv));
3601             break;
3602         }
3603         if (checksum) {
3604             sv = NEWSV(42, 0);
3605             if (index("fFdD", datumtype) ||
3606               (checksum > 32 && index("iIlLN", datumtype)) ) {
3607                 double modf();
3608                 double trouble;
3609
3610                 adouble = 1.0;
3611                 while (checksum >= 16) {
3612                     checksum -= 16;
3613                     adouble *= 65536.0;
3614                 }
3615                 while (checksum >= 4) {
3616                     checksum -= 4;
3617                     adouble *= 16.0;
3618                 }
3619                 while (checksum--)
3620                     adouble *= 2.0;
3621                 along = (1 << checksum) - 1;
3622                 while (cdouble < 0.0)
3623                     cdouble += adouble;
3624                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3625                 sv_setnv(sv, cdouble);
3626             }
3627             else {
3628                 if (checksum < 32) {
3629                     along = (1 << checksum) - 1;
3630                     culong &= (U32)along;
3631                 }
3632                 sv_setnv(sv, (double)culong);
3633             }
3634             XPUSHs(sv_2mortal(sv));
3635             checksum = 0;
3636         }
3637     }
3638     RETURN;
3639 }
3640
3641 static void
3642 doencodes(sv, s, len)
3643 register SV *sv;
3644 register char *s;
3645 register I32 len;
3646 {
3647     char hunk[5];
3648
3649     *hunk = len + ' ';
3650     sv_catpvn(sv, hunk, 1);
3651     hunk[4] = '\0';
3652     while (len > 0) {
3653         hunk[0] = ' ' + (077 & (*s >> 2));
3654         hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
3655         hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
3656         hunk[3] = ' ' + (077 & (s[2] & 077));
3657         sv_catpvn(sv, hunk, 4);
3658         s += 3;
3659         len -= 3;
3660     }
3661     for (s = SvPV(sv); *s; s++) {
3662         if (*s == ' ')
3663             *s = '`';
3664     }
3665     sv_catpvn(sv, "\n", 1);
3666 }
3667
3668 PP(pp_pack)
3669 {
3670     dSP; dMARK; dORIGMARK; dTARGET;
3671     register SV *cat = TARG;
3672     register I32 items;
3673     register char *pat = SvPVnx(*++MARK);
3674     register char *patend = pat + SvCUR(*MARK);
3675     register I32 len;
3676     I32 datumtype;
3677     SV *fromstr;
3678     /*SUPPRESS 442*/
3679     static char *null10 = "\0\0\0\0\0\0\0\0\0\0";
3680     static char *space10 = "          ";
3681
3682     /* These must not be in registers: */
3683     char achar;
3684     I16 ashort;
3685     int aint;
3686     unsigned int auint;
3687     I32 along;
3688     U32 aulong;
3689 #ifdef QUAD
3690     quad aquad;
3691     unsigned quad auquad;
3692 #endif
3693     char *aptr;
3694     float afloat;
3695     double adouble;
3696
3697     items = SP - MARK;
3698     MARK++;
3699     sv_setpvn(cat, "", 0);
3700     while (pat < patend) {
3701 #define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
3702         datumtype = *pat++;
3703         if (*pat == '*') {
3704             len = index("@Xxu", datumtype) ? 0 : items;
3705             pat++;
3706         }
3707         else if (isDIGIT(*pat)) {
3708             len = *pat++ - '0';
3709             while (isDIGIT(*pat))
3710                 len = (len * 10) + (*pat++ - '0');
3711         }
3712         else
3713             len = 1;
3714         switch(datumtype) {
3715         default:
3716             break;
3717         case '%':
3718             DIE("% may only be used in unpack");
3719         case '@':
3720             len -= SvCUR(cat);
3721             if (len > 0)
3722                 goto grow;
3723             len = -len;
3724             if (len > 0)
3725                 goto shrink;
3726             break;
3727         case 'X':
3728           shrink:
3729             if (SvCUR(cat) < len)
3730                 DIE("X outside of string");
3731             SvCUR(cat) -= len;
3732             *SvEND(cat) = '\0';
3733             break;
3734         case 'x':
3735           grow:
3736             while (len >= 10) {
3737                 sv_catpvn(cat, null10, 10);
3738                 len -= 10;
3739             }
3740             sv_catpvn(cat, null10, len);
3741             break;
3742         case 'A':
3743         case 'a':
3744             fromstr = NEXTFROM;
3745             aptr = SvPVn(fromstr);
3746             if (pat[-1] == '*')
3747                 len = SvCUR(fromstr);
3748             if (SvCUR(fromstr) > len)
3749                 sv_catpvn(cat, aptr, len);
3750             else {
3751                 sv_catpvn(cat, aptr, SvCUR(fromstr));
3752                 len -= SvCUR(fromstr);
3753                 if (datumtype == 'A') {
3754                     while (len >= 10) {
3755                         sv_catpvn(cat, space10, 10);
3756                         len -= 10;
3757                     }
3758                     sv_catpvn(cat, space10, len);
3759                 }
3760                 else {
3761                     while (len >= 10) {
3762                         sv_catpvn(cat, null10, 10);
3763                         len -= 10;
3764                     }
3765                     sv_catpvn(cat, null10, len);
3766                 }
3767             }
3768             break;
3769         case 'B':
3770         case 'b':
3771             {
3772                 char *savepat = pat;
3773                 I32 saveitems;
3774
3775                 fromstr = NEXTFROM;
3776                 saveitems = items;
3777                 aptr = SvPVn(fromstr);
3778                 if (pat[-1] == '*')
3779                     len = SvCUR(fromstr);
3780                 pat = aptr;
3781                 aint = SvCUR(cat);
3782                 SvCUR(cat) += (len+7)/8;
3783                 SvGROW(cat, SvCUR(cat) + 1);
3784                 aptr = SvPV(cat) + aint;
3785                 if (len > SvCUR(fromstr))
3786                     len = SvCUR(fromstr);
3787                 aint = len;
3788                 items = 0;
3789                 if (datumtype == 'B') {
3790                     for (len = 0; len++ < aint;) {
3791                         items |= *pat++ & 1;
3792                         if (len & 7)
3793                             items <<= 1;
3794                         else {
3795                             *aptr++ = items & 0xff;
3796                             items = 0;
3797                         }
3798                     }
3799                 }
3800                 else {
3801                     for (len = 0; len++ < aint;) {
3802                         if (*pat++ & 1)
3803                             items |= 128;
3804                         if (len & 7)
3805                             items >>= 1;
3806                         else {
3807                             *aptr++ = items & 0xff;
3808                             items = 0;
3809                         }
3810                     }
3811                 }
3812                 if (aint & 7) {
3813                     if (datumtype == 'B')
3814                         items <<= 7 - (aint & 7);
3815                     else
3816                         items >>= 7 - (aint & 7);
3817                     *aptr++ = items & 0xff;
3818                 }
3819                 pat = SvPV(cat) + SvCUR(cat);
3820                 while (aptr <= pat)
3821                     *aptr++ = '\0';
3822
3823                 pat = savepat;
3824                 items = saveitems;
3825             }
3826             break;
3827         case 'H':
3828         case 'h':
3829             {
3830                 char *savepat = pat;
3831                 I32 saveitems;
3832
3833                 fromstr = NEXTFROM;
3834                 saveitems = items;
3835                 aptr = SvPVn(fromstr);
3836                 if (pat[-1] == '*')
3837                     len = SvCUR(fromstr);
3838                 pat = aptr;
3839                 aint = SvCUR(cat);
3840                 SvCUR(cat) += (len+1)/2;
3841                 SvGROW(cat, SvCUR(cat) + 1);
3842                 aptr = SvPV(cat) + aint;
3843                 if (len > SvCUR(fromstr))
3844                     len = SvCUR(fromstr);
3845                 aint = len;
3846                 items = 0;
3847                 if (datumtype == 'H') {
3848                     for (len = 0; len++ < aint;) {
3849                         if (isALPHA(*pat))
3850                             items |= ((*pat++ & 15) + 9) & 15;
3851                         else
3852                             items |= *pat++ & 15;
3853                         if (len & 1)
3854                             items <<= 4;
3855                         else {
3856                             *aptr++ = items & 0xff;
3857                             items = 0;
3858                         }
3859                     }
3860                 }
3861                 else {
3862                     for (len = 0; len++ < aint;) {
3863                         if (isALPHA(*pat))
3864                             items |= (((*pat++ & 15) + 9) & 15) << 4;
3865                         else
3866                             items |= (*pat++ & 15) << 4;
3867                         if (len & 1)
3868                             items >>= 4;
3869                         else {
3870                             *aptr++ = items & 0xff;
3871                             items = 0;
3872                         }
3873                     }
3874                 }
3875                 if (aint & 1)
3876                     *aptr++ = items & 0xff;
3877                 pat = SvPV(cat) + SvCUR(cat);
3878                 while (aptr <= pat)
3879                     *aptr++ = '\0';
3880
3881                 pat = savepat;
3882                 items = saveitems;
3883             }
3884             break;
3885         case 'C':
3886         case 'c':
3887             while (len-- > 0) {
3888                 fromstr = NEXTFROM;
3889                 aint = SvIVn(fromstr);
3890                 achar = aint;
3891                 sv_catpvn(cat, &achar, sizeof(char));
3892             }
3893             break;
3894         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
3895         case 'f':
3896         case 'F':
3897             while (len-- > 0) {
3898                 fromstr = NEXTFROM;
3899                 afloat = (float)SvNVn(fromstr);
3900                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3901             }
3902             break;
3903         case 'd':
3904         case 'D':
3905             while (len-- > 0) {
3906                 fromstr = NEXTFROM;
3907                 adouble = (double)SvNVn(fromstr);
3908                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3909             }
3910             break;
3911         case 'n':
3912             while (len-- > 0) {
3913                 fromstr = NEXTFROM;
3914                 ashort = (I16)SvIVn(fromstr);
3915 #ifdef HAS_HTONS
3916                 ashort = htons(ashort);
3917 #endif
3918                 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3919             }
3920             break;
3921         case 'v':
3922             while (len-- > 0) {
3923                 fromstr = NEXTFROM;
3924                 ashort = (I16)SvIVn(fromstr);
3925 #ifdef HAS_HTOVS
3926                 ashort = htovs(ashort);
3927 #endif
3928                 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3929             }
3930             break;
3931         case 'S':
3932         case 's':
3933             while (len-- > 0) {
3934                 fromstr = NEXTFROM;
3935                 ashort = (I16)SvIVn(fromstr);
3936                 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3937             }
3938             break;
3939         case 'I':
3940             while (len-- > 0) {
3941                 fromstr = NEXTFROM;
3942                 auint = U_I(SvNVn(fromstr));
3943                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
3944             }
3945             break;
3946         case 'i':
3947             while (len-- > 0) {
3948                 fromstr = NEXTFROM;
3949                 aint = SvIVn(fromstr);
3950                 sv_catpvn(cat, (char*)&aint, sizeof(int));
3951             }
3952             break;
3953         case 'N':
3954             while (len-- > 0) {
3955                 fromstr = NEXTFROM;
3956                 aulong = U_L(SvNVn(fromstr));
3957 #ifdef HAS_HTONL
3958                 aulong = htonl(aulong);
3959 #endif
3960                 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3961             }
3962             break;
3963         case 'V':
3964             while (len-- > 0) {
3965                 fromstr = NEXTFROM;
3966                 aulong = U_L(SvNVn(fromstr));
3967 #ifdef HAS_HTOVL
3968                 aulong = htovl(aulong);
3969 #endif
3970                 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3971             }
3972             break;
3973         case 'L':
3974             while (len-- > 0) {
3975                 fromstr = NEXTFROM;
3976                 aulong = U_L(SvNVn(fromstr));
3977                 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3978             }
3979             break;
3980         case 'l':
3981             while (len-- > 0) {
3982                 fromstr = NEXTFROM;
3983                 along = SvIVn(fromstr);
3984                 sv_catpvn(cat, (char*)&along, sizeof(I32));
3985             }
3986             break;
3987 #ifdef QUAD
3988         case 'Q':
3989             while (len-- > 0) {
3990                 fromstr = NEXTFROM;
3991                 auquad = (unsigned quad)SvNVn(fromstr);
3992                 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned quad));
3993             }
3994             break;
3995         case 'q':
3996             while (len-- > 0) {
3997                 fromstr = NEXTFROM;
3998                 aquad = (quad)SvNVn(fromstr);
3999                 sv_catpvn(cat, (char*)&aquad, sizeof(quad));
4000             }
4001             break;
4002 #endif /* QUAD */
4003         case 'p':
4004             while (len-- > 0) {
4005                 fromstr = NEXTFROM;
4006                 aptr = SvPVn(fromstr);
4007                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4008             }
4009             break;
4010         case 'u':
4011             fromstr = NEXTFROM;
4012             aptr = SvPVn(fromstr);
4013             aint = SvCUR(fromstr);
4014             SvGROW(cat, aint * 4 / 3);
4015             if (len <= 1)
4016                 len = 45;
4017             else
4018                 len = len / 3 * 3;
4019             while (aint > 0) {
4020                 I32 todo;
4021
4022                 if (aint > len)
4023                     todo = len;
4024                 else
4025                     todo = aint;
4026                 doencodes(cat, aptr, todo);
4027                 aint -= todo;
4028                 aptr += todo;
4029             }
4030             break;
4031         }
4032     }
4033     SvSETMAGIC(cat);
4034     SP = ORIGMARK;
4035     PUSHs(cat);
4036     RETURN;
4037 }
4038 #undef NEXTFROM
4039
4040 PP(pp_split)
4041 {
4042     dSP; dTARG;
4043     AV *ary;
4044     register I32 limit = POPi;
4045     register char *s = SvPVn(TOPs);
4046     char *strend = s + SvCURx(POPs);
4047     register PMOP *pm = (PMOP*)POPs;
4048     register SV *dstr;
4049     register char *m;
4050     I32 iters = 0;
4051     I32 maxiters = (strend - s) + 10;
4052     I32 i;
4053     char *orig;
4054     I32 origlimit = limit;
4055     I32 realarray = 0;
4056     I32 base;
4057     AV *oldstack;
4058     register REGEXP *rx = pm->op_pmregexp;
4059     I32 gimme = GIMME;
4060
4061     if (!pm || !s)
4062         DIE("panic: do_split");
4063     if (pm->op_pmreplroot)
4064         ary = GvAVn((GV*)pm->op_pmreplroot);
4065     else
4066         ary = Nullav;
4067     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4068         realarray = 1;
4069         if (!AvREAL(ary)) {
4070             AvREAL_on(ary);
4071             for (i = AvFILL(ary); i >= 0; i--)
4072                 AvARRAY(ary)[i] = Nullsv;       /* don't free mere refs */
4073         }
4074         av_fill(ary,0);         /* force allocation */
4075         av_fill(ary,-1);
4076         /* temporarily switch stacks */
4077         oldstack = stack;
4078         SWITCHSTACK(stack, ary);
4079     }
4080     base = SP - stack_base + 1;
4081     orig = s;
4082     if (pm->op_pmflags & PMf_SKIPWHITE) {
4083         while (isSPACE(*s))
4084             s++;
4085     }
4086     if (!limit)
4087         limit = maxiters + 2;
4088     if (strEQ("\\s+", rx->precomp)) {
4089         while (--limit) {
4090             /*SUPPRESS 530*/
4091             for (m = s; m < strend && !isSPACE(*m); m++) ;
4092             if (m >= strend)
4093                 break;
4094             dstr = NEWSV(30, m-s);
4095             sv_setpvn(dstr, s, m-s);
4096             if (!realarray)
4097                 sv_2mortal(dstr);
4098             XPUSHs(dstr);
4099             /*SUPPRESS 530*/
4100             for (s = m + 1; s < strend && isSPACE(*s); s++) ;
4101         }
4102     }
4103     else if (strEQ("^", rx->precomp)) {
4104         while (--limit) {
4105             /*SUPPRESS 530*/
4106             for (m = s; m < strend && *m != '\n'; m++) ;
4107             m++;
4108             if (m >= strend)
4109                 break;
4110             dstr = NEWSV(30, m-s);
4111             sv_setpvn(dstr, s, m-s);
4112             if (!realarray)
4113                 sv_2mortal(dstr);
4114             XPUSHs(dstr);
4115             s = m;
4116         }
4117     }
4118     else if (pm->op_pmshort) {
4119         i = SvCUR(pm->op_pmshort);
4120         if (i == 1) {
4121             I32 fold = (pm->op_pmflags & PMf_FOLD);
4122             i = *SvPV(pm->op_pmshort);
4123             if (fold && isUPPER(i))
4124                 i = tolower(i);
4125             while (--limit) {
4126                 if (fold) {
4127                     for ( m = s;
4128                           m < strend && *m != i &&
4129                             (!isUPPER(*m) || tolower(*m) != i);
4130                           m++)                  /*SUPPRESS 530*/
4131                         ;
4132                 }
4133                 else                            /*SUPPRESS 530*/
4134                     for (m = s; m < strend && *m != i; m++) ;
4135                 if (m >= strend)
4136                     break;
4137                 dstr = NEWSV(30, m-s);
4138                 sv_setpvn(dstr, s, m-s);
4139                 if (!realarray)
4140                     sv_2mortal(dstr);
4141                 XPUSHs(dstr);
4142                 s = m + 1;
4143             }
4144         }
4145         else {
4146 #ifndef lint
4147             while (s < strend && --limit &&
4148               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4149                     pm->op_pmshort)) )
4150 #endif
4151             {
4152                 dstr = NEWSV(31, m-s);
4153                 sv_setpvn(dstr, s, m-s);
4154                 if (!realarray)
4155                     sv_2mortal(dstr);
4156                 XPUSHs(dstr);
4157                 s = m + i;
4158             }
4159         }
4160     }
4161     else {
4162         maxiters += (strend - s) * rx->nparens;
4163         while (s < strend && --limit &&
4164             regexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) {
4165             if (rx->subbase
4166               && rx->subbase != orig) {
4167                 m = s;
4168                 s = orig;
4169                 orig = rx->subbase;
4170                 s = orig + (m - s);
4171                 strend = s + (strend - m);
4172             }
4173             m = rx->startp[0];
4174             dstr = NEWSV(32, m-s);
4175             sv_setpvn(dstr, s, m-s);
4176             if (!realarray)
4177                 sv_2mortal(dstr);
4178             XPUSHs(dstr);
4179             if (rx->nparens) {
4180                 for (i = 1; i <= rx->nparens; i++) {
4181                     s = rx->startp[i];
4182                     m = rx->endp[i];
4183                     dstr = NEWSV(33, m-s);
4184                     sv_setpvn(dstr, s, m-s);
4185                     if (!realarray)
4186                         sv_2mortal(dstr);
4187                     XPUSHs(dstr);
4188                 }
4189             }
4190             s = rx->endp[0];
4191         }
4192     }
4193     iters = (SP - stack_base) - base;
4194     if (iters > maxiters)
4195         DIE("Split loop");
4196     if (s < strend || origlimit) {      /* keep field after final delim? */
4197         dstr = NEWSV(34, strend-s);
4198         sv_setpvn(dstr, s, strend-s);
4199         if (!realarray)
4200             sv_2mortal(dstr);
4201         XPUSHs(dstr);
4202         iters++;
4203     }
4204     else {
4205         while (iters > 0 && SvCUR(TOPs) == 0)
4206             iters--, SP--;
4207     }
4208     if (realarray) {
4209         SWITCHSTACK(ary, oldstack);
4210         if (gimme == G_ARRAY) {
4211             EXTEND(SP, iters);
4212             Copy(AvARRAY(ary), SP + 1, iters, SV*);
4213             SP += iters;
4214             RETURN;
4215         }
4216     }
4217     else {
4218         if (gimme == G_ARRAY)
4219             RETURN;
4220     }
4221     SP = stack_base + base;
4222     GETTARGET;
4223     PUSHi(iters);
4224     RETURN;
4225 }
4226
4227 PP(pp_join)
4228 {
4229     dSP; dMARK; dTARGET;
4230     MARK++;
4231     do_join(TARG, *MARK, MARK, SP);
4232     SP = MARK;
4233     SETs(TARG);
4234     RETURN;
4235 }
4236
4237 /* List operators. */
4238
4239 PP(pp_list)
4240 {
4241     dSP;
4242     if (GIMME != G_ARRAY) {
4243         dMARK;
4244         if (++MARK <= SP)
4245             *MARK = *SP;                /* unwanted list, return last item */
4246         else
4247             *MARK = &sv_undef;
4248         SP = MARK;
4249     }
4250     RETURN;
4251 }
4252
4253 PP(pp_lslice)
4254 {
4255     dSP;
4256     SV **lastrelem = stack_sp;
4257     SV **lastlelem = stack_base + POPMARK;
4258     SV **firstlelem = stack_base + POPMARK + 1;
4259     register SV **firstrelem = lastlelem + 1;
4260     I32 lval = op->op_flags & OPf_LVAL;
4261     I32 is_something_there = lval;
4262
4263     register I32 max = lastrelem - lastlelem;
4264     register SV **lelem;
4265     register I32 ix;
4266
4267     if (GIMME != G_ARRAY) {
4268         ix = SvIVnx(*lastlelem) - arybase;
4269         if (ix < 0 || ix >= max)
4270             *firstlelem = &sv_undef;
4271         else
4272             *firstlelem = firstrelem[ix];
4273         SP = firstlelem;
4274         RETURN;
4275     }
4276
4277     if (max == 0) {
4278         SP = firstlelem;
4279         RETURN;
4280     }
4281
4282     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4283         ix = SvIVnx(*lelem) - arybase;
4284         if (ix < 0 || ix >= max || !(*lelem = firstrelem[ix]))
4285             *lelem = &sv_undef;
4286         if (!is_something_there && SvOK(*lelem))
4287             is_something_there = TRUE;
4288     }
4289     if (is_something_there)
4290         SP = lastlelem;
4291     else
4292         SP = firstlelem;
4293     RETURN;
4294 }
4295
4296 PP(pp_anonlist)
4297 {
4298     dSP; dMARK;
4299     I32 items = SP - MARK;
4300     SP = MARK;
4301     XPUSHs((SV*)av_make(items, MARK+1));
4302     RETURN;
4303 }
4304
4305 PP(pp_anonhash)
4306 {
4307     dSP; dMARK; dORIGMARK;
4308     HV* hv = newHV(COEFFSIZE);
4309     SvREFCNT(hv) = 0;
4310     while (MARK < SP) {
4311         SV* key = *++MARK;
4312         SV* val;
4313         char *tmps;
4314         if (MARK < SP)
4315             val = *++MARK;
4316         tmps = SvPV(key);
4317         (void)hv_store(hv,tmps,SvCUR(key),val,0);
4318     }
4319     SP = ORIGMARK;
4320     XPUSHs((SV*)hv);
4321     RETURN;
4322 }
4323
4324 PP(pp_splice)
4325 {
4326     dSP; dMARK; dORIGMARK;
4327     register AV *ary = (AV*)*++MARK;
4328     register SV **src;
4329     register SV **dst;
4330     register I32 i;
4331     register I32 offset;
4332     register I32 length;
4333     I32 newlen;
4334     I32 after;
4335     I32 diff;
4336     SV **tmparyval;
4337
4338     SP++;
4339
4340     if (++MARK < SP) {
4341         offset = SvIVnx(*MARK);
4342         if (offset < 0)
4343             offset += AvFILL(ary) + 1;
4344         else
4345             offset -= arybase;
4346         if (++MARK < SP) {
4347             length = SvIVnx(*MARK++);
4348             if (length < 0)
4349                 length = 0;
4350         }
4351         else
4352             length = AvMAX(ary) + 1;            /* close enough to infinity */
4353     }
4354     else {
4355         offset = 0;
4356         length = AvMAX(ary) + 1;
4357     }
4358     if (offset < 0) {
4359         length += offset;
4360         offset = 0;
4361         if (length < 0)
4362             length = 0;
4363     }
4364     if (offset > AvFILL(ary) + 1)
4365         offset = AvFILL(ary) + 1;
4366     after = AvFILL(ary) + 1 - (offset + length);
4367     if (after < 0) {                            /* not that much array */
4368         length += after;                        /* offset+length now in array */
4369         after = 0;
4370         if (!AvALLOC(ary)) {
4371             av_fill(ary, 0);
4372             av_fill(ary, -1);
4373         }
4374     }
4375
4376     /* At this point, MARK .. SP-1 is our new LIST */
4377
4378     newlen = SP - MARK;
4379     diff = newlen - length;
4380
4381     if (diff < 0) {                             /* shrinking the area */
4382         if (newlen) {
4383             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
4384             Copy(MARK, tmparyval, newlen, SV*);
4385         }
4386
4387         MARK = ORIGMARK + 1;
4388         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4389             MEXTEND(MARK, length);
4390             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4391             if (AvREAL(ary)) {
4392                 for (i = length, dst = MARK; i; i--)
4393                     sv_2mortal(*dst++); /* free them eventualy */
4394             }
4395             MARK += length - 1;
4396         }
4397         else {
4398             *MARK = AvARRAY(ary)[offset+length-1];
4399             if (AvREAL(ary)) {
4400                 sv_2mortal(*MARK);
4401                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4402                     sv_free(*dst++);    /* free them now */
4403             }
4404         }
4405         AvFILL(ary) += diff;
4406
4407         /* pull up or down? */
4408
4409         if (offset < after) {                   /* easier to pull up */
4410             if (offset) {                       /* esp. if nothing to pull */
4411                 src = &AvARRAY(ary)[offset-1];
4412                 dst = src - diff;               /* diff is negative */
4413                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4414                     *dst-- = *src--;
4415             }
4416             Zero(AvARRAY(ary), -diff, SV*);
4417             AvARRAY(ary) -= diff;               /* diff is negative */
4418             AvMAX(ary) += diff;
4419         }
4420         else {
4421             if (after) {                        /* anything to pull down? */
4422                 src = AvARRAY(ary) + offset + length;
4423                 dst = src + diff;               /* diff is negative */
4424                 Move(src, dst, after, SV*);
4425             }
4426             Zero(&AvARRAY(ary)[AvFILL(ary)+1], -diff, SV*);
4427                                                 /* avoid later double free */
4428         }
4429         if (newlen) {
4430             for (src = tmparyval, dst = AvARRAY(ary) + offset;
4431               newlen; newlen--) {
4432                 *dst = NEWSV(46, 0);
4433                 sv_setsv(*dst++, *src++);
4434             }
4435             Safefree(tmparyval);
4436         }
4437     }
4438     else {                                      /* no, expanding (or same) */
4439         if (length) {
4440             New(452, tmparyval, length, SV*);   /* so remember deletion */
4441             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4442         }
4443
4444         if (diff > 0) {                         /* expanding */
4445
4446             /* push up or down? */
4447
4448             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4449                 if (offset) {
4450                     src = AvARRAY(ary);
4451                     dst = src - diff;
4452                     Move(src, dst, offset, SV*);
4453                 }
4454                 AvARRAY(ary) -= diff;           /* diff is positive */
4455                 AvMAX(ary) += diff;
4456                 AvFILL(ary) += diff;
4457             }
4458             else {
4459                 if (AvFILL(ary) + diff >= AvMAX(ary))   /* oh, well */
4460                     av_store(ary, AvFILL(ary) + diff, Nullsv);
4461                 else
4462                     AvFILL(ary) += diff;
4463                 dst = AvARRAY(ary) + AvFILL(ary);
4464                 for (i = diff; i > 0; i--) {
4465                     if (*dst)                   /* stuff was hanging around */
4466                         sv_free(*dst);          /*  after $#foo */
4467                     dst--;
4468                 }
4469                 if (after) {
4470                     dst = AvARRAY(ary) + AvFILL(ary);
4471                     src = dst - diff;
4472                     for (i = after; i; i--) {
4473                         *dst-- = *src--;
4474                     }
4475                 }
4476             }
4477         }
4478
4479         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4480             *dst = NEWSV(46, 0);
4481             sv_setsv(*dst++, *src++);
4482         }
4483         MARK = ORIGMARK + 1;
4484         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4485             if (length) {
4486                 Copy(tmparyval, MARK, length, SV*);
4487                 if (AvREAL(ary)) {
4488                     for (i = length, dst = MARK; i; i--)
4489                         sv_2mortal(*dst++);     /* free them eventualy */
4490                 }
4491                 Safefree(tmparyval);
4492             }
4493             MARK += length - 1;
4494         }
4495         else if (length--) {
4496             *MARK = tmparyval[length];
4497             if (AvREAL(ary)) {
4498                 sv_2mortal(*MARK);
4499                 while (length-- > 0)
4500                     sv_free(tmparyval[length]);
4501             }
4502             Safefree(tmparyval);
4503         }
4504         else
4505             *MARK = &sv_undef;
4506     }
4507     SP = MARK;
4508     RETURN;
4509 }
4510
4511 PP(pp_push)
4512 {
4513     dSP; dMARK; dORIGMARK; dTARGET;
4514     register AV *ary = (AV*)*++MARK;
4515     register SV *sv = &sv_undef;
4516
4517     for (++MARK; MARK <= SP; MARK++) {
4518         sv = NEWSV(51, 0);
4519         if (*MARK)
4520             sv_setsv(sv, *MARK);
4521         (void)av_push(ary, sv);
4522     }
4523     SP = ORIGMARK;
4524     PUSHi( AvFILL(ary) + 1 );
4525     RETURN;
4526 }
4527
4528 PP(pp_pop)
4529 {
4530     dSP;
4531     AV *av = (AV*)POPs;
4532     SV *sv = av_pop(av);
4533     if (!sv)
4534         RETPUSHUNDEF;
4535     if (AvREAL(av))
4536         (void)sv_2mortal(sv);
4537     PUSHs(sv);
4538     RETURN;
4539 }
4540
4541 PP(pp_shift)
4542 {
4543     dSP;
4544     AV *av = (AV*)POPs;
4545     SV *sv = av_shift(av);
4546     EXTEND(SP, 1);
4547     if (!sv)
4548         RETPUSHUNDEF;
4549     if (AvREAL(av))
4550         (void)sv_2mortal(sv);
4551     PUSHs(sv);
4552     RETURN;
4553 }
4554
4555 PP(pp_unshift)
4556 {
4557     dSP; dMARK; dORIGMARK; dTARGET;
4558     register AV *ary = (AV*)*++MARK;
4559     register SV *sv;
4560     register I32 i = 0;
4561
4562     av_unshift(ary, SP - MARK);
4563     while (MARK < SP) {
4564         sv = NEWSV(27, 0);
4565         sv_setsv(sv, *++MARK);
4566         (void)av_store(ary, i++, sv);
4567     }
4568
4569     SP = ORIGMARK;
4570     PUSHi( AvFILL(ary) + 1 );
4571     RETURN;
4572 }
4573
4574 PP(pp_grepstart)
4575 {
4576     dSP;
4577     SV *src;
4578
4579     if (stack_base + *markstack_ptr == sp) {
4580         POPMARK;
4581         RETURNOP(op->op_next->op_next);
4582     }
4583     stack_sp = stack_base + *markstack_ptr + 1;
4584     pp_pushmark();                              /* push dst */
4585     pp_pushmark();                              /* push src */
4586     ENTER;                                      /* enter outer scope */
4587
4588     SAVETMPS;
4589     SAVESPTR(GvSV(defgv));
4590
4591     ENTER;                                      /* enter inner scope */
4592     SAVESPTR(curpm);
4593
4594     if (src = stack_base[*markstack_ptr]) {
4595         SvTEMP_off(src);
4596         GvSV(defgv) = src;
4597     }
4598     else
4599         GvSV(defgv) = sv_mortalcopy(&sv_undef);
4600
4601     RETURNOP(((LOGOP*)op->op_next)->op_other);
4602 }
4603
4604 PP(pp_grepwhile)
4605 {
4606     dSP;
4607
4608     if (SvTRUEx(POPs))
4609         stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr];
4610     ++*markstack_ptr;
4611     LEAVE;                                      /* exit inner scope */
4612
4613     /* All done yet? */
4614     if (stack_base + *markstack_ptr > sp) {
4615         I32 items;
4616
4617         LEAVE;                                  /* exit outer scope */
4618         POPMARK;                                /* pop src */
4619         items = --*markstack_ptr - markstack_ptr[-1];
4620         POPMARK;                                /* pop dst */
4621         SP = stack_base + POPMARK;              /* pop original mark */
4622         if (GIMME != G_ARRAY) {
4623             dTARGET;
4624             XPUSHi(items);
4625             RETURN;
4626         }
4627         SP += items;
4628         RETURN;
4629     }
4630     else {
4631         SV *src;
4632
4633         ENTER;                                  /* enter inner scope */
4634         SAVESPTR(curpm);
4635
4636         if (src = stack_base[*markstack_ptr]) {
4637             SvTEMP_off(src);
4638             GvSV(defgv) = src;
4639         }
4640         else
4641             GvSV(defgv) = sv_mortalcopy(&sv_undef);
4642
4643         RETURNOP(cLOGOP->op_other);
4644     }
4645 }
4646
4647 PP(pp_sort)
4648 {
4649     dSP; dMARK; dORIGMARK;
4650     register SV **up;
4651     SV **myorigmark = ORIGMARK;
4652     register I32 max;
4653     register I32 i;
4654     int sortcmp();
4655     int sortcv();
4656     HV *stash;
4657     SV *sortcvvar;
4658     GV *gv;
4659     CV *cv;
4660
4661     if (GIMME != G_ARRAY) {
4662         SP = MARK;
4663         RETSETUNDEF;
4664     }
4665
4666     if (op->op_flags & OPf_STACKED) {
4667         if (op->op_flags & OPf_SPECIAL) {
4668             OP *kid = cLISTOP->op_first->op_sibling;    /* pass pushmark */
4669             kid = kUNOP->op_first;                      /* pass rv2gv */
4670             kid = kUNOP->op_first;                      /* pass leave */
4671             sortcop = kid->op_next;
4672             stash = curcop->cop_stash;
4673         }
4674         else {
4675             cv = sv_2cv(*++MARK, &stash, &gv, 0);
4676             if (!cv) {
4677                 if (gv) {
4678                     SV *tmpstr = sv_mortalcopy(&sv_undef);
4679                     gv_efullname(tmpstr, gv);
4680                     DIE("Undefined sort subroutine \"%s\" called",
4681                         SvPV(tmpstr));
4682                 }
4683                 DIE("Undefined subroutine in sort");
4684             }
4685             sortcop = CvSTART(cv);
4686             SAVESPTR(CvROOT(cv)->op_ppaddr);
4687             CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
4688         }
4689     }
4690     else {
4691         sortcop = Nullop;
4692         stash = curcop->cop_stash;
4693     }
4694
4695     up = myorigmark + 1;
4696     while (MARK < SP) { /* This may or may not shift down one here. */
4697         /*SUPPRESS 560*/
4698         if (*up = *++MARK) {                    /* Weed out nulls. */
4699             if (!SvPOK(*up))
4700                 (void)sv_2pv(*up);
4701             else
4702                 SvTEMP_off(*up);
4703             up++;
4704         }
4705     }
4706     max = --up - myorigmark;
4707     if (max > 1) {
4708         if (sortcop) {
4709             AV *oldstack;
4710
4711             ENTER;
4712             SAVETMPS;
4713             SAVESPTR(op);
4714
4715             oldstack = stack;
4716             if (!sortstack) {
4717                 sortstack = newAV();
4718                 av_store(sortstack, 32, Nullsv);
4719                 av_clear(sortstack);
4720                 AvREAL_off(sortstack);
4721             }
4722             SWITCHSTACK(stack, sortstack);
4723             if (sortstash != stash) {
4724                 firstgv = gv_fetchpv("a", TRUE);
4725                 secondgv = gv_fetchpv("b", TRUE);
4726                 sortstash = stash;
4727             }
4728
4729             SAVESPTR(GvSV(firstgv));
4730             SAVESPTR(GvSV(secondgv));
4731
4732             qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv);
4733
4734             SWITCHSTACK(sortstack, oldstack);
4735
4736             LEAVE;
4737         }
4738         else {
4739             MEXTEND(SP, 20);    /* Can't afford stack realloc on signal. */
4740             qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp);
4741         }
4742     }
4743     SP = ORIGMARK + max;
4744     RETURN;
4745 }
4746
4747 PP(pp_reverse)
4748 {
4749     dSP; dMARK;
4750     register SV *tmp;
4751     SV **oldsp = SP;
4752
4753     if (GIMME == G_ARRAY) {
4754         MARK++;
4755         while (MARK < SP) {
4756             tmp = *MARK;
4757             *MARK++ = *SP;
4758             *SP-- = tmp;
4759         }
4760         SP = oldsp;
4761     }
4762     else {
4763         register char *up;
4764         register char *down;
4765         register I32 tmp;
4766         dTARGET;
4767
4768         if (SP - MARK > 1)
4769             do_join(TARG, sv_no, MARK, SP);
4770         else
4771             sv_setsv(TARG, *SP);
4772         up = SvPVn(TARG);
4773         if (SvCUR(TARG) > 1) {
4774             down = SvPV(TARG) + SvCUR(TARG) - 1;
4775             while (down > up) {
4776                 tmp = *up;
4777                 *up++ = *down;
4778                 *down-- = tmp;
4779             }
4780         }
4781         SP = MARK + 1;
4782         SETTARG;
4783     }
4784     RETURN;
4785 }
4786
4787 /* Range stuff. */
4788
4789 PP(pp_range)
4790 {
4791     if (GIMME == G_ARRAY)
4792         return cCONDOP->op_true;
4793     return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
4794 }
4795
4796 PP(pp_flip)
4797 {
4798     dSP;
4799
4800     if (GIMME == G_ARRAY) {
4801         RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
4802     }
4803     else {
4804         dTOPss;
4805         SV *targ = PAD_SV(op->op_targ);
4806
4807         if ((op->op_private & OPpFLIP_LINENUM)
4808           ? last_in_gv && SvIVn(sv) == GvIO(last_in_gv)->lines
4809           : SvTRUE(sv) ) {
4810             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
4811             if (op->op_flags & OPf_SPECIAL) {
4812                 sv_setiv(targ, 1);
4813                 RETURN;
4814             }
4815             else {
4816                 sv_setiv(targ, 0);
4817                 sp--;
4818                 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
4819             }
4820         }
4821         sv_setpv(TARG, "");
4822         SETs(targ);
4823         RETURN;
4824     }
4825 }
4826
4827 PP(pp_flop)
4828 {
4829     dSP;
4830
4831     if (GIMME == G_ARRAY) {
4832         dPOPPOPssrl;
4833         register I32 i;
4834         register SV *sv;
4835         I32 max;
4836
4837         if (SvNIOK(lstr) || !SvPOK(lstr) ||
4838           (looks_like_number(lstr) && *SvPV(lstr) != '0') ) {
4839             i = SvIVn(lstr);
4840             max = SvIVn(rstr);
4841             if (max > i)
4842                 EXTEND(SP, max - i + 1);
4843             while (i <= max) {
4844                 sv = sv_mortalcopy(&sv_no);
4845                 sv_setiv(sv,i++);
4846                 PUSHs(sv);
4847             }
4848         }
4849         else {
4850             SV *final = sv_mortalcopy(rstr);
4851             char *tmps = SvPVn(final);
4852
4853             sv = sv_mortalcopy(lstr);
4854             while (!SvNIOK(sv) && SvCUR(sv) <= SvCUR(final) &&
4855                 strNE(SvPV(sv),tmps) ) {
4856                 XPUSHs(sv);
4857                 sv = sv_2mortal(newSVsv(sv));
4858                 sv_inc(sv);
4859             }
4860             if (strEQ(SvPV(sv),tmps))
4861                 XPUSHs(sv);
4862         }
4863     }
4864     else {
4865         dTOPss;
4866         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
4867         sv_inc(targ);
4868         if ((op->op_private & OPpFLIP_LINENUM)
4869           ? last_in_gv && SvIVn(sv) == GvIO(last_in_gv)->lines
4870           : SvTRUE(sv) ) {
4871             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
4872             sv_catpv(targ, "E0");
4873         }
4874         SETs(targ);
4875     }
4876
4877     RETURN;
4878 }
4879
4880 /* Control. */
4881
4882 static I32
4883 dopoptolabel(label)
4884 char *label;
4885 {
4886     register I32 i;
4887     register CONTEXT *cx;
4888
4889     for (i = cxstack_ix; i >= 0; i--) {
4890         cx = &cxstack[i];
4891         switch (cx->cx_type) {
4892         case CXt_SUBST:
4893             if (dowarn)
4894                 warn("Exiting substitution via %s", op_name[op->op_type]);
4895             break;
4896         case CXt_SUB:
4897             if (dowarn)
4898                 warn("Exiting subroutine via %s", op_name[op->op_type]);
4899             break;
4900         case CXt_EVAL:
4901             if (dowarn)
4902                 warn("Exiting eval via %s", op_name[op->op_type]);
4903             break;
4904         case CXt_LOOP:
4905             if (!cx->blk_loop.label ||
4906               strNE(label, cx->blk_loop.label) ) {
4907                 DEBUG_l(deb("(Skipping label #%d %s)\n",
4908                         i, cx->blk_loop.label));
4909                 continue;
4910             }
4911             DEBUG_l( deb("(Found label #%d %s)\n", i, label));
4912             return i;
4913         }
4914     }
4915 }
4916
4917 static I32
4918 dopoptosub(startingblock)
4919 I32 startingblock;
4920 {
4921     I32 i;
4922     register CONTEXT *cx;
4923     for (i = startingblock; i >= 0; i--) {
4924         cx = &cxstack[i];
4925         switch (cx->cx_type) {
4926         default:
4927             continue;
4928         case CXt_EVAL:
4929         case CXt_SUB:
4930             DEBUG_l( deb("(Found sub #%d)\n", i));
4931             return i;
4932         }
4933     }
4934     return i;
4935 }
4936
4937 I32
4938 dopoptoeval(startingblock)
4939 I32 startingblock;
4940 {
4941     I32 i;
4942     register CONTEXT *cx;
4943     for (i = startingblock; i >= 0; i--) {
4944         cx = &cxstack[i];
4945         switch (cx->cx_type) {
4946         default:
4947             continue;
4948         case CXt_EVAL:
4949             DEBUG_l( deb("(Found eval #%d)\n", i));
4950             return i;
4951         }
4952     }
4953     return i;
4954 }
4955
4956 static I32
4957 dopoptoloop(startingblock)
4958 I32 startingblock;
4959 {
4960     I32 i;
4961     register CONTEXT *cx;
4962     for (i = startingblock; i >= 0; i--) {
4963         cx = &cxstack[i];
4964         switch (cx->cx_type) {
4965         case CXt_SUBST:
4966             if (dowarn)
4967                 warn("Exiting substitition via %s", op_name[op->op_type]);
4968             break;
4969         case CXt_SUB:
4970             if (dowarn)
4971                 warn("Exiting subroutine via %s", op_name[op->op_type]);
4972             break;
4973         case CXt_EVAL:
4974             if (dowarn)
4975                 warn("Exiting eval via %s", op_name[op->op_type]);
4976             break;
4977         case CXt_LOOP:
4978             DEBUG_l( deb("(Found loop #%d)\n", i));
4979             return i;
4980         }
4981     }
4982     return i;
4983 }
4984
4985 static void
4986 dounwind(cxix)
4987 I32 cxix;
4988 {
4989     register CONTEXT *cx;
4990     SV **newsp;
4991     I32 optype;
4992
4993     while (cxstack_ix > cxix) {
4994         cx = &cxstack[cxstack_ix--];
4995         DEBUG_l(fprintf(stderr, "Unwinding block %d, type %d\n", cxstack_ix+1,
4996                     cx->cx_type));
4997         /* Note: we don't need to restore the base context info till the end. */
4998         switch (cx->cx_type) {
4999         case CXt_SUB:
5000             POPSUB(cx);
5001             break;
5002         case CXt_EVAL:
5003             POPEVAL(cx);
5004             break;
5005         case CXt_LOOP:
5006             POPLOOP(cx);
5007             break;
5008         case CXt_SUBST:
5009             break;
5010         }
5011     }
5012 }
5013
5014 /*VARARGS0*/
5015 OP *
5016 die(va_alist)
5017 va_dcl
5018 {
5019     va_list args;
5020     char *tmps;
5021     char *message;
5022     OP *retop;
5023
5024     va_start(args);
5025     message = mess(args);
5026     va_end(args);
5027     restartop = die_where(message);
5028     if (stack != mainstack)
5029         longjmp(top_env, 3);
5030     return restartop;
5031 }
5032
5033 OP *
5034 die_where(message)
5035 char *message;
5036 {
5037     if (in_eval) {
5038         I32 cxix;
5039         register CONTEXT *cx;
5040         I32 gimme;
5041         SV **newsp;
5042
5043         sv_setpv(GvSV(gv_fetchpv("@",TRUE)),message);
5044         cxix = dopoptoeval(cxstack_ix);
5045         if (cxix >= 0) {
5046             I32 optype;
5047
5048             if (cxix < cxstack_ix)
5049                 dounwind(cxix);
5050
5051             POPBLOCK(cx);
5052             if (cx->cx_type != CXt_EVAL) {
5053                 fprintf(stderr, "panic: die %s", message);
5054                 my_exit(1);
5055             }
5056             POPEVAL(cx);
5057
5058             if (gimme == G_SCALAR)
5059                 *++newsp = &sv_undef;
5060             stack_sp = newsp;
5061
5062             LEAVE;
5063             if (optype == OP_REQUIRE)
5064                 DIE("%s", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
5065             return pop_return();
5066         }
5067     }
5068     fputs(message, stderr);
5069     (void)fflush(stderr);
5070     if (e_fp)
5071         (void)UNLINK(e_tmpname);
5072     statusvalue >>= 8;
5073     my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
5074     return 0;
5075 }
5076
5077 PP(pp_and)
5078 {
5079     dSP;
5080     if (!SvTRUE(TOPs))
5081         RETURN;
5082     else {
5083         --SP;
5084         RETURNOP(cLOGOP->op_other);
5085     }
5086 }
5087
5088 PP(pp_or)
5089 {
5090     dSP;
5091     if (SvTRUE(TOPs))
5092         RETURN;
5093     else {
5094         --SP;
5095         RETURNOP(cLOGOP->op_other);
5096     }
5097 }
5098
5099 PP(pp_cond_expr)
5100 {
5101     dSP;
5102     if (SvTRUEx(POPs))
5103         RETURNOP(cCONDOP->op_true);
5104     else
5105         RETURNOP(cCONDOP->op_false);
5106 }
5107
5108 PP(pp_andassign)
5109 {
5110     dSP;
5111     if (!SvTRUE(TOPs))
5112         RETURN;
5113     else
5114         RETURNOP(cLOGOP->op_other);
5115 }
5116
5117 PP(pp_orassign)
5118 {
5119     dSP;
5120     if (SvTRUE(TOPs))
5121         RETURN;
5122     else
5123         RETURNOP(cLOGOP->op_other);
5124 }
5125
5126 PP(pp_method)
5127 {
5128     dSP; dPOPss; dTARGET;
5129     SV* ob;
5130     GV* gv;
5131
5132     if (SvTYPE(sv) != SVt_REF || !(ob = (SV*)SvANY(sv)) || SvSTORAGE(ob) != 'O')
5133         DIE("Not an object reference");
5134
5135     if (TARG && SvTYPE(TARG) == SVt_REF) {
5136         /* XXX */
5137         gv = 0;
5138     }
5139     else
5140         gv = 0;
5141
5142     if (!gv) {          /* nothing cached */
5143         char *name = SvPV(((SVOP*)cLOGOP->op_other)->op_sv);
5144         if (index(name, '\''))
5145             gv = gv_fetchpv(name, FALSE);
5146         else
5147             gv = gv_fetchmethod(SvSTASH(ob),name);
5148         if (!gv)
5149             DIE("Can't locate object method \"%s\" via package \"%s\"",
5150                 name, HvNAME(SvSTASH(ob)));
5151     }
5152
5153     EXTEND(sp,2);
5154     PUSHs(gv);
5155     PUSHs(sv);
5156     RETURN;
5157 }
5158
5159 PP(pp_entersubr)
5160 {
5161     dSP; dMARK;
5162     SV *sv;
5163     GV *gv;
5164     HV *stash;
5165     register CV *cv = sv_2cv(*++MARK, &stash, &gv, 0);
5166     register I32 items = SP - MARK;
5167     I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
5168     register CONTEXT *cx;
5169
5170     ENTER;
5171     SAVETMPS;
5172
5173     if (!cv) {
5174         if (gv) {
5175             SV *tmpstr = sv_mortalcopy(&sv_undef);
5176             gv_efullname(tmpstr, gv);
5177             DIE("Undefined subroutine \"%s\" called",SvPV(tmpstr));
5178         }
5179         DIE("Not a subroutine reference");
5180     }
5181     if ((op->op_private & OPpSUBR_DB) && !CvUSERSUB(cv)) {
5182         sv = GvSV(DBsub);
5183         save_item(sv);
5184         gv_efullname(sv,gv);
5185         cv = GvCV(DBsub);
5186         if (!cv)
5187             DIE("No DBsub routine");
5188     }
5189
5190     if (CvUSERSUB(cv)) {
5191         cx->blk_sub.hasargs = 0;
5192         cx->blk_sub.savearray = Null(AV*);;
5193         cx->blk_sub.argarray = Null(AV*);
5194         if (!hasargs)
5195             items = 0;
5196         items = (*CvUSERSUB(cv))(CvUSERINDEX(cv), sp - stack_base, items);
5197         sp = stack_base + items;
5198         RETURN;
5199     }
5200     else {
5201         I32 gimme = GIMME;
5202         push_return(op->op_next);
5203         PUSHBLOCK(cx, CXt_SUB, MARK - 1);
5204         PUSHSUB(cx);
5205         if (hasargs) {
5206             cx->blk_sub.savearray = GvAV(defgv);
5207             cx->blk_sub.argarray = av_fake(items, ++MARK);
5208             GvAV(defgv) = cx->blk_sub.argarray;
5209         }
5210         CvDEPTH(cv)++;
5211         if (CvDEPTH(cv) >= 2) { /* save temporaries on recursion? */
5212             if (CvDEPTH(cv) == 100 && dowarn)
5213                 warn("Deep recursion on subroutine \"%s\"",GvENAME(gv));
5214             if (CvDEPTH(cv) > AvFILL(CvPADLIST(cv))) {
5215                 AV *newpad = newAV();
5216                 I32 ix = AvFILL((AV*)*av_fetch(CvPADLIST(cv), 1, FALSE));
5217                 while (ix > 0)
5218                     av_store(newpad, ix--, NEWSV(0,0));
5219                 av_store(CvPADLIST(cv), CvDEPTH(cv), (SV*)newpad);
5220                 AvFILL(CvPADLIST(cv)) = CvDEPTH(cv);
5221             }
5222         }
5223         SAVESPTR(curpad);
5224         curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),CvDEPTH(cv),FALSE));
5225         RETURNOP(CvSTART(cv));
5226     }
5227 }
5228
5229 PP(pp_leavesubr)
5230 {
5231     dSP;
5232     SV **mark;
5233     SV **newsp;
5234     I32 gimme;
5235     register CONTEXT *cx;
5236
5237     POPBLOCK(cx);
5238     POPSUB(cx);
5239
5240     if (gimme == G_SCALAR) {
5241         MARK = newsp + 1;
5242         if (MARK <= SP)
5243             *MARK = sv_mortalcopy(TOPs);
5244         else {
5245             MEXTEND(mark,0);
5246             *MARK = &sv_undef;
5247         }
5248         SP = MARK;
5249     }
5250     else {
5251         for (mark = newsp + 1; mark <= SP; mark++)
5252             *mark = sv_mortalcopy(*mark);
5253                 /* in case LEAVE wipes old return values */
5254     }
5255
5256     LEAVE;
5257     PUTBACK;
5258     return pop_return();
5259 }
5260
5261 PP(pp_done)
5262 {
5263     return pop_return();
5264 }
5265
5266 PP(pp_caller)
5267 {
5268     dSP;
5269     register I32 cxix = dopoptosub(cxstack_ix);
5270     I32 nextcxix;
5271     register CONTEXT *cx;
5272     SV *sv;
5273     I32 count = 0;
5274
5275     if (cxix < 0)
5276         DIE("There is no caller");
5277     if (MAXARG)
5278         count = POPi;
5279     for (;;) {
5280         if (cxix < 0)
5281             RETURN;
5282         nextcxix = dopoptosub(cxix - 1);
5283         if (DBsub && nextcxix >= 0 &&
5284                 cxstack[nextcxix].blk_sub.cv == GvCV(DBsub))
5285             count++;
5286         if (!count--)
5287             break;
5288         cxix = nextcxix;
5289     }
5290     cx = &cxstack[cxix];
5291     EXTEND(SP, 6);
5292     if (GIMME != G_ARRAY) {
5293         dTARGET;
5294
5295         sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash));
5296         PUSHs(TARG);
5297         RETURN;
5298     }
5299
5300     PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0)));
5301     PUSHs(sv_2mortal(newSVpv(SvPV(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
5302     PUSHs(sv_2mortal(newSVnv((double)cx->blk_oldcop->cop_line)));
5303     if (!MAXARG)
5304         RETURN;
5305     sv = NEWSV(49, 0);
5306     gv_efullname(sv, cx->blk_sub.gv);
5307     PUSHs(sv_2mortal(sv));
5308     PUSHs(sv_2mortal(newSVnv((double)cx->blk_sub.hasargs)));
5309     PUSHs(sv_2mortal(newSVnv((double)cx->blk_gimme)));
5310     if (cx->blk_sub.hasargs) {
5311         AV *ary = cx->blk_sub.argarray;
5312
5313         if (!dbargs)
5314             dbargs = GvAV(gv_AVadd(gv_fetchpv("DB'args", TRUE)));
5315         if (AvMAX(dbargs) < AvFILL(ary))
5316             av_store(dbargs, AvFILL(ary), Nullsv);
5317         Copy(AvARRAY(ary), AvARRAY(dbargs), AvFILL(ary)+1, SV*);
5318         AvFILL(dbargs) = AvFILL(ary);
5319     }
5320     RETURN;
5321 }
5322
5323 static I32
5324 sortcv(str1, str2)
5325 SV **str1;
5326 SV **str2;
5327 {
5328     GvSV(firstgv) = *str1;
5329     GvSV(secondgv) = *str2;
5330     stack_sp = stack_base;
5331     op = sortcop;
5332     run();
5333     return SvIVnx(AvARRAY(stack)[1]);
5334 }
5335
5336 static I32
5337 sortcmp(strp1, strp2)
5338 SV **strp1;
5339 SV **strp2;
5340 {
5341     register SV *str1 = *strp1;
5342     register SV *str2 = *strp2;
5343     I32 retval;
5344
5345     if (SvCUR(str1) < SvCUR(str2)) {
5346         /*SUPPRESS 560*/
5347         if (retval = memcmp(SvPV(str1), SvPV(str2), SvCUR(str1)))
5348             return retval;
5349         else
5350             return -1;
5351     }
5352     /*SUPPRESS 560*/
5353     else if (retval = memcmp(SvPV(str1), SvPV(str2), SvCUR(str2)))
5354         return retval;
5355     else if (SvCUR(str1) == SvCUR(str2))
5356         return 0;
5357     else
5358         return 1;
5359 }
5360
5361 PP(pp_warn)
5362 {
5363     dSP; dMARK;
5364     char *tmps;
5365     if (SP - MARK != 1) {
5366         dTARGET;
5367         do_join(TARG, sv_no, MARK, SP);
5368         tmps = SvPVn(TARG);
5369         SP = MARK + 1;
5370     }
5371     else {
5372         tmps = SvPVn(TOPs);
5373     }
5374     if (!tmps || !*tmps) {
5375         SV *error = GvSV(gv_fetchpv("@", TRUE));
5376         if (SvCUR(error))
5377             sv_catpv(error, "\t...caught");
5378         tmps = SvPVn(error);
5379     }
5380     if (!tmps || !*tmps)
5381         tmps = "Warning: something's wrong";
5382     warn("%s", tmps);
5383     RETSETYES;
5384 }
5385
5386 PP(pp_die)
5387 {
5388     dSP; dMARK;
5389     char *tmps;
5390     if (SP - MARK != 1) {
5391         dTARGET;
5392         do_join(TARG, sv_no, MARK, SP);
5393         tmps = SvPVn(TARG);
5394         SP = MARK + 1;
5395     }
5396     else {
5397         tmps = SvPVn(TOPs);
5398     }
5399     if (!tmps || !*tmps) {
5400         SV *error = GvSV(gv_fetchpv("@", TRUE));
5401         if (SvCUR(error))
5402             sv_catpv(error, "\t...propagated");
5403         tmps = SvPVn(error);
5404     }
5405     if (!tmps || !*tmps)
5406         tmps = "Died";
5407     DIE("%s", tmps);
5408 }
5409
5410 PP(pp_reset)
5411 {
5412     dSP;
5413     double value;
5414     char *tmps;
5415
5416     if (MAXARG < 1)
5417         tmps = "";
5418     else
5419         tmps = POPp;
5420     sv_reset(tmps, curcop->cop_stash);
5421     PUSHs(&sv_yes);
5422     RETURN;
5423 }
5424
5425 PP(pp_lineseq)
5426 {
5427     return NORMAL;
5428 }
5429
5430 PP(pp_curcop)
5431 {
5432     curcop = (COP*)op;
5433 #ifdef TAINT
5434     tainted = 0;        /* Each statement is presumed innocent */
5435 #endif
5436     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
5437     free_tmps();
5438     return NORMAL;
5439 }
5440
5441 PP(pp_unstack)
5442 {
5443     I32 oldsave;
5444 #ifdef TAINT
5445     tainted = 0;        /* Each statement is presumed innocent */
5446 #endif
5447     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
5448     /* XXX should tmps_floor live in cxstack? */
5449     while (tmps_ix > tmps_floor) {      /* clean up after last eval */
5450         sv_free(tmps_stack[tmps_ix]);
5451         tmps_stack[tmps_ix--] = Nullsv;
5452     }
5453     oldsave = scopestack[scopestack_ix - 1];
5454     if (savestack_ix > oldsave)
5455         leave_scope(oldsave);
5456     return NORMAL;
5457 }
5458
5459 PP(pp_enter)
5460 {
5461     dSP;
5462     register CONTEXT *cx;
5463     I32 gimme = GIMME;
5464     ENTER;
5465
5466     SAVETMPS;
5467     PUSHBLOCK(cx,CXt_BLOCK,sp);
5468
5469     RETURN;
5470 }
5471
5472 PP(pp_leave)
5473 {
5474     dSP;
5475     register CONTEXT *cx;
5476     I32 gimme;
5477     SV **newsp;
5478
5479     POPBLOCK(cx);
5480     LEAVE;
5481
5482     RETURN;
5483 }
5484
5485 PP(pp_enteriter)
5486 {
5487     dSP; dMARK;
5488     register CONTEXT *cx;
5489     SV **svp = &GvSV((GV*)POPs);
5490     I32 gimme = GIMME;
5491
5492     ENTER;
5493     SAVETMPS;
5494     ENTER;
5495
5496     PUSHBLOCK(cx,CXt_LOOP,SP);
5497     PUSHLOOP(cx, svp, MARK);
5498     cx->blk_loop.iterary = stack;
5499     cx->blk_loop.iterix = MARK - stack_base;
5500
5501     RETURN;
5502 }
5503
5504 PP(pp_iter)
5505 {
5506     dSP;
5507     register CONTEXT *cx;
5508     SV *sv;
5509
5510     EXTEND(sp, 1);
5511     cx = &cxstack[cxstack_ix];
5512     if (cx->cx_type != CXt_LOOP)
5513         DIE("panic: pp_iter");
5514
5515     if (cx->blk_loop.iterix >= cx->blk_oldsp)
5516         RETPUSHNO;
5517
5518     sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix];
5519     *cx->blk_loop.itervar = sv ? sv : &sv_undef;
5520
5521     RETPUSHYES;
5522 }
5523
5524 PP(pp_enterloop)
5525 {
5526     dSP;
5527     register CONTEXT *cx;
5528     I32 gimme = GIMME;
5529
5530     ENTER;
5531     SAVETMPS;
5532     ENTER;
5533
5534     PUSHBLOCK(cx, CXt_LOOP, SP);
5535     PUSHLOOP(cx, 0, SP);
5536
5537     RETURN;
5538 }
5539
5540 PP(pp_leaveloop)
5541 {
5542     dSP;
5543     register CONTEXT *cx;
5544     I32 gimme;
5545     SV **newsp;
5546     SV **mark;
5547
5548     POPBLOCK(cx);
5549     mark = newsp;
5550     POPLOOP(cx);
5551     if (gimme == G_SCALAR) {
5552         if (mark < SP)
5553             *++newsp = sv_mortalcopy(*SP);
5554         else
5555             *++newsp = &sv_undef;
5556     }
5557     else {
5558         while (mark < SP)
5559             *++newsp = sv_mortalcopy(*++mark);
5560     }
5561     sp = newsp;
5562     LEAVE;
5563     LEAVE;
5564
5565     RETURN;
5566 }
5567
5568 PP(pp_return)
5569 {
5570     dSP; dMARK;
5571     I32 cxix;
5572     register CONTEXT *cx;
5573     I32 gimme;
5574     SV **newsp;
5575     I32 optype = 0;
5576
5577     cxix = dopoptosub(cxstack_ix);
5578     if (cxix < 0)
5579         DIE("Can't return outside a subroutine");
5580     if (cxix < cxstack_ix)
5581         dounwind(cxix);
5582
5583     POPBLOCK(cx);
5584     switch (cx->cx_type) {
5585     case CXt_SUB:
5586         POPSUB(cx);
5587         break;
5588     case CXt_EVAL:
5589         POPEVAL(cx);
5590         break;
5591     default:
5592         DIE("panic: return");
5593         break;
5594     }
5595
5596     if (gimme == G_SCALAR) {
5597         if (MARK < SP)
5598             *++newsp = sv_mortalcopy(*SP);
5599         else
5600             *++newsp = &sv_undef;
5601         if (optype == OP_REQUIRE && !SvTRUE(*newsp))
5602             DIE("%s", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
5603     }
5604     else {
5605         if (optype == OP_REQUIRE && MARK == SP)
5606             DIE("%s", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
5607         while (MARK < SP)
5608             *++newsp = sv_mortalcopy(*++MARK);
5609     }
5610     stack_sp = newsp;
5611
5612     LEAVE;
5613     return pop_return();
5614 }
5615
5616 PP(pp_last)
5617 {
5618     dSP;
5619     I32 cxix;
5620     register CONTEXT *cx;
5621     I32 gimme;
5622     I32 optype;
5623     OP *nextop;
5624     SV **newsp;
5625     SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
5626     /* XXX The sp is probably not right yet... */
5627
5628     if (op->op_flags & OPf_SPECIAL) {
5629         cxix = dopoptoloop(cxstack_ix);
5630         if (cxix < 0)
5631             DIE("Can't \"last\" outside a block");
5632     }
5633     else {
5634         cxix = dopoptolabel(cPVOP->op_pv);
5635         if (cxix < 0)
5636             DIE("Label not found for \"last %s\"", cPVOP->op_pv);
5637     }
5638     if (cxix < cxstack_ix)
5639         dounwind(cxix);
5640
5641     POPBLOCK(cx);
5642     switch (cx->cx_type) {
5643     case CXt_LOOP:
5644         POPLOOP(cx);
5645         nextop = cx->blk_loop.last_op->op_next;
5646         LEAVE;
5647         break;
5648     case CXt_EVAL:
5649         POPEVAL(cx);
5650         nextop = pop_return();
5651         break;
5652     case CXt_SUB:
5653         POPSUB(cx);
5654         nextop = pop_return();
5655         break;
5656     default:
5657         DIE("panic: last");
5658         break;
5659     }
5660
5661     if (gimme == G_SCALAR) {
5662         if (mark < SP)
5663             *++newsp = sv_mortalcopy(*SP);
5664         else
5665             *++newsp = &sv_undef;
5666     }
5667     else {
5668         while (mark < SP)
5669             *++newsp = sv_mortalcopy(*++mark);
5670     }
5671     sp = newsp;
5672
5673     LEAVE;
5674     RETURNOP(nextop);
5675 }
5676
5677 PP(pp_next)
5678 {
5679     dSP;
5680     I32 cxix;
5681     register CONTEXT *cx;
5682     I32 oldsave;
5683
5684     if (op->op_flags & OPf_SPECIAL) {
5685         cxix = dopoptoloop(cxstack_ix);
5686         if (cxix < 0)
5687             DIE("Can't \"next\" outside a block");
5688     }
5689     else {
5690         cxix = dopoptolabel(cPVOP->op_pv);
5691         if (cxix < 0)
5692             DIE("Label not found for \"next %s\"", cPVOP->op_pv);
5693     }
5694     if (cxix < cxstack_ix)
5695         dounwind(cxix);
5696
5697     TOPBLOCK(cx);
5698     oldsave = scopestack[scopestack_ix - 1];
5699     if (savestack_ix > oldsave)
5700         leave_scope(oldsave);
5701     return cx->blk_loop.next_op;
5702 }
5703
5704 PP(pp_redo)
5705 {
5706     dSP;
5707     I32 cxix;
5708     register CONTEXT *cx;
5709     I32 oldsave;
5710
5711     if (op->op_flags & OPf_SPECIAL) {
5712         cxix = dopoptoloop(cxstack_ix);
5713         if (cxix < 0)
5714             DIE("Can't \"redo\" outside a block");
5715     }
5716     else {
5717         cxix = dopoptolabel(cPVOP->op_pv);
5718         if (cxix < 0)
5719             DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
5720     }
5721     if (cxix < cxstack_ix)
5722         dounwind(cxix);
5723
5724     TOPBLOCK(cx);
5725     oldsave = scopestack[scopestack_ix - 1];
5726     if (savestack_ix > oldsave)
5727         leave_scope(oldsave);
5728     return cx->blk_loop.redo_op;
5729 }
5730
5731 static OP* lastgotoprobe;
5732
5733 OP *
5734 dofindlabel(op,label,opstack)
5735 OP *op;
5736 char *label;
5737 OP **opstack;
5738 {
5739     OP *kid;
5740     OP **ops = opstack;
5741
5742     if (op->op_type == OP_LEAVE ||
5743         op->op_type == OP_LEAVELOOP ||
5744         op->op_type == OP_LEAVETRY)
5745             *ops++ = cUNOP->op_first;
5746     *ops = 0;
5747     if (op->op_flags & OPf_KIDS) {
5748         /* First try all the kids at this level, since that's likeliest. */
5749         for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
5750             if (kid->op_type == OP_CURCOP && kCOP->cop_label &&
5751               strEQ(kCOP->cop_label, label))
5752                 return kid;
5753         }
5754         for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
5755             if (kid == lastgotoprobe)
5756                 continue;
5757             if (kid->op_type == OP_CURCOP) {
5758                 if (ops > opstack && ops[-1]->op_type == OP_CURCOP)
5759                     *ops = kid;
5760                 else
5761                     *ops++ = kid;
5762             }
5763             if (op = dofindlabel(kid,label,ops))
5764                 return op;
5765         }
5766     }
5767     *ops = 0;
5768     return 0;
5769 }
5770
5771 PP(pp_dump)
5772 {
5773     return pp_goto(ARGS);
5774     /*NOTREACHED*/
5775 }
5776
5777 PP(pp_goto)
5778 {
5779     dSP;
5780     OP *retop = 0;
5781     I32 ix;
5782     register CONTEXT *cx;
5783     I32 entering = 0;
5784     OP *enterops[64];
5785     char *label;
5786
5787     label = 0;
5788     if (op->op_flags & OPf_SPECIAL) {
5789         if (op->op_type != OP_DUMP)
5790             DIE("goto must have label");
5791     }
5792     else
5793         label = cPVOP->op_pv;
5794
5795     if (label && *label) {
5796         OP *gotoprobe;
5797
5798         /* find label */
5799
5800         lastgotoprobe = 0;
5801         *enterops = 0;
5802         for (ix = cxstack_ix; ix >= 0; ix--) {
5803             cx = &cxstack[ix];
5804             switch (cx->cx_type) {
5805             case CXt_SUB:
5806                 gotoprobe = CvROOT(cx->blk_sub.cv);
5807                 break;
5808             case CXt_EVAL:
5809                 gotoprobe = eval_root; /* XXX not good for nested eval */
5810                 break;
5811             case CXt_LOOP:
5812                 gotoprobe = cx->blk_oldcop->op_sibling;
5813                 break;
5814             case CXt_SUBST:
5815                 continue;
5816             case CXt_BLOCK:
5817                 if (ix)
5818                     gotoprobe = cx->blk_oldcop->op_sibling;
5819                 else
5820                     gotoprobe = main_root;
5821                 break;
5822             default:
5823                 if (ix)
5824                     DIE("panic: goto");
5825                 else
5826                     gotoprobe = main_root;
5827                 break;
5828             }
5829             retop = dofindlabel(gotoprobe, label, enterops);
5830             if (retop)
5831                 break;
5832             lastgotoprobe = gotoprobe;
5833         }
5834         if (!retop)
5835             DIE("Can't find label %s", label);
5836
5837         /* pop unwanted frames */
5838
5839         if (ix < cxstack_ix) {
5840             I32 oldsave;
5841
5842             if (ix < 0)
5843                 ix = 0;
5844             dounwind(ix);
5845             TOPBLOCK(cx);
5846             oldsave = scopestack[scopestack_ix - 1];
5847             if (savestack_ix > oldsave)
5848                 leave_scope(oldsave);
5849         }
5850
5851         /* push wanted frames */
5852
5853         if (*enterops) {
5854             OP *oldop = op;
5855             for (ix = 0 + (gotoprobe == main_root); enterops[ix]; ix++) {
5856                 op = enterops[ix];
5857                 (*op->op_ppaddr)();
5858             }
5859             op = oldop;
5860         }
5861     }
5862
5863     if (op->op_type == OP_DUMP) {
5864         restartop = retop;
5865         do_undump = TRUE;
5866
5867         my_unexec();
5868
5869         restartop = 0;          /* hmm, must be GNU unexec().. */
5870         do_undump = FALSE;
5871     }
5872
5873     RETURNOP(retop);
5874 }
5875
5876 PP(pp_exit)
5877 {
5878     dSP;
5879     I32 anum;
5880
5881     if (MAXARG < 1)
5882         anum = 0;
5883     else
5884         anum = SvIVnx(POPs);
5885     my_exit(anum);
5886     PUSHs(&sv_undef);
5887     RETURN;
5888 }
5889
5890 PP(pp_nswitch)
5891 {
5892     dSP;
5893     double value = SvNVnx(GvSV(cCOP->cop_gv));
5894     register I32 match = (I32)value;
5895
5896     if (value < 0.0) {
5897         if (((double)match) > value)
5898             --match;            /* was fractional--truncate other way */
5899     }
5900     match -= cCOP->uop.scop.scop_offset;
5901     if (match < 0)
5902         match = 0;
5903     else if (match > cCOP->uop.scop.scop_max)
5904         match = cCOP->uop.scop.scop_max;
5905     op = cCOP->uop.scop.scop_next[match];
5906     RETURNOP(op);
5907 }
5908
5909 PP(pp_cswitch)
5910 {
5911     dSP;
5912     register I32 match;
5913
5914     if (multiline)
5915         op = op->op_next;                       /* can't assume anything */
5916     else {
5917         match = *(SvPVnx(GvSV(cCOP->cop_gv))) & 255;
5918         match -= cCOP->uop.scop.scop_offset;
5919         if (match < 0)
5920             match = 0;
5921         else if (match > cCOP->uop.scop.scop_max)
5922             match = cCOP->uop.scop.scop_max;
5923         op = cCOP->uop.scop.scop_next[match];
5924     }
5925     RETURNOP(op);
5926 }
5927
5928 /* I/O. */
5929
5930 PP(pp_open)
5931 {
5932     dSP; dTARGET;
5933     GV *gv;
5934     dPOPss;
5935     char *tmps;
5936
5937     gv = (GV*)POPs;
5938     tmps = SvPVn(sv);
5939     if (do_open(gv, tmps, SvCUR(sv))) {
5940         GvIO(gv)->lines = 0;
5941         PUSHi( (I32)forkprocess );
5942     }
5943     else if (forkprocess == 0)          /* we are a new child */
5944         PUSHi(0);
5945     else
5946         RETPUSHUNDEF;
5947     RETURN;
5948 }
5949
5950 PP(pp_close)
5951 {
5952     dSP;
5953     GV *gv;
5954
5955     if (MAXARG == 0)
5956         gv = defoutgv;
5957     else
5958         gv = (GV*)POPs;
5959     EXTEND(SP, 1);
5960     PUSHs( do_close(gv, TRUE) ? &sv_yes : &sv_no );
5961     RETURN;
5962 }
5963
5964 PP(pp_pipe_op)
5965 {
5966     dSP;
5967 #ifdef HAS_PIPE
5968     GV *rgv;
5969     GV *wgv;
5970     register IO *rstio;
5971     register IO *wstio;
5972     int fd[2];
5973
5974     wgv = (GV*)POPs;
5975     rgv = (GV*)POPs;
5976
5977     if (!rgv || !wgv)
5978         goto badexit;
5979
5980     rstio = GvIOn(rgv);
5981     wstio = GvIOn(wgv);
5982
5983     if (rstio->ifp)
5984         do_close(rgv, FALSE);
5985     if (wstio->ifp)
5986         do_close(wgv, FALSE);
5987
5988     if (pipe(fd) < 0)
5989         goto badexit;
5990
5991     rstio->ifp = fdopen(fd[0], "r");
5992     wstio->ofp = fdopen(fd[1], "w");
5993     wstio->ifp = wstio->ofp;
5994     rstio->type = '<';
5995     wstio->type = '>';
5996
5997     if (!rstio->ifp || !wstio->ofp) {
5998         if (rstio->ifp) fclose(rstio->ifp);
5999         else close(fd[0]);
6000         if (wstio->ofp) fclose(wstio->ofp);
6001         else close(fd[1]);
6002         goto badexit;
6003     }
6004
6005     RETPUSHYES;
6006
6007 badexit:
6008     RETPUSHUNDEF;
6009 #else
6010     DIE(no_func, "pipe");
6011 #endif
6012 }
6013
6014 PP(pp_fileno)
6015 {
6016     dSP; dTARGET;
6017     GV *gv;
6018     IO *io;
6019     FILE *fp;
6020     if (MAXARG < 1)
6021         RETPUSHUNDEF;
6022     gv = (GV*)POPs;
6023     if (!gv || !(io = GvIO(gv)) || !(fp = io->ifp))
6024         RETPUSHUNDEF;
6025     PUSHi(fileno(fp));
6026     RETURN;
6027 }
6028
6029 PP(pp_umask)
6030 {
6031     dSP; dTARGET;
6032     int anum;
6033
6034 #ifdef HAS_UMASK
6035     if (MAXARG < 1) {
6036         anum = umask(0);
6037         (void)umask(anum);
6038     }
6039     else
6040         anum = umask(POPi);
6041     TAINT_PROPER("umask");
6042     XPUSHi(anum);
6043 #else
6044     DIE(no_func, "Unsupported function umask");
6045 #endif
6046     RETURN;
6047 }
6048
6049 PP(pp_binmode)
6050 {
6051     dSP;
6052     GV *gv;
6053     IO *io;
6054     FILE *fp;
6055
6056     if (MAXARG < 1)
6057         RETPUSHUNDEF;
6058
6059     gv = (GV*)POPs;
6060
6061     EXTEND(SP, 1);
6062     if (!gv || !(io = GvIO(gv)) || !(fp = io->ifp))
6063         RETSETUNDEF;
6064
6065 #ifdef DOSISH
6066 #ifdef atarist
6067     if (!fflush(fp) && (fp->_flag |= _IOBIN))
6068         RETPUSHYES;
6069     else
6070         RETPUSHUNDEF;
6071 #else
6072     if (setmode(fileno(fp), OP_BINARY) != -1)
6073         RETPUSHYES;
6074     else
6075         RETPUSHUNDEF;
6076 #endif
6077 #else
6078     RETPUSHYES;
6079 #endif
6080 }
6081
6082 PP(pp_dbmopen)
6083 {
6084     dSP; dTARGET;
6085     int anum;
6086     HV *hv;
6087     dPOPPOPssrl;
6088
6089     hv = (HV*)POPs;
6090     if (SvOK(rstr))
6091         anum = SvIVn(rstr);
6092     else
6093         anum = -1;
6094 #ifdef SOME_DBM
6095     PUSHi( (I32)hv_dbmopen(hv, SvPVn(lstr), anum) );
6096 #else
6097     DIE("No dbm or ndbm on this machine");
6098 #endif
6099     RETURN;
6100 }
6101
6102 PP(pp_dbmclose)
6103 {
6104     dSP;
6105     I32 anum;
6106     HV *hv;
6107
6108     hv = (HV*)POPs;
6109 #ifdef SOME_DBM
6110     hv_dbmclose(hv);
6111     RETPUSHYES;
6112 #else
6113     DIE("No dbm or ndbm on this machine");
6114 #endif
6115 }
6116
6117 PP(pp_sselect)
6118 {
6119     dSP; dTARGET;
6120 #ifdef HAS_SELECT
6121     register I32 i;
6122     register I32 j;
6123     register char *s;
6124     register SV *sv;
6125     double value;
6126     I32 maxlen = 0;
6127     I32 nfound;
6128     struct timeval timebuf;
6129     struct timeval *tbuf = &timebuf;
6130     I32 growsize;
6131     char *fd_sets[4];
6132 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
6133         I32 masksize;
6134         I32 offset;
6135         I32 k;
6136
6137 #   if BYTEORDER & 0xf0000
6138 #       define ORDERBYTE (0x88888888 - BYTEORDER)
6139 #   else
6140 #       define ORDERBYTE (0x4444 - BYTEORDER)
6141 #   endif
6142
6143 #endif
6144
6145     SP -= 4;
6146     for (i = 1; i <= 3; i++) {
6147         if (!SvPOK(SP[i]))
6148             continue;
6149         j = SvCUR(SP[i]);
6150         if (maxlen < j)
6151             maxlen = j;
6152     }
6153
6154 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
6155     growsize = maxlen;          /* little endians can use vecs directly */
6156 #else
6157 #ifdef NFDBITS
6158
6159 #ifndef NBBY
6160 #define NBBY 8
6161 #endif
6162
6163     masksize = NFDBITS / NBBY;
6164 #else
6165     masksize = sizeof(long);    /* documented int, everyone seems to use long */
6166 #endif
6167     growsize = maxlen + (masksize - (maxlen % masksize));
6168     Zero(&fd_sets[0], 4, char*);
6169 #endif
6170
6171     sv = SP[4];
6172     if (SvOK(sv)) {
6173         value = SvNVn(sv);
6174         if (value < 0.0)
6175             value = 0.0;
6176         timebuf.tv_sec = (long)value;
6177         value -= (double)timebuf.tv_sec;
6178         timebuf.tv_usec = (long)(value * 1000000.0);
6179     }
6180     else
6181         tbuf = Null(struct timeval*);
6182
6183     for (i = 1; i <= 3; i++) {
6184         sv = SP[i];
6185         if (!SvPOK(sv)) {
6186             fd_sets[i] = 0;
6187             continue;
6188         }
6189         j = SvLEN(sv);
6190         if (j < growsize) {
6191             Sv_Grow(sv, growsize);
6192             s = SvPVn(sv) + j;
6193             while (++j <= growsize) {
6194                 *s++ = '\0';
6195             }
6196         }
6197 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
6198         s = SvPV(sv);
6199         New(403, fd_sets[i], growsize, char);
6200         for (offset = 0; offset < growsize; offset += masksize) {
6201             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
6202                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
6203         }
6204 #else
6205         fd_sets[i] = SvPV(sv);
6206 #endif
6207     }
6208
6209     nfound = select(
6210         maxlen * 8,
6211         fd_sets[1],
6212         fd_sets[2],
6213         fd_sets[3],
6214         tbuf);
6215 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
6216     for (i = 1; i <= 3; i++) {
6217         if (fd_sets[i]) {
6218             sv = SP[i];
6219             s = SvPV(sv);
6220             for (offset = 0; offset < growsize; offset += masksize) {
6221                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
6222                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
6223             }
6224             Safefree(fd_sets[i]);
6225         }
6226     }
6227 #endif
6228
6229     PUSHi(nfound);
6230     if (GIMME == G_ARRAY && tbuf) {
6231         value = (double)(timebuf.tv_sec) +
6232                 (double)(timebuf.tv_usec) / 1000000.0;
6233         PUSHs(sv = sv_mortalcopy(&sv_no));
6234         sv_setnv(sv, value);
6235     }
6236     RETURN;
6237 #else
6238     DIE("select not implemented");
6239 #endif
6240 }
6241
6242 PP(pp_select)
6243 {
6244     dSP; dTARGET;
6245     GV *oldgv = defoutgv;
6246     if (op->op_private > 0) {
6247         defoutgv = (GV*)POPs;
6248         if (!GvIO(defoutgv))
6249             GvIO(defoutgv) = newIO();
6250         curoutgv = defoutgv;
6251     }
6252     gv_efullname(TARG, oldgv);
6253     XPUSHTARG;
6254     RETURN;
6255 }
6256
6257 PP(pp_getc)
6258 {
6259     dSP; dTARGET;
6260     GV *gv;
6261
6262     if (MAXARG <= 0)
6263         gv = stdingv;
6264     else
6265         gv = (GV*)POPs;
6266     if (!gv)
6267         gv = argvgv;
6268     if (!gv || do_eof(gv)) /* make sure we have fp with something */
6269         RETPUSHUNDEF;
6270     TAINT_IF(1);
6271     sv_setpv(TARG, " ");
6272     *SvPV(TARG) = getc(GvIO(gv)->ifp); /* should never be EOF */
6273     PUSHTARG;
6274     RETURN;
6275 }
6276
6277 PP(pp_read)
6278 {
6279     return pp_sysread(ARGS);
6280 }
6281
6282 static OP *
6283 doform(cv,gv,retop)
6284 CV *cv;
6285 GV *gv;
6286 OP *retop;
6287 {
6288     register CONTEXT *cx;
6289     I32 gimme = GIMME;
6290     ENTER;
6291     SAVETMPS;
6292
6293     push_return(retop);
6294     PUSHBLOCK(cx, CXt_SUB, stack_sp);
6295     PUSHFORMAT(cx);
6296     defoutgv = gv;              /* locally select filehandle so $% et al work */
6297     return CvSTART(cv);
6298 }
6299
6300 PP(pp_enterwrite)
6301 {
6302     dSP;
6303     register GV *gv;
6304     register IO *io;
6305     GV *fgv;
6306     FILE *fp;
6307     CV *cv;
6308
6309     if (MAXARG == 0)
6310         gv = defoutgv;
6311     else {
6312         gv = (GV*)POPs;
6313         if (!gv)
6314             gv = defoutgv;
6315     }
6316     EXTEND(SP, 1);
6317     io = GvIO(gv);
6318     if (!io) {
6319         RETPUSHNO;
6320     }
6321     curoutgv = gv;
6322     if (io->fmt_gv)
6323         fgv = io->fmt_gv;
6324     else
6325         fgv = gv;
6326
6327     cv = GvFORM(fgv);
6328
6329     if (!cv) {
6330         if (fgv) {
6331             SV *tmpstr = sv_mortalcopy(&sv_undef);
6332             gv_efullname(tmpstr, gv);
6333             DIE("Undefined format \"%s\" called",SvPV(tmpstr));
6334         }
6335         DIE("Not a format reference");
6336     }
6337
6338     return doform(cv,gv,op->op_next);
6339 }
6340
6341 PP(pp_leavewrite)
6342 {
6343     dSP;
6344     GV *gv = cxstack[cxstack_ix].blk_sub.gv;
6345     register IO *io = GvIO(gv);
6346     FILE *ofp = io->ofp;
6347     FILE *fp;
6348     SV **mark;
6349     SV **newsp;
6350     I32 gimme;
6351     register CONTEXT *cx;
6352
6353     DEBUG_f(fprintf(stderr,"left=%ld, todo=%ld\n",
6354           (long)io->lines_left, (long)FmLINES(formtarget)));
6355     if (io->lines_left < FmLINES(formtarget) &&
6356         formtarget != toptarget)
6357     {
6358         if (!io->top_gv) {
6359             GV *topgv;
6360             char tmpbuf[256];
6361
6362             if (!io->top_name) {
6363                 if (!io->fmt_name)
6364                     io->fmt_name = savestr(GvNAME(gv));
6365                 sprintf(tmpbuf, "%s_TOP", io->fmt_name);
6366                 topgv = gv_fetchpv(tmpbuf,FALSE);
6367                 if (topgv && GvFORM(topgv))
6368                     io->top_name = savestr(tmpbuf);
6369                 else
6370                     io->top_name = savestr("top");
6371             }
6372             topgv = gv_fetchpv(io->top_name,FALSE);
6373             if (!topgv || !GvFORM(topgv)) {
6374                 io->lines_left = 100000000;
6375                 goto forget_top;
6376             }
6377             io->top_gv = topgv;
6378         }
6379         if (io->lines_left >= 0 && io->page > 0)
6380             fwrite(SvPV(formfeed), SvCUR(formfeed), 1, ofp);
6381         io->lines_left = io->page_len;
6382         io->page++;
6383         formtarget = toptarget;
6384         return doform(GvFORM(io->top_gv),gv,op);
6385     }
6386
6387   forget_top:
6388     POPBLOCK(cx);
6389     POPFORMAT(cx);
6390     LEAVE;
6391
6392     fp = io->ofp;
6393     if (!fp) {
6394         if (dowarn) {
6395             if (io->ifp)
6396                 warn("Filehandle only opened for input");
6397             else
6398                 warn("Write on closed filehandle");
6399         }
6400         PUSHs(&sv_no);
6401     }
6402     else {
6403         if ((io->lines_left -= FmLINES(formtarget)) < 0) {
6404             if (dowarn)
6405                 warn("page overflow");
6406         }
6407         if (!fwrite(SvPV(formtarget), 1, SvCUR(formtarget), ofp) ||
6408                 ferror(fp))
6409             PUSHs(&sv_no);
6410         else {
6411             FmLINES(formtarget) = 0;
6412             SvCUR_set(formtarget, 0);
6413             if (io->flags & IOf_FLUSH)
6414                 (void)fflush(fp);
6415             PUSHs(&sv_yes);
6416         }
6417     }
6418     formtarget = bodytarget;
6419     PUTBACK;
6420     return pop_return();
6421 }
6422
6423 PP(pp_prtf)
6424 {
6425     dSP; dMARK; dORIGMARK;
6426     GV *gv;
6427     IO *io;
6428     FILE *fp;
6429     SV *sv = NEWSV(0,0);
6430
6431     if (op->op_flags & OPf_STACKED)
6432         gv = (GV*)*++MARK;
6433     else
6434         gv = defoutgv;
6435     if (!(io = GvIO(gv))) {
6436         if (dowarn)
6437             warn("Filehandle never opened");
6438         errno = EBADF;
6439         goto just_say_no;
6440     }
6441     else if (!(fp = io->ofp)) {
6442         if (dowarn)  {
6443             if (io->ifp)
6444                 warn("Filehandle opened only for input");
6445             else
6446                 warn("printf on closed filehandle");
6447         }
6448         errno = EBADF;
6449         goto just_say_no;
6450     }
6451     else {
6452         do_sprintf(sv, SP - MARK, MARK + 1);
6453         if (!do_print(sv, fp))
6454             goto just_say_no;
6455
6456         if (io->flags & IOf_FLUSH)
6457             if (fflush(fp) == EOF)
6458                 goto just_say_no;
6459     }
6460     sv_free(sv);
6461     SP = ORIGMARK;
6462     PUSHs(&sv_yes);
6463     RETURN;
6464
6465   just_say_no:
6466     sv_free(sv);
6467     SP = ORIGMARK;
6468     PUSHs(&sv_undef);
6469     RETURN;
6470 }
6471
6472 PP(pp_print)
6473 {
6474     dSP; dMARK; dORIGMARK;
6475     GV *gv;
6476     IO *io;
6477     register FILE *fp;
6478
6479     if (op->op_flags & OPf_STACKED)
6480         gv = (GV*)*++MARK;
6481     else
6482         gv = defoutgv;
6483     if (!(io = GvIO(gv))) {
6484         if (dowarn)
6485             warn("Filehandle never opened");
6486         errno = EBADF;
6487         goto just_say_no;
6488     }
6489     else if (!(fp = io->ofp)) {
6490         if (dowarn)  {
6491             if (io->ifp)
6492                 warn("Filehandle opened only for input");
6493             else
6494                 warn("print on closed filehandle");
6495         }
6496         errno = EBADF;
6497         goto just_say_no;
6498     }
6499     else {
6500         MARK++;
6501         if (ofslen) {
6502             while (MARK <= SP) {
6503                 if (!do_print(*MARK, fp))
6504                     break;
6505                 MARK++;
6506                 if (MARK <= SP) {
6507                     if (fwrite(ofs, 1, ofslen, fp) == 0 || ferror(fp)) {
6508                         MARK--;
6509                         break;
6510                     }
6511                 }
6512             }
6513         }
6514         else {
6515             while (MARK <= SP) {
6516                 if (!do_print(*MARK, fp))
6517                     break;
6518                 MARK++;
6519             }
6520         }
6521         if (MARK <= SP)
6522             goto just_say_no;
6523         else {
6524             if (orslen)
6525                 if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp))
6526                     goto just_say_no;
6527
6528             if (io->flags & IOf_FLUSH)
6529                 if (fflush(fp) == EOF)
6530                     goto just_say_no;
6531         }
6532     }
6533     SP = ORIGMARK;
6534     PUSHs(&sv_yes);
6535     RETURN;
6536
6537   just_say_no:
6538     SP = ORIGMARK;
6539     PUSHs(&sv_undef);
6540     RETURN;
6541 }
6542
6543 PP(pp_sysread)
6544 {
6545     dSP; dMARK; dORIGMARK; dTARGET;
6546     int offset;
6547     GV *gv;
6548     IO *io;
6549     char *buffer;
6550     int length;
6551     int bufsize;
6552     SV *bufstr;
6553
6554     gv = (GV*)*++MARK;
6555     if (!gv)
6556         goto say_undef;
6557     bufstr = *++MARK;
6558     buffer = SvPVn(bufstr);
6559     length = SvIVnx(*++MARK);
6560     errno = 0;
6561     if (MARK < SP)
6562         offset = SvIVnx(*++MARK);
6563     else
6564         offset = 0;
6565     if (MARK < SP)
6566         warn("Too many args on read");
6567     io = GvIO(gv);
6568     if (!io || !io->ifp)
6569         goto say_undef;
6570 #ifdef HAS_SOCKET
6571     if (op->op_type == OP_RECV) {
6572         bufsize = sizeof buf;
6573         SvGROW(bufstr, length+1), (buffer = SvPVn(bufstr));  /* sneaky */
6574         length = recvfrom(fileno(io->ifp), buffer, length, offset,
6575             buf, &bufsize);
6576         if (length < 0)
6577             RETPUSHUNDEF;
6578         SvCUR_set(bufstr, length);
6579         *SvEND(bufstr) = '\0';
6580         SvNOK_off(bufstr);
6581         SP = ORIGMARK;
6582         sv_setpvn(TARG, buf, bufsize);
6583         PUSHs(TARG);
6584         RETURN;
6585     }
6586 #else
6587     if (op->op_type == OP_RECV)
6588         DIE(no_sock_func, "recv");
6589 #endif
6590     SvGROW(bufstr, length+offset+1), (buffer = SvPVn(bufstr));  /* sneaky */
6591     if (op->op_type == OP_SYSREAD) {
6592         length = read(fileno(io->ifp), buffer+offset, length);
6593     }
6594     else
6595 #ifdef HAS_SOCKET
6596     if (io->type == 's') {
6597         bufsize = sizeof buf;
6598         length = recvfrom(fileno(io->ifp), buffer+offset, length, 0,
6599             buf, &bufsize);
6600     }
6601     else
6602 #endif
6603         length = fread(buffer+offset, 1, length, io->ifp);
6604     if (length < 0)
6605         goto say_undef;
6606     SvCUR_set(bufstr, length+offset);
6607     *SvEND(bufstr) = '\0';
6608     SvNOK_off(bufstr);
6609     SP = ORIGMARK;
6610     PUSHi(length);
6611     RETURN;
6612
6613   say_undef:
6614     SP = ORIGMARK;
6615     RETPUSHUNDEF;
6616 }
6617
6618 PP(pp_syswrite)
6619 {
6620     return pp_send(ARGS);
6621 }
6622
6623 PP(pp_send)
6624 {
6625     dSP; dMARK; dORIGMARK; dTARGET;
6626     GV *gv;
6627     IO *io;
6628     int offset;
6629     SV *bufstr;
6630     char *buffer;
6631     int length;
6632
6633     gv = (GV*)*++MARK;
6634     if (!gv)
6635         goto say_undef;
6636     bufstr = *++MARK;
6637     buffer = SvPVn(bufstr);
6638     length = SvIVnx(*++MARK);
6639     errno = 0;
6640     io = GvIO(gv);
6641     if (!io || !io->ifp) {
6642         length = -1;
6643         if (dowarn) {
6644             if (op->op_type == OP_SYSWRITE)
6645                 warn("Syswrite on closed filehandle");
6646             else
6647                 warn("Send on closed socket");
6648         }
6649     }
6650     else if (op->op_type == OP_SYSWRITE) {
6651         if (MARK < SP)
6652             offset = SvIVnx(*++MARK);
6653         else
6654             offset = 0;
6655         if (MARK < SP)
6656             warn("Too many args on syswrite");
6657         length = write(fileno(io->ifp), buffer+offset, length);
6658     }
6659 #ifdef HAS_SOCKET
6660     else if (SP >= MARK) {
6661         if (SP > MARK)
6662             warn("Too many args on send");
6663         buffer = SvPVnx(*++MARK);
6664         length = sendto(fileno(io->ifp), buffer, SvCUR(bufstr),
6665           length, buffer, SvCUR(*MARK));
6666     }
6667     else
6668         length = send(fileno(io->ifp), buffer, SvCUR(bufstr), length);
6669 #else
6670     else
6671         DIE(no_sock_func, "send");
6672 #endif
6673     if (length < 0)
6674         goto say_undef;
6675     SP = ORIGMARK;
6676     PUSHi(length);
6677     RETURN;
6678
6679   say_undef:
6680     SP = ORIGMARK;
6681     RETPUSHUNDEF;
6682 }
6683
6684 PP(pp_recv)
6685 {
6686     return pp_sysread(ARGS);
6687 }
6688
6689 PP(pp_eof)
6690 {
6691     dSP;
6692     GV *gv;
6693
6694     if (MAXARG <= 0)
6695         gv = last_in_gv;
6696     else
6697         gv = (GV*)POPs;
6698     PUSHs(do_eof(gv) ? &sv_yes : &sv_no);
6699     RETURN;
6700 }
6701
6702 PP(pp_tell)
6703 {
6704     dSP; dTARGET;
6705     GV *gv;
6706
6707     if (MAXARG <= 0)
6708         gv = last_in_gv;
6709     else
6710         gv = (GV*)POPs;
6711     PUSHi( do_tell(gv) );
6712     RETURN;
6713 }
6714
6715 PP(pp_seek)
6716 {
6717     dSP;
6718     GV *gv;
6719     int whence = POPi;
6720     long offset = POPl;
6721
6722     gv = (GV*)POPs;
6723     PUSHs( do_seek(gv, offset, whence) ? &sv_yes : &sv_no );
6724     RETURN;
6725 }
6726
6727 PP(pp_truncate)
6728 {
6729     dSP;
6730     off_t len = (off_t)POPn;
6731     int result = 1;
6732     GV *tmpgv;
6733
6734     errno = 0;
6735 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE)
6736 #ifdef HAS_TRUNCATE
6737     if (op->op_flags & OPf_SPECIAL) {
6738         tmpgv = gv_fetchpv(POPp,FALSE);
6739         if (!tmpgv || !GvIO(tmpgv) || !GvIO(tmpgv)->ifp ||
6740           ftruncate(fileno(GvIO(tmpgv)->ifp), len) < 0)
6741             result = 0;
6742     }
6743     else if (truncate(POPp, len) < 0)
6744         result = 0;
6745 #else
6746     if (op->op_flags & OPf_SPECIAL) {
6747         tmpgv = gv_fetchpv(POPp,FALSE);
6748         if (!tmpgv || !GvIO(tmpgv) || !GvIO(tmpgv)->ifp ||
6749           chsize(fileno(GvIO(tmpgv)->ifp), len) < 0)
6750             result = 0;
6751     }
6752     else {
6753         int tmpfd;
6754
6755         if ((tmpfd = open(POPp, 0)) < 0)
6756             result = 0;
6757         else {
6758             if (chsize(tmpfd, len) < 0)
6759                 result = 0;
6760             close(tmpfd);
6761         }
6762     }
6763 #endif
6764
6765     if (result)
6766         RETPUSHYES;
6767     if (!errno)
6768         errno = EBADF;
6769     RETPUSHUNDEF;
6770 #else
6771     DIE("truncate not implemented");
6772 #endif
6773 }
6774
6775 PP(pp_fcntl)
6776 {
6777     return pp_ioctl(ARGS);
6778 }
6779
6780 PP(pp_ioctl)
6781 {
6782     dSP; dTARGET;
6783     SV *argstr = POPs;
6784     unsigned int func = U_I(POPn);
6785     int optype = op->op_type;
6786     char *s;
6787     int retval;
6788     GV *gv = (GV*)POPs;
6789     IO *io = GvIOn(gv);
6790
6791     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
6792
6793     if (!io || !argstr || !io->ifp) {
6794         errno = EBADF;  /* well, sort of... */
6795         RETPUSHUNDEF;
6796     }
6797
6798     if (SvPOK(argstr) || !SvNIOK(argstr)) {
6799         if (!SvPOK(argstr))
6800             s = SvPVn(argstr);
6801         retval = IOCPARM_LEN(func);
6802         if (SvCUR(argstr) < retval) {
6803             Sv_Grow(argstr, retval+1);
6804             SvCUR_set(argstr, retval);
6805         }
6806
6807         s = SvPV(argstr);
6808         s[SvCUR(argstr)] = 17;  /* a little sanity check here */
6809     }
6810     else {
6811         retval = SvIVn(argstr);
6812 #ifdef DOSISH
6813         s = (char*)(long)retval;        /* ouch */
6814 #else
6815         s = (char*)retval;              /* ouch */
6816 #endif
6817     }
6818
6819     if (optype == OP_IOCTL)
6820         retval = ioctl(fileno(io->ifp), func, s);
6821     else
6822 #ifdef DOSISH
6823         DIE("fcntl is not implemented");
6824 #else
6825 #   ifdef HAS_FCNTL
6826         retval = fcntl(fileno(io->ifp), func, s);
6827 #   else
6828         DIE("fcntl is not implemented");
6829 #   endif
6830 #endif
6831
6832     if (SvPOK(argstr)) {
6833         if (s[SvCUR(argstr)] != 17)
6834             DIE("Return value overflowed string");
6835         s[SvCUR(argstr)] = 0;           /* put our null back */
6836     }
6837
6838     if (retval == -1)
6839         RETPUSHUNDEF;
6840     if (retval != 0) {
6841         PUSHi(retval);
6842     }
6843     else {
6844         PUSHp("0 but true", 10);
6845     }
6846     RETURN;
6847 }
6848
6849 PP(pp_flock)
6850 {
6851     dSP; dTARGET;
6852     I32 value;
6853     int argtype;
6854     GV *gv;
6855     FILE *fp;
6856 #ifdef HAS_FLOCK
6857     argtype = POPi;
6858     if (MAXARG <= 0)
6859         gv = last_in_gv;
6860     else
6861         gv = (GV*)POPs;
6862     if (gv && GvIO(gv))
6863         fp = GvIO(gv)->ifp;
6864     else
6865         fp = Nullfp;
6866     if (fp) {
6867         value = (I32)(flock(fileno(fp), argtype) >= 0);
6868     }
6869     else
6870         value = 0;
6871     PUSHi(value);
6872     RETURN;
6873 #else
6874     DIE(no_func, "flock()");
6875 #endif
6876 }
6877
6878 /* Sockets. */
6879
6880 PP(pp_socket)
6881 {
6882     dSP;
6883 #ifdef HAS_SOCKET
6884     GV *gv;
6885     register IO *io;
6886     int protocol = POPi;
6887     int type = POPi;
6888     int domain = POPi;
6889     int fd;
6890
6891     gv = (GV*)POPs;
6892
6893     if (!gv) {
6894         errno = EBADF;
6895         RETPUSHUNDEF;
6896     }
6897
6898     io = GvIOn(gv);
6899     if (io->ifp)
6900         do_close(gv, FALSE);
6901
6902     TAINT_PROPER("socket");
6903     fd = socket(domain, type, protocol);
6904     if (fd < 0)
6905         RETPUSHUNDEF;
6906     io->ifp = fdopen(fd, "r");  /* stdio gets confused about sockets */
6907     io->ofp = fdopen(fd, "w");
6908     io->type = 's';
6909     if (!io->ifp || !io->ofp) {
6910         if (io->ifp) fclose(io->ifp);
6911         if (io->ofp) fclose(io->ofp);
6912         if (!io->ifp && !io->ofp) close(fd);
6913         RETPUSHUNDEF;
6914     }
6915
6916     RETPUSHYES;
6917 #else
6918     DIE(no_sock_func, "socket");
6919 #endif
6920 }
6921
6922 PP(pp_sockpair)
6923 {
6924     dSP;
6925 #ifdef HAS_SOCKETPAIR
6926     GV *gv1;
6927     GV *gv2;
6928     register IO *io1;
6929     register IO *io2;
6930     int protocol = POPi;
6931     int type = POPi;
6932     int domain = POPi;
6933     int fd[2];
6934
6935     gv2 = (GV*)POPs;
6936     gv1 = (GV*)POPs;
6937     if (!gv1 || !gv2)
6938         RETPUSHUNDEF;
6939
6940     io1 = GvIOn(gv1);
6941     io2 = GvIOn(gv2);
6942     if (io1->ifp)
6943         do_close(gv1, FALSE);
6944     if (io2->ifp)
6945         do_close(gv2, FALSE);
6946
6947     TAINT_PROPER("socketpair");
6948     if (socketpair(domain, type, protocol, fd) < 0)
6949         RETPUSHUNDEF;
6950     io1->ifp = fdopen(fd[0], "r");
6951     io1->ofp = fdopen(fd[0], "w");
6952     io1->type = 's';
6953     io2->ifp = fdopen(fd[1], "r");
6954     io2->ofp = fdopen(fd[1], "w");
6955     io2->type = 's';
6956     if (!io1->ifp || !io1->ofp || !io2->ifp || !io2->ofp) {
6957         if (io1->ifp) fclose(io1->ifp);
6958         if (io1->ofp) fclose(io1->ofp);
6959         if (!io1->ifp && !io1->ofp) close(fd[0]);
6960         if (io2->ifp) fclose(io2->ifp);
6961         if (io2->ofp) fclose(io2->ofp);
6962         if (!io2->ifp && !io2->ofp) close(fd[1]);
6963         RETPUSHUNDEF;
6964     }
6965
6966     RETPUSHYES;
6967 #else
6968     DIE(no_sock_func, "socketpair");
6969 #endif
6970 }
6971
6972 PP(pp_bind)
6973 {
6974     dSP;
6975 #ifdef HAS_SOCKET
6976     SV *addrstr = POPs;
6977     char *addr;
6978     GV *gv = (GV*)POPs;
6979     register IO *io = GvIOn(gv);
6980
6981     if (!io || !io->ifp)
6982         goto nuts;
6983
6984     addr = SvPVn(addrstr);
6985     TAINT_PROPER("bind");
6986     if (bind(fileno(io->ifp), addr, SvCUR(addrstr)) >= 0)
6987         RETPUSHYES;
6988     else
6989         RETPUSHUNDEF;
6990
6991 nuts:
6992     if (dowarn)
6993         warn("bind() on closed fd");
6994     errno = EBADF;
6995     RETPUSHUNDEF;
6996 #else
6997     DIE(no_sock_func, "bind");
6998 #endif
6999 }
7000
7001 PP(pp_connect)
7002 {
7003     dSP;
7004 #ifdef HAS_SOCKET
7005     SV *addrstr = POPs;
7006     char *addr;
7007     GV *gv = (GV*)POPs;
7008     register IO *io = GvIOn(gv);
7009
7010     if (!io || !io->ifp)
7011         goto nuts;
7012
7013     addr = SvPVn(addrstr);
7014     TAINT_PROPER("connect");
7015     if (connect(fileno(io->ifp), addr, SvCUR(addrstr)) >= 0)
7016         RETPUSHYES;
7017     else
7018         RETPUSHUNDEF;
7019
7020 nuts:
7021     if (dowarn)
7022         warn("connect() on closed fd");
7023     errno = EBADF;
7024     RETPUSHUNDEF;
7025 #else
7026     DIE(no_sock_func, "connect");
7027 #endif
7028 }
7029
7030 PP(pp_listen)
7031 {
7032     dSP;
7033 #ifdef HAS_SOCKET
7034     int backlog = POPi;
7035     GV *gv = (GV*)POPs;
7036     register IO *io = GvIOn(gv);
7037
7038     if (!io || !io->ifp)
7039         goto nuts;
7040
7041     if (listen(fileno(io->ifp), backlog) >= 0)
7042         RETPUSHYES;
7043     else
7044         RETPUSHUNDEF;
7045
7046 nuts:
7047     if (dowarn)
7048         warn("listen() on closed fd");
7049     errno = EBADF;
7050     RETPUSHUNDEF;
7051 #else
7052     DIE(no_sock_func, "listen");
7053 #endif
7054 }
7055
7056 PP(pp_accept)
7057 {
7058     dSP; dTARGET;
7059 #ifdef HAS_SOCKET
7060     GV *ngv;
7061     GV *ggv;
7062     register IO *nstio;
7063     register IO *gstio;
7064     int len = sizeof buf;
7065     int fd;
7066
7067     ggv = (GV*)POPs;
7068     ngv = (GV*)POPs;
7069
7070     if (!ngv)
7071         goto badexit;
7072     if (!ggv)
7073         goto nuts;
7074
7075     gstio = GvIO(ggv);
7076     if (!gstio || !gstio->ifp)
7077         goto nuts;
7078
7079     nstio = GvIOn(ngv);
7080     if (nstio->ifp)
7081         do_close(ngv, FALSE);
7082
7083     fd = accept(fileno(gstio->ifp), (struct sockaddr *)buf, &len);
7084     if (fd < 0)
7085         goto badexit;
7086     nstio->ifp = fdopen(fd, "r");
7087     nstio->ofp = fdopen(fd, "w");
7088     nstio->type = 's';
7089     if (!nstio->ifp || !nstio->ofp) {
7090         if (nstio->ifp) fclose(nstio->ifp);
7091         if (nstio->ofp) fclose(nstio->ofp);
7092         if (!nstio->ifp && !nstio->ofp) close(fd);
7093         goto badexit;
7094     }
7095
7096     PUSHp(buf, len);
7097     RETURN;
7098
7099 nuts:
7100     if (dowarn)
7101         warn("accept() on closed fd");
7102     errno = EBADF;
7103
7104 badexit:
7105     RETPUSHUNDEF;
7106
7107 #else
7108     DIE(no_sock_func, "accept");
7109 #endif
7110 }
7111
7112 PP(pp_shutdown)
7113 {
7114     dSP; dTARGET;
7115 #ifdef HAS_SOCKET
7116     int how = POPi;
7117     GV *gv = (GV*)POPs;
7118     register IO *io = GvIOn(gv);
7119
7120     if (!io || !io->ifp)
7121         goto nuts;
7122
7123     PUSHi( shutdown(fileno(io->ifp), how) >= 0 );
7124     RETURN;
7125
7126 nuts:
7127     if (dowarn)
7128         warn("shutdown() on closed fd");
7129     errno = EBADF;
7130     RETPUSHUNDEF;
7131 #else
7132     DIE(no_sock_func, "shutdown");
7133 #endif
7134 }
7135
7136 PP(pp_gsockopt)
7137 {
7138 #ifdef HAS_SOCKET
7139     return pp_ssockopt(ARGS);
7140 #else
7141     DIE(no_sock_func, "getsockopt");
7142 #endif
7143 }
7144
7145 PP(pp_ssockopt)
7146 {
7147     dSP;
7148 #ifdef HAS_SOCKET
7149     int optype = op->op_type;
7150     SV *sv;
7151     int fd;
7152     unsigned int optname;
7153     unsigned int lvl;
7154     GV *gv;
7155     register IO *io;
7156
7157     if (optype == OP_GSOCKOPT)
7158         sv = sv_2mortal(NEWSV(22, 257));
7159     else
7160         sv = POPs;
7161     optname = (unsigned int) POPi;
7162     lvl = (unsigned int) POPi;
7163
7164     gv = (GV*)POPs;
7165     io = GvIOn(gv);
7166     if (!io || !io->ifp)
7167         goto nuts;
7168
7169     fd = fileno(io->ifp);
7170     switch (optype) {
7171     case OP_GSOCKOPT:
7172         SvCUR_set(sv, 256);
7173         SvPOK_on(sv);
7174         if (getsockopt(fd, lvl, optname, SvPV(sv), (int*)&SvCUR(sv)) < 0)
7175             goto nuts2;
7176         PUSHs(sv);
7177         break;
7178     case OP_SSOCKOPT:
7179         if (setsockopt(fd, lvl, optname, SvPV(sv), SvCUR(sv)) < 0)
7180             goto nuts2;
7181         PUSHs(&sv_yes);
7182         break;
7183     }
7184     RETURN;
7185
7186 nuts:
7187     if (dowarn)
7188         warn("[gs]etsockopt() on closed fd");
7189     errno = EBADF;
7190 nuts2:
7191     RETPUSHUNDEF;
7192
7193 #else
7194     DIE(no_sock_func, "setsockopt");
7195 #endif
7196 }
7197
7198 PP(pp_getsockname)
7199 {
7200 #ifdef HAS_SOCKET
7201     return pp_getpeername(ARGS);
7202 #else
7203     DIE(no_sock_func, "getsockname");
7204 #endif
7205 }
7206
7207 PP(pp_getpeername)
7208 {
7209     dSP;
7210 #ifdef HAS_SOCKET
7211     int optype = op->op_type;
7212     SV *sv;
7213     int fd;
7214     GV *gv = (GV*)POPs;
7215     register IO *io = GvIOn(gv);
7216
7217     if (!io || !io->ifp)
7218         goto nuts;
7219
7220     sv = sv_2mortal(NEWSV(22, 257));
7221     SvCUR_set(sv, 256);
7222     SvPOK_on(sv);
7223     fd = fileno(io->ifp);
7224     switch (optype) {
7225     case OP_GETSOCKNAME:
7226         if (getsockname(fd, SvPV(sv), (int*)&SvCUR(sv)) < 0)
7227             goto nuts2;
7228         break;
7229     case OP_GETPEERNAME:
7230         if (getpeername(fd, SvPV(sv), (int*)&SvCUR(sv)) < 0)
7231             goto nuts2;
7232         break;
7233     }
7234     PUSHs(sv);
7235     RETURN;
7236
7237 nuts:
7238     if (dowarn)
7239         warn("get{sock, peer}name() on closed fd");
7240     errno = EBADF;
7241 nuts2:
7242     RETPUSHUNDEF;
7243
7244 #else
7245     DIE(no_sock_func, "getpeername");
7246 #endif
7247 }
7248
7249 /* Stat calls. */
7250
7251 PP(pp_lstat)
7252 {
7253     return pp_stat(ARGS);
7254 }
7255
7256 PP(pp_stat)
7257 {
7258     dSP;
7259     GV *tmpgv;
7260     I32 max = 13;
7261
7262     if (op->op_flags & OPf_SPECIAL) {
7263         tmpgv = cGVOP->op_gv;
7264         if (tmpgv != defgv) {
7265             laststype = OP_STAT;
7266             statgv = tmpgv;
7267             sv_setpv(statname, "");
7268             if (!GvIO(tmpgv) || !GvIO(tmpgv)->ifp ||
7269               fstat(fileno(GvIO(tmpgv)->ifp), &statcache) < 0) {
7270                 max = 0;
7271                 laststatval = -1;
7272             }
7273         }
7274         else if (laststatval < 0)
7275             max = 0;
7276     }
7277     else {
7278         sv_setpv(statname, POPp);
7279         statgv = Nullgv;
7280 #ifdef HAS_LSTAT
7281         laststype = op->op_type;
7282         if (op->op_type == OP_LSTAT)
7283             laststatval = lstat(SvPVn(statname), &statcache);
7284         else
7285 #endif
7286             laststatval = stat(SvPVn(statname), &statcache);
7287         if (laststatval < 0) {
7288             if (dowarn && index(SvPVn(statname), '\n'))
7289                 warn(warn_nl, "stat");
7290             max = 0;
7291         }
7292     }
7293
7294     EXTEND(SP, 13);
7295     if (GIMME != G_ARRAY) {
7296         if (max)
7297             RETPUSHYES;
7298         else
7299             RETPUSHUNDEF;
7300     }
7301     if (max) {
7302         PUSHs(sv_2mortal(newSVnv((double)statcache.st_dev)));
7303         PUSHs(sv_2mortal(newSVnv((double)statcache.st_ino)));
7304         PUSHs(sv_2mortal(newSVnv((double)statcache.st_mode)));
7305         PUSHs(sv_2mortal(newSVnv((double)statcache.st_nlink)));
7306         PUSHs(sv_2mortal(newSVnv((double)statcache.st_uid)));
7307         PUSHs(sv_2mortal(newSVnv((double)statcache.st_gid)));
7308         PUSHs(sv_2mortal(newSVnv((double)statcache.st_rdev)));
7309         PUSHs(sv_2mortal(newSVnv((double)statcache.st_size)));
7310         PUSHs(sv_2mortal(newSVnv((double)statcache.st_atime)));
7311         PUSHs(sv_2mortal(newSVnv((double)statcache.st_mtime)));
7312         PUSHs(sv_2mortal(newSVnv((double)statcache.st_ctime)));
7313 #ifdef STATBLOCKS
7314         PUSHs(sv_2mortal(newSVnv((double)statcache.st_blksize)));
7315         PUSHs(sv_2mortal(newSVnv((double)statcache.st_blocks)));
7316 #else
7317         PUSHs(sv_2mortal(newSVpv("", 0)));
7318         PUSHs(sv_2mortal(newSVpv("", 0)));
7319 #endif
7320     }
7321     RETURN;
7322 }
7323
7324 PP(pp_ftrread)
7325 {
7326     I32 result = my_stat(ARGS);
7327     dSP;
7328     if (result < 0)
7329         RETPUSHUNDEF;
7330     if (cando(S_IRUSR, 0, &statcache))
7331         RETPUSHYES;
7332     RETPUSHNO;
7333 }
7334
7335 PP(pp_ftrwrite)
7336 {
7337     I32 result = my_stat(ARGS);
7338     dSP;
7339     if (result < 0)
7340         RETPUSHUNDEF;
7341     if (cando(S_IWUSR, 0, &statcache))
7342         RETPUSHYES;
7343     RETPUSHNO;
7344 }
7345
7346 PP(pp_ftrexec)
7347 {
7348     I32 result = my_stat(ARGS);
7349     dSP;
7350     if (result < 0)
7351         RETPUSHUNDEF;
7352     if (cando(S_IXUSR, 0, &statcache))
7353         RETPUSHYES;
7354     RETPUSHNO;
7355 }
7356
7357 PP(pp_fteread)
7358 {
7359     I32 result = my_stat(ARGS);
7360     dSP;
7361     if (result < 0)
7362         RETPUSHUNDEF;
7363     if (cando(S_IRUSR, 1, &statcache))
7364         RETPUSHYES;
7365     RETPUSHNO;
7366 }
7367
7368 PP(pp_ftewrite)
7369 {
7370     I32 result = my_stat(ARGS);
7371     dSP;
7372     if (result < 0)
7373         RETPUSHUNDEF;
7374     if (cando(S_IWUSR, 1, &statcache))
7375         RETPUSHYES;
7376     RETPUSHNO;
7377 }
7378
7379 PP(pp_fteexec)
7380 {
7381     I32 result = my_stat(ARGS);
7382     dSP;
7383     if (result < 0)
7384         RETPUSHUNDEF;
7385     if (cando(S_IXUSR, 1, &statcache))
7386         RETPUSHYES;
7387     RETPUSHNO;
7388 }
7389
7390 PP(pp_ftis)
7391 {
7392     I32 result = my_stat(ARGS);
7393     dSP;
7394     if (result < 0)
7395         RETPUSHUNDEF;
7396     RETPUSHYES;
7397 }
7398
7399 PP(pp_fteowned)
7400 {
7401     return pp_ftrowned(ARGS);
7402 }
7403
7404 PP(pp_ftrowned)
7405 {
7406     I32 result = my_stat(ARGS);
7407     dSP;
7408     if (result < 0)
7409         RETPUSHUNDEF;
7410     if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
7411         RETPUSHYES;
7412     RETPUSHNO;
7413 }
7414
7415 PP(pp_ftzero)
7416 {
7417     I32 result = my_stat(ARGS);
7418     dSP;
7419     if (result < 0)
7420         RETPUSHUNDEF;
7421     if (!statcache.st_size)
7422         RETPUSHYES;
7423     RETPUSHNO;
7424 }
7425
7426 PP(pp_ftsize)
7427 {
7428     I32 result = my_stat(ARGS);
7429     dSP; dTARGET;
7430     if (result < 0)
7431         RETPUSHUNDEF;
7432     PUSHi(statcache.st_size);
7433     RETURN;
7434 }
7435
7436 PP(pp_ftmtime)
7437 {
7438     I32 result = my_stat(ARGS);
7439     dSP; dTARGET;
7440     if (result < 0)
7441         RETPUSHUNDEF;
7442     PUSHn( (basetime - statcache.st_mtime) / 86400.0 );
7443     RETURN;
7444 }
7445
7446 PP(pp_ftatime)
7447 {
7448     I32 result = my_stat(ARGS);
7449     dSP; dTARGET;
7450     if (result < 0)
7451         RETPUSHUNDEF;
7452     PUSHn( (basetime - statcache.st_atime) / 86400.0 );
7453     RETURN;
7454 }
7455
7456 PP(pp_ftctime)
7457 {
7458     I32 result = my_stat(ARGS);
7459     dSP; dTARGET;
7460     if (result < 0)
7461         RETPUSHUNDEF;
7462     PUSHn( (basetime - statcache.st_ctime) / 86400.0 );
7463     RETURN;
7464 }
7465
7466 PP(pp_ftsock)
7467 {
7468     I32 result = my_stat(ARGS);
7469     dSP;
7470     if (result < 0)
7471         RETPUSHUNDEF;
7472     if (S_ISSOCK(statcache.st_mode))
7473         RETPUSHYES;
7474     RETPUSHNO;
7475 }
7476
7477 PP(pp_ftchr)
7478 {
7479     I32 result = my_stat(ARGS);
7480     dSP;
7481     if (result < 0)
7482         RETPUSHUNDEF;
7483     if (S_ISCHR(statcache.st_mode))
7484         RETPUSHYES;
7485     RETPUSHNO;
7486 }
7487
7488 PP(pp_ftblk)
7489 {
7490     I32 result = my_stat(ARGS);
7491     dSP;
7492     if (result < 0)
7493         RETPUSHUNDEF;
7494     if (S_ISBLK(statcache.st_mode))
7495         RETPUSHYES;
7496     RETPUSHNO;
7497 }
7498
7499 PP(pp_ftfile)
7500 {
7501     I32 result = my_stat(ARGS);
7502     dSP;
7503     if (result < 0)
7504         RETPUSHUNDEF;
7505     if (S_ISREG(statcache.st_mode))
7506         RETPUSHYES;
7507     RETPUSHNO;
7508 }
7509
7510 PP(pp_ftdir)
7511 {
7512     I32 result = my_stat(ARGS);
7513     dSP;
7514     if (result < 0)
7515         RETPUSHUNDEF;
7516     if (S_ISDIR(statcache.st_mode))
7517         RETPUSHYES;
7518     RETPUSHNO;
7519 }
7520
7521 PP(pp_ftpipe)
7522 {
7523     I32 result = my_stat(ARGS);
7524     dSP;
7525     if (result < 0)
7526         RETPUSHUNDEF;
7527     if (S_ISFIFO(statcache.st_mode))
7528         RETPUSHYES;
7529     RETPUSHNO;
7530 }
7531
7532 PP(pp_ftlink)
7533 {
7534     I32 result = my_lstat(ARGS);
7535     dSP;
7536     if (result < 0)
7537         RETPUSHUNDEF;
7538     if (S_ISLNK(statcache.st_mode))
7539         RETPUSHYES;
7540     RETPUSHNO;
7541 }
7542
7543 PP(pp_ftsuid)
7544 {
7545     dSP;
7546 #ifdef S_ISUID
7547     I32 result = my_stat(ARGS);
7548     SPAGAIN;
7549     if (result < 0)
7550         RETPUSHUNDEF;
7551     if (statcache.st_mode & S_ISUID)
7552         RETPUSHYES;
7553 #endif
7554     RETPUSHNO;
7555 }
7556
7557 PP(pp_ftsgid)
7558 {
7559     dSP;
7560 #ifdef S_ISGID
7561     I32 result = my_stat(ARGS);
7562     SPAGAIN;
7563     if (result < 0)
7564         RETPUSHUNDEF;
7565     if (statcache.st_mode & S_ISGID)
7566         RETPUSHYES;
7567 #endif
7568     RETPUSHNO;
7569 }
7570
7571 PP(pp_ftsvtx)
7572 {
7573     dSP;
7574 #ifdef S_ISVTX
7575     I32 result = my_stat(ARGS);
7576     SPAGAIN;
7577     if (result < 0)
7578         RETPUSHUNDEF;
7579     if (statcache.st_mode & S_ISVTX)
7580         RETPUSHYES;
7581 #endif
7582     RETPUSHNO;
7583 }
7584
7585 PP(pp_fttty)
7586 {
7587     dSP;
7588     int fd;
7589     GV *gv;
7590     char *tmps;
7591     if (op->op_flags & OPf_SPECIAL) {
7592         gv = cGVOP->op_gv;
7593         tmps = "";
7594     }
7595     else
7596         gv = gv_fetchpv(tmps = POPp, FALSE);
7597     if (gv && GvIO(gv) && GvIO(gv)->ifp)
7598         fd = fileno(GvIO(gv)->ifp);
7599     else if (isDIGIT(*tmps))
7600         fd = atoi(tmps);
7601     else
7602         RETPUSHUNDEF;
7603     if (isatty(fd))
7604         RETPUSHYES;
7605     RETPUSHNO;
7606 }
7607
7608 PP(pp_fttext)
7609 {
7610     dSP;
7611     I32 i;
7612     I32 len;
7613     I32 odd = 0;
7614     STDCHAR tbuf[512];
7615     register STDCHAR *s;
7616     register IO *io;
7617     SV *sv;
7618
7619     if (op->op_flags & OPf_SPECIAL) {
7620         EXTEND(SP, 1);
7621         if (cGVOP->op_gv == defgv) {
7622             if (statgv)
7623                 io = GvIO(statgv);
7624             else {
7625                 sv = statname;
7626                 goto really_filename;
7627             }
7628         }
7629         else {
7630             statgv = cGVOP->op_gv;
7631             sv_setpv(statname, "");
7632             io = GvIO(statgv);
7633         }
7634         if (io && io->ifp) {
7635 #if defined(STDSTDIO) || defined(atarist) /* this will work with atariST */
7636             fstat(fileno(io->ifp), &statcache);
7637             if (S_ISDIR(statcache.st_mode))     /* handle NFS glitch */
7638                 if (op->op_type == OP_FTTEXT)
7639                     RETPUSHNO;
7640                 else
7641                     RETPUSHYES;
7642             if (io->ifp->_cnt <= 0) {
7643                 i = getc(io->ifp);
7644                 if (i != EOF)
7645                     (void)ungetc(i, io->ifp);
7646             }
7647             if (io->ifp->_cnt <= 0)     /* null file is anything */
7648                 RETPUSHYES;
7649             len = io->ifp->_cnt + (io->ifp->_ptr - io->ifp->_base);
7650             s = io->ifp->_base;
7651 #else
7652             DIE("-T and -B not implemented on filehandles");
7653 #endif
7654         }
7655         else {
7656             if (dowarn)
7657                 warn("Test on unopened file <%s>",
7658                   GvENAME(cGVOP->op_gv));
7659             errno = EBADF;
7660             RETPUSHUNDEF;
7661         }
7662     }
7663     else {
7664         sv = POPs;
7665         statgv = Nullgv;
7666         sv_setpv(statname, SvPVn(sv));
7667       really_filename:
7668         i = open(SvPVn(sv), 0);
7669         if (i < 0) {
7670             if (dowarn && index(SvPVn(sv), '\n'))
7671                 warn(warn_nl, "open");
7672             RETPUSHUNDEF;
7673         }
7674         fstat(i, &statcache);
7675         len = read(i, tbuf, 512);
7676         (void)close(i);
7677         if (len <= 0) {
7678             if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
7679                 RETPUSHNO;              /* special case NFS directories */
7680             RETPUSHYES;         /* null file is anything */
7681         }
7682         s = tbuf;
7683     }
7684
7685     /* now scan s to look for textiness */
7686
7687     for (i = 0; i < len; i++, s++) {
7688         if (!*s) {                      /* null never allowed in text */
7689             odd += len;
7690             break;
7691         }
7692         else if (*s & 128)
7693             odd++;
7694         else if (*s < 32 &&
7695           *s != '\n' && *s != '\r' && *s != '\b' &&
7696           *s != '\t' && *s != '\f' && *s != 27)
7697             odd++;
7698     }
7699
7700     if ((odd * 10 > len) == (op->op_type == OP_FTTEXT)) /* allow 10% odd */
7701         RETPUSHNO;
7702     else
7703         RETPUSHYES;
7704 }
7705
7706 PP(pp_ftbinary)
7707 {
7708     return pp_fttext(ARGS);
7709 }
7710
7711 /* File calls. */
7712
7713 PP(pp_chdir)
7714 {
7715     dSP; dTARGET;
7716     double value;
7717     char *tmps;
7718     SV **svp;
7719
7720     if (MAXARG < 1)
7721         tmps = Nullch;
7722     else
7723         tmps = POPp;
7724     if (!tmps || !*tmps) {
7725         svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
7726         if (svp)
7727             tmps = SvPVn(*svp);
7728     }
7729     if (!tmps || !*tmps) {
7730         svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
7731         if (svp)
7732             tmps = SvPVn(*svp);
7733     }
7734     TAINT_PROPER("chdir");
7735     PUSHi( chdir(tmps) >= 0 );
7736     RETURN;
7737 }
7738
7739 PP(pp_chown)
7740 {
7741     dSP; dMARK; dTARGET;
7742     I32 value;
7743 #ifdef HAS_CHOWN
7744     value = (I32)apply(op->op_type, MARK, SP);
7745     SP = MARK;
7746     PUSHi(value);
7747     RETURN;
7748 #else
7749     DIE(no_func, "Unsupported function chown");
7750 #endif
7751 }
7752
7753 PP(pp_chroot)
7754 {
7755     dSP; dTARGET;
7756     char *tmps;
7757 #ifdef HAS_CHROOT
7758     if (MAXARG < 1)
7759         tmps = SvPVnx(GvSV(defgv));
7760     else
7761         tmps = POPp;
7762     TAINT_PROPER("chroot");
7763     PUSHi( chroot(tmps) >= 0 );
7764     RETURN;
7765 #else
7766     DIE(no_func, "chroot");
7767 #endif
7768 }
7769
7770 PP(pp_unlink)
7771 {
7772     dSP; dMARK; dTARGET;
7773     I32 value;
7774     value = (I32)apply(op->op_type, MARK, SP);
7775     SP = MARK;
7776     PUSHi(value);
7777     RETURN;
7778 }
7779
7780 PP(pp_chmod)
7781 {
7782     dSP; dMARK; dTARGET;
7783     I32 value;
7784     value = (I32)apply(op->op_type, MARK, SP);
7785     SP = MARK;
7786     PUSHi(value);
7787     RETURN;
7788 }
7789
7790 PP(pp_utime)
7791 {
7792     dSP; dMARK; dTARGET;
7793     I32 value;
7794     value = (I32)apply(op->op_type, MARK, SP);
7795     SP = MARK;
7796     PUSHi(value);
7797     RETURN;
7798 }
7799
7800 PP(pp_rename)
7801 {
7802     dSP; dTARGET;
7803     int anum;
7804
7805     char *tmps2 = POPp;
7806     char *tmps = SvPVn(TOPs);
7807     TAINT_PROPER("rename");
7808 #ifdef HAS_RENAME
7809     anum = rename(tmps, tmps2);
7810 #else
7811     if (same_dirent(tmps2, tmps))       /* can always rename to same name */
7812         anum = 1;
7813     else {
7814         if (euid || stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
7815             (void)UNLINK(tmps2);
7816         if (!(anum = link(tmps, tmps2)))
7817             anum = UNLINK(tmps);
7818     }
7819 #endif
7820     SETi( anum >= 0 );
7821     RETURN;
7822 }
7823
7824 PP(pp_link)
7825 {
7826     dSP; dTARGET;
7827 #ifdef HAS_LINK
7828     char *tmps2 = POPp;
7829     char *tmps = SvPVn(TOPs);
7830     TAINT_PROPER("link");
7831     SETi( link(tmps, tmps2) >= 0 );
7832 #else
7833     DIE(no_func, "Unsupported function link");
7834 #endif
7835     RETURN;
7836 }
7837
7838 PP(pp_symlink)
7839 {
7840     dSP; dTARGET;
7841 #ifdef HAS_SYMLINK
7842     char *tmps2 = POPp;
7843     char *tmps = SvPVn(TOPs);
7844     TAINT_PROPER("symlink");
7845     SETi( symlink(tmps, tmps2) >= 0 );
7846     RETURN;
7847 #else
7848     DIE(no_func, "symlink");
7849 #endif
7850 }
7851
7852 PP(pp_readlink)
7853 {
7854     dSP; dTARGET;
7855 #ifdef HAS_SYMLINK
7856     char *tmps;
7857     int len;
7858     if (MAXARG < 1)
7859         tmps = SvPVnx(GvSV(defgv));
7860     else
7861         tmps = POPp;
7862     len = readlink(tmps, buf, sizeof buf);
7863     EXTEND(SP, 1);
7864     if (len < 0)
7865         RETPUSHUNDEF;
7866     PUSHp(buf, len);
7867     RETURN;
7868 #else
7869     EXTEND(SP, 1);
7870     RETSETUNDEF;                /* just pretend it's a normal file */
7871 #endif
7872 }
7873
7874 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
7875 static void
7876 dooneliner(cmd, filename)
7877 char *cmd;
7878 char *filename;
7879 {
7880     char mybuf[8192];
7881     char *s;
7882     int anum = 1;
7883     FILE *myfp;
7884
7885     strcpy(mybuf, cmd);
7886     strcat(mybuf, " ");
7887     for (s = mybuf+strlen(mybuf); *filename; ) {
7888         *s++ = '\\';
7889         *s++ = *filename++;
7890     }
7891     strcpy(s, " 2>&1");
7892     myfp = my_popen(mybuf, "r");
7893     if (myfp) {
7894         *mybuf = '\0';
7895         s = fgets(mybuf, sizeof mybuf, myfp);
7896         (void)my_pclose(myfp);
7897         if (s != Nullch) {
7898             for (errno = 1; errno < sys_nerr; errno++) {
7899                 if (instr(mybuf, sys_errlist[errno]))   /* you don't see this */
7900                     return 0;
7901             }
7902             errno = 0;
7903 #ifndef EACCES
7904 #define EACCES EPERM
7905 #endif
7906             if (instr(mybuf, "cannot make"))
7907                 errno = EEXIST;
7908             else if (instr(mybuf, "existing file"))
7909                 errno = EEXIST;
7910             else if (instr(mybuf, "ile exists"))
7911                 errno = EEXIST;
7912             else if (instr(mybuf, "non-exist"))
7913                 errno = ENOENT;
7914             else if (instr(mybuf, "does not exist"))
7915                 errno = ENOENT;
7916             else if (instr(mybuf, "not empty"))
7917                 errno = EBUSY;
7918             else if (instr(mybuf, "cannot access"))
7919                 errno = EACCES;
7920             else
7921                 errno = EPERM;
7922             return 0;
7923         }
7924         else {  /* some mkdirs return no failure indication */
7925             tmps = SvPVnx(st[1]);
7926             anum = (stat(tmps, &statbuf) >= 0);
7927             if (op->op_type == OP_RMDIR)
7928                 anum = !anum;
7929             if (anum)
7930                 errno = 0;
7931             else
7932                 errno = EACCES; /* a guess */
7933         }
7934         return anum;
7935     }
7936     else
7937         return 0;
7938 }
7939 #endif
7940
7941 PP(pp_mkdir)
7942 {
7943     dSP; dTARGET;
7944     int mode = POPi;
7945     int oldumask;
7946     char *tmps = SvPVn(TOPs);
7947
7948     TAINT_PROPER("mkdir");
7949 #ifdef HAS_MKDIR
7950     SETi( mkdir(tmps, mode) >= 0 );
7951 #else
7952     SETi( dooneliner("mkdir", tmps) );
7953     oldumask = umask(0)
7954     umask(oldumask);
7955     chmod(tmps, (mode & ~oldumask) & 0777);
7956 #endif
7957     RETURN;
7958 }
7959
7960 PP(pp_rmdir)
7961 {
7962     dSP; dTARGET;
7963     char *tmps;
7964
7965     if (MAXARG < 1)
7966         tmps = SvPVnx(GvSV(defgv));
7967     else
7968         tmps = POPp;
7969     TAINT_PROPER("rmdir");
7970 #ifdef HAS_RMDIR
7971     XPUSHi( rmdir(tmps) >= 0 );
7972 #else
7973     XPUSHi( dooneliner("rmdir", tmps) );
7974 #endif
7975     RETURN;
7976 }
7977
7978 /* Directory calls. */
7979
7980 PP(pp_open_dir)
7981 {
7982     dSP;
7983 #if defined(DIRENT) && defined(HAS_READDIR)
7984     char *dirname = POPp;
7985     GV *gv = (GV*)POPs;
7986     register IO *io = GvIOn(gv);
7987
7988     if (!io)
7989         goto nope;
7990
7991     if (io->dirp)
7992         closedir(io->dirp);
7993     if (!(io->dirp = opendir(dirname)))
7994         goto nope;
7995
7996     RETPUSHYES;
7997 nope:
7998     if (!errno)
7999         errno = EBADF;
8000     RETPUSHUNDEF;
8001 #else
8002     DIE(no_dir_func, "opendir");
8003 #endif
8004 }
8005
8006 PP(pp_readdir)
8007 {
8008     dSP;
8009 #if defined(DIRENT) && defined(HAS_READDIR)
8010 #ifndef apollo
8011     struct DIRENT *readdir();
8012 #endif
8013     register struct DIRENT *dp;
8014     GV *gv = (GV*)POPs;
8015     register IO *io = GvIOn(gv);
8016
8017     if (!io || !io->dirp)
8018         goto nope;
8019
8020     if (GIMME == G_ARRAY) {
8021         /*SUPPRESS 560*/
8022         while (dp = readdir(io->dirp)) {
8023 #ifdef DIRNAMLEN
8024             XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
8025 #else
8026             XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
8027 #endif
8028         }
8029     }
8030     else {
8031         if (!(dp = readdir(io->dirp)))
8032             goto nope;
8033 #ifdef DIRNAMLEN
8034         XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
8035 #else
8036         XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
8037 #endif
8038     }
8039     RETURN;
8040
8041 nope:
8042     if (!errno)
8043         errno = EBADF;
8044     if (GIMME == G_ARRAY)
8045         RETURN;
8046     else
8047         RETPUSHUNDEF;
8048 #else
8049     DIE(no_dir_func, "readdir");
8050 #endif
8051 }
8052
8053 PP(pp_telldir)
8054 {
8055     dSP; dTARGET;
8056 #if defined(HAS_TELLDIR) || defined(telldir)
8057 #ifndef telldir
8058     long telldir();
8059 #endif
8060     GV *gv = (GV*)POPs;
8061     register IO *io = GvIOn(gv);
8062
8063     if (!io || !io->dirp)
8064         goto nope;
8065
8066     PUSHi( telldir(io->dirp) );
8067     RETURN;
8068 nope:
8069     if (!errno)
8070         errno = EBADF;
8071     RETPUSHUNDEF;
8072 #else
8073     DIE(no_dir_func, "telldir");
8074 #endif
8075 }
8076
8077 PP(pp_seekdir)
8078 {
8079     dSP;
8080 #if defined(HAS_SEEKDIR) || defined(seekdir)
8081     long along = POPl;
8082     GV *gv = (GV*)POPs;
8083     register IO *io = GvIOn(gv);
8084
8085     if (!io || !io->dirp)
8086         goto nope;
8087
8088     (void)seekdir(io->dirp, along);
8089
8090     RETPUSHYES;
8091 nope:
8092     if (!errno)
8093         errno = EBADF;
8094     RETPUSHUNDEF;
8095 #else
8096     DIE(no_dir_func, "seekdir");
8097 #endif
8098 }
8099
8100 PP(pp_rewinddir)
8101 {
8102     dSP;
8103 #if defined(HAS_REWINDDIR) || defined(rewinddir)
8104     GV *gv = (GV*)POPs;
8105     register IO *io = GvIOn(gv);
8106
8107     if (!io || !io->dirp)
8108         goto nope;
8109
8110     (void)rewinddir(io->dirp);
8111     RETPUSHYES;
8112 nope:
8113     if (!errno)
8114         errno = EBADF;
8115     RETPUSHUNDEF;
8116 #else
8117     DIE(no_dir_func, "rewinddir");
8118 #endif
8119 }
8120
8121 PP(pp_closedir)
8122 {
8123     dSP;
8124 #if defined(DIRENT) && defined(HAS_READDIR)
8125     GV *gv = (GV*)POPs;
8126     register IO *io = GvIOn(gv);
8127
8128     if (!io || !io->dirp)
8129         goto nope;
8130
8131     if (closedir(io->dirp) < 0)
8132         goto nope;
8133     io->dirp = 0;
8134
8135     RETPUSHYES;
8136 nope:
8137     if (!errno)
8138         errno = EBADF;
8139     RETPUSHUNDEF;
8140 #else
8141     DIE(no_dir_func, "closedir");
8142 #endif
8143 }
8144
8145 /* Process control. */
8146
8147 PP(pp_fork)
8148 {
8149     dSP; dTARGET;
8150     int childpid;
8151     GV *tmpgv;
8152
8153     EXTEND(SP, 1);
8154 #ifdef HAS_FORK
8155     childpid = fork();
8156     if (childpid < 0)
8157         RETSETUNDEF;
8158     if (!childpid) {
8159         /*SUPPRESS 560*/
8160         if (tmpgv = gv_fetchpv("$", allgvs))
8161             sv_setiv(GvSV(tmpgv), (I32)getpid());
8162         hv_clear(pidstatus, FALSE);     /* no kids, so don't wait for 'em */
8163     }
8164     PUSHi(childpid);
8165     RETURN;
8166 #else
8167     DIE(no_func, "Unsupported function fork");
8168 #endif
8169 }
8170
8171 PP(pp_wait)
8172 {
8173     dSP; dTARGET;
8174     int childpid;
8175     int argflags;
8176     I32 value;
8177
8178     EXTEND(SP, 1);
8179 #ifdef HAS_WAIT
8180     childpid = wait(&argflags);
8181     if (childpid > 0)
8182         pidgone(childpid, argflags);
8183     value = (I32)childpid;
8184     statusvalue = (U16)argflags;
8185     PUSHi(value);
8186     RETURN;
8187 #else
8188     DIE(no_func, "Unsupported function wait");
8189 #endif
8190 }
8191
8192 PP(pp_waitpid)
8193 {
8194     dSP; dTARGET;
8195     int childpid;
8196     int optype;
8197     int argflags;
8198     I32 value;
8199
8200 #ifdef HAS_WAIT
8201     optype = POPi;
8202     childpid = TOPi;
8203     childpid = wait4pid(childpid, &argflags, optype);
8204     value = (I32)childpid;
8205     statusvalue = (U16)argflags;
8206     SETi(value);
8207     RETURN;
8208 #else
8209     DIE(no_func, "Unsupported function wait");
8210 #endif
8211 }
8212
8213 PP(pp_system)
8214 {
8215     dSP; dMARK; dORIGMARK; dTARGET;
8216     I32 value;
8217     int childpid;
8218     int result;
8219     int status;
8220     VOIDRET (*ihand)();     /* place to save signal during system() */
8221     VOIDRET (*qhand)();     /* place to save signal during system() */
8222
8223 #ifdef HAS_FORK
8224     if (SP - MARK == 1) {
8225         TAINT_ENV();
8226         TAINT_IF(TOPs->sv_tainted);
8227         TAINT_PROPER("system");
8228     }
8229     while ((childpid = vfork()) == -1) {
8230         if (errno != EAGAIN) {
8231             value = -1;
8232             SP = ORIGMARK;
8233             PUSHi(value);
8234             RETURN;
8235         }
8236         sleep(5);
8237     }
8238     if (childpid > 0) {
8239         ihand = signal(SIGINT, SIG_IGN);
8240         qhand = signal(SIGQUIT, SIG_IGN);
8241         result = wait4pid(childpid, &status, 0);
8242         (void)signal(SIGINT, ihand);
8243         (void)signal(SIGQUIT, qhand);
8244         statusvalue = (U16)status;
8245         if (result < 0)
8246             value = -1;
8247         else {
8248             value = (I32)((unsigned int)status & 0xffff);
8249         }
8250         do_execfree();  /* free any memory child malloced on vfork */
8251         SP = ORIGMARK;
8252         PUSHi(value);
8253         RETURN;
8254     }
8255     if (op->op_flags & OPf_STACKED) {
8256         SV *really = *++MARK;
8257         value = (I32)do_aexec(really, MARK, SP);
8258     }
8259     else if (SP - MARK != 1)
8260         value = (I32)do_aexec(Nullsv, MARK, SP);
8261     else {
8262         value = (I32)do_exec(SvPVnx(sv_mortalcopy(*SP)));
8263     }
8264     _exit(-1);
8265 #else /* ! FORK */
8266     if ((op[1].op_type & A_MASK) == A_GV)
8267         value = (I32)do_aspawn(st[1], arglast);
8268     else if (arglast[2] - arglast[1] != 1)
8269         value = (I32)do_aspawn(Nullsv, arglast);
8270     else {
8271         value = (I32)do_spawn(SvPVnx(sv_mortalcopy(st[2])));
8272     }
8273     PUSHi(value);
8274 #endif /* FORK */
8275     RETURN;
8276 }
8277
8278 PP(pp_exec)
8279 {
8280     dSP; dMARK; dORIGMARK; dTARGET;
8281     I32 value;
8282
8283     if (op->op_flags & OPf_STACKED) {
8284         SV *really = *++MARK;
8285         value = (I32)do_aexec(really, MARK, SP);
8286     }
8287     else if (SP - MARK != 1)
8288         value = (I32)do_aexec(Nullsv, MARK, SP);
8289     else {
8290         TAINT_ENV();
8291         TAINT_IF((*SP)->sv_tainted);
8292         TAINT_PROPER("exec");
8293         value = (I32)do_exec(SvPVnx(sv_mortalcopy(*SP)));
8294     }
8295     SP = ORIGMARK;
8296     PUSHi(value);
8297     RETURN;
8298 }
8299
8300 PP(pp_kill)
8301 {
8302     dSP; dMARK; dTARGET;
8303     I32 value;
8304 #ifdef HAS_KILL
8305     value = (I32)apply(op->op_type, MARK, SP);
8306     SP = MARK;
8307     PUSHi(value);
8308     RETURN;
8309 #else
8310     DIE(no_func, "Unsupported function kill");
8311 #endif
8312 }
8313
8314 PP(pp_getppid)
8315 {
8316 #ifdef HAS_GETPPID
8317     dSP; dTARGET;
8318     XPUSHi( getppid() );
8319     RETURN;
8320 #else
8321     DIE(no_func, "getppid");
8322 #endif
8323 }
8324
8325 PP(pp_getpgrp)
8326 {
8327 #ifdef HAS_GETPGRP
8328     dSP; dTARGET;
8329     int pid;
8330     I32 value;
8331
8332     if (MAXARG < 1)
8333         pid = 0;
8334     else
8335         pid = SvIVnx(POPs);
8336 #ifdef _POSIX_SOURCE
8337     if (pid != 0)
8338         DIE("POSIX getpgrp can't take an argument");
8339     value = (I32)getpgrp();
8340 #else
8341     value = (I32)getpgrp(pid);
8342 #endif
8343     XPUSHi(value);
8344     RETURN;
8345 #else
8346     DIE(no_func, "getpgrp()");
8347 #endif
8348 }
8349
8350 PP(pp_setpgrp)
8351 {
8352 #ifdef HAS_SETPGRP
8353     dSP; dTARGET;
8354     int pgrp = POPi;
8355     int pid = TOPi;
8356
8357     TAINT_PROPER("setpgrp");
8358     SETi( setpgrp(pid, pgrp) >= 0 );
8359     RETURN;
8360 #else
8361     DIE(no_func, "setpgrp()");
8362 #endif
8363 }
8364
8365 PP(pp_getpriority)
8366 {
8367     dSP; dTARGET;
8368     int which;
8369     int who;
8370 #ifdef HAS_GETPRIORITY
8371     who = POPi;
8372     which = TOPi;
8373     SETi( getpriority(which, who) );
8374     RETURN;
8375 #else
8376     DIE(no_func, "getpriority()");
8377 #endif
8378 }
8379
8380 PP(pp_setpriority)
8381 {
8382     dSP; dTARGET;
8383     int which;
8384     int who;
8385     int niceval;
8386 #ifdef HAS_SETPRIORITY
8387     niceval = POPi;
8388     who = POPi;
8389     which = TOPi;
8390     TAINT_PROPER("setpriority");
8391     SETi( setpriority(which, who, niceval) >= 0 );
8392     RETURN;
8393 #else
8394     DIE(no_func, "setpriority()");
8395 #endif
8396 }
8397
8398 /* Time calls. */
8399
8400 PP(pp_time)
8401 {
8402     dSP; dTARGET;
8403     XPUSHi( time(Null(long*)) );
8404     RETURN;
8405 }
8406
8407 #ifndef HZ
8408 #define HZ 60
8409 #endif
8410
8411 PP(pp_tms)
8412 {
8413     dSP;
8414
8415 #ifdef MSDOS
8416     DIE("times not implemented");
8417 #else
8418     EXTEND(SP, 4);
8419
8420     (void)times(&timesbuf);
8421
8422     PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
8423     if (GIMME == G_ARRAY) {
8424         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
8425         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
8426         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
8427     }
8428     RETURN;
8429 #endif /* MSDOS */
8430 }
8431
8432 PP(pp_localtime)
8433 {
8434     return pp_gmtime(ARGS);
8435 }
8436
8437 PP(pp_gmtime)
8438 {
8439     dSP;
8440     time_t when;
8441     struct tm *tmbuf;
8442     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
8443     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
8444                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
8445
8446     if (MAXARG < 1)
8447         (void)time(&when);
8448     else
8449         when = (time_t)SvIVnx(POPs);
8450
8451     if (op->op_type == OP_LOCALTIME)
8452         tmbuf = localtime(&when);
8453     else
8454         tmbuf = gmtime(&when);
8455
8456     EXTEND(SP, 9);
8457     if (GIMME != G_ARRAY) {
8458         dTARGET;
8459         char mybuf[30];
8460         if (!tmbuf)
8461             RETPUSHUNDEF;
8462         sprintf(mybuf, "%s %s %2d %02d:%02d:%02d %d",
8463             dayname[tmbuf->tm_wday],
8464             monname[tmbuf->tm_mon],
8465             tmbuf->tm_mday,
8466             tmbuf->tm_hour,
8467             tmbuf->tm_min,
8468             tmbuf->tm_sec,
8469             tmbuf->tm_year + 1900);
8470         PUSHp(mybuf, strlen(mybuf));
8471     }
8472     else if (tmbuf) {
8473         PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_sec)));
8474         PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_min)));
8475         PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_hour)));
8476         PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_mday)));
8477         PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_mon)));
8478         PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_year)));
8479         PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_wday)));
8480         PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_yday)));
8481         PUSHs(sv_2mortal(newSVnv((double)tmbuf->tm_isdst)));
8482     }
8483     RETURN;
8484 }
8485
8486 PP(pp_alarm)
8487 {
8488     dSP; dTARGET;
8489     int anum;
8490     char *tmps;
8491 #ifdef HAS_ALARM
8492     if (MAXARG < 1)
8493         tmps = SvPVnx(GvSV(defgv));
8494     else
8495         tmps = POPp;
8496     if (!tmps)
8497         tmps = "0";
8498     anum = alarm((unsigned int)atoi(tmps));
8499     EXTEND(SP, 1);
8500     if (anum < 0)
8501         RETPUSHUNDEF;
8502     PUSHi((I32)anum);
8503     RETURN;
8504 #else
8505     DIE(no_func, "Unsupported function alarm");
8506     break;
8507 #endif
8508 }
8509
8510 PP(pp_sleep)
8511 {
8512     dSP; dTARGET;
8513     char *tmps;
8514     I32 duration;
8515     time_t lasttime;
8516     time_t when;
8517
8518     (void)time(&lasttime);
8519     if (MAXARG < 1)
8520         pause();
8521     else {
8522         duration = POPi;
8523         sleep((unsigned int)duration);
8524     }
8525     (void)time(&when);
8526     XPUSHi(when - lasttime);
8527     RETURN;
8528 }
8529
8530 /* Shared memory. */
8531
8532 PP(pp_shmget)
8533 {
8534     return pp_semget(ARGS);
8535 }
8536
8537 PP(pp_shmctl)
8538 {
8539     return pp_semctl(ARGS);
8540 }
8541
8542 PP(pp_shmread)
8543 {
8544     return pp_shmwrite(ARGS);
8545 }
8546
8547 PP(pp_shmwrite)
8548 {
8549 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
8550     dSP; dMARK; dTARGET;
8551     I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
8552     SP = MARK;
8553     PUSHi(value);
8554     RETURN;
8555 #else
8556     pp_semget(ARGS);
8557 #endif
8558 }
8559
8560 /* Message passing. */
8561
8562 PP(pp_msgget)
8563 {
8564     return pp_semget(ARGS);
8565 }
8566
8567 PP(pp_msgctl)
8568 {
8569     return pp_semctl(ARGS);
8570 }
8571
8572 PP(pp_msgsnd)
8573 {
8574 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
8575     dSP; dMARK; dTARGET;
8576     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
8577     SP = MARK;
8578     PUSHi(value);
8579     RETURN;
8580 #else
8581     pp_semget(ARGS);
8582 #endif
8583 }
8584
8585 PP(pp_msgrcv)
8586 {
8587 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
8588     dSP; dMARK; dTARGET;
8589     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
8590     SP = MARK;
8591     PUSHi(value);
8592     RETURN;
8593 #else
8594     pp_semget(ARGS);
8595 #endif
8596 }
8597
8598 /* Semaphores. */
8599
8600 PP(pp_semget)
8601 {
8602 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
8603     dSP; dMARK; dTARGET;
8604     int anum = do_ipcget(op->op_type, MARK, SP);
8605     SP = MARK;
8606     if (anum == -1)
8607         RETPUSHUNDEF;
8608     PUSHi(anum);
8609     RETURN;
8610 #else
8611     DIE("System V IPC is not implemented on this machine");
8612 #endif
8613 }
8614
8615 PP(pp_semctl)
8616 {
8617 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
8618     dSP; dMARK; dTARGET;
8619     int anum = do_ipcctl(op->op_type, MARK, SP);
8620     SP = MARK;
8621     if (anum == -1)
8622         RETSETUNDEF;
8623     if (anum != 0) {
8624         PUSHi(anum);
8625     }
8626     else {
8627         PUSHp("0 but true",10);
8628     }
8629     RETURN;
8630 #else
8631     pp_semget(ARGS);
8632 #endif
8633 }
8634
8635 PP(pp_semop)
8636 {
8637 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
8638     dSP; dMARK; dTARGET;
8639     I32 value = (I32)(do_semop(MARK, SP) >= 0);
8640     SP = MARK;
8641     PUSHi(value);
8642     RETURN;
8643 #else
8644     pp_semget(ARGS);
8645 #endif
8646 }
8647
8648 /* Eval. */
8649
8650 static void
8651 save_lines(array, sv)
8652 AV *array;
8653 SV *sv;
8654 {
8655     register char *s = SvPV(sv);
8656     register char *send = SvPV(sv) + SvCUR(sv);
8657     register char *t;
8658     register I32 line = 1;
8659
8660     while (s && s < send) {
8661         SV *tmpstr = NEWSV(85,0);
8662
8663         t = index(s, '\n');
8664         if (t)
8665             t++;
8666         else
8667             t = send;
8668
8669         sv_setpvn(tmpstr, s, t - s);
8670         av_store(array, line++, tmpstr);
8671         s = t;
8672     }
8673 }
8674
8675 OP *
8676 doeval()
8677 {
8678     dSP;
8679     OP *saveop = op;
8680     HV *newstash;
8681
8682     in_eval = 1;
8683     reinit_lexer();
8684
8685     /* set up a scratch pad */
8686
8687     SAVEINT(padix);
8688     SAVESPTR(curpad);
8689     SAVESPTR(comppad);
8690     comppad = newAV();
8691     av_push(comppad, Nullsv);
8692     curpad = AvARRAY(comppad);
8693     padix = 0;
8694
8695     /* make sure we compile in the right package */
8696
8697     newstash = curcop->cop_stash;
8698     if (curstash != newstash) {
8699         SAVESPTR(curstash);
8700         curstash = newstash;
8701     }
8702
8703     /* try to compile it */
8704
8705     eval_root = Nullop;
8706     error_count = 0;
8707     curcop = &compiling;
8708     if (yyparse() || error_count || !eval_root) {
8709         SV **newsp;
8710         I32 gimme;
8711         CONTEXT *cx;
8712         I32 optype;
8713
8714         op = saveop;
8715         POPBLOCK(cx);
8716         POPEVAL(cx);
8717         pop_return();
8718         LEAVE;
8719         if (eval_root) {
8720             op_free(eval_root);
8721             eval_root = Nullop;
8722         }
8723         if (optype == OP_REQUIRE)
8724             DIE("%s", SvPVnx(GvSV(gv_fetchpv("@",TRUE))));
8725         RETPUSHUNDEF;
8726     }
8727     compiling.cop_line = 0;
8728
8729     DEBUG_x(dump_eval(eval_root, eval_start));
8730
8731     /* compiled okay, so do it */
8732
8733     sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
8734     RETURNOP(eval_start);
8735 }
8736
8737 PP(pp_require)
8738 {
8739     dSP;
8740     register CONTEXT *cx;
8741     dPOPss;
8742     char *name = SvPVn(sv);
8743     char *tmpname;
8744     SV** svp;
8745     I32 gimme = G_SCALAR;
8746
8747     if (op->op_type == OP_REQUIRE &&
8748       (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
8749       *svp != &sv_undef)
8750         RETPUSHYES;
8751
8752     /* prepare to compile file */
8753
8754     sv_setpv(linestr,"");
8755
8756     tmpname = savestr(name);
8757     if (*tmpname == '/' ||
8758         (*tmpname == '.' &&
8759             (tmpname[1] == '/' ||
8760              (tmpname[1] == '.' && tmpname[2] == '/'))))
8761     {
8762         rsfp = fopen(tmpname,"r");
8763     }
8764     else {
8765         AV *ar = GvAVn(incgv);
8766         I32 i;
8767
8768         for (i = 0; i <= AvFILL(ar); i++) {
8769             (void)sprintf(buf, "%s/%s", SvPVnx(*av_fetch(ar, i, TRUE)), name);
8770             rsfp = fopen(buf, "r");
8771             if (rsfp) {
8772                 char *s = buf;
8773
8774                 if (*s == '.' && s[1] == '/')
8775                     s += 2;
8776                 Safefree(tmpname);
8777                 tmpname = savestr(s);
8778                 break;
8779             }
8780         }
8781     }
8782     compiling.cop_filegv = gv_fetchfile(tmpname);
8783     Safefree(tmpname);
8784     tmpname = Nullch;
8785     if (!rsfp) {
8786         if (op->op_type == OP_REQUIRE) {
8787             sprintf(tokenbuf,"Can't locate %s in @INC", name);
8788             if (instr(tokenbuf,".h "))
8789                 strcat(tokenbuf," (change .h to .ph maybe?)");
8790             if (instr(tokenbuf,".ph "))
8791                 strcat(tokenbuf," (did you run h2ph?)");
8792             DIE("%s",tokenbuf);
8793         }
8794
8795         RETPUSHUNDEF;
8796     }
8797
8798     ENTER;
8799     SAVETMPS;
8800
8801     /* switch to eval mode */
8802
8803     push_return(op->op_next);
8804     PUSHBLOCK(cx,CXt_EVAL,SP);
8805     PUSHEVAL(cx,savestr(name));
8806
8807     if (curcop->cop_line == 0)            /* don't debug debugger... */
8808         perldb = FALSE;
8809     compiling.cop_line = 0;
8810
8811     PUTBACK;
8812     return doeval();
8813 }
8814
8815 PP(pp_dofile)
8816 {
8817     return pp_require(ARGS);
8818 }
8819
8820 PP(pp_entereval)
8821 {
8822     dSP;
8823     register CONTEXT *cx;
8824     dPOPss;
8825     I32 gimme = GIMME;
8826
8827     ENTER;
8828     SAVETMPS;
8829
8830     /* switch to eval mode */
8831
8832     push_return(op->op_next);
8833     PUSHBLOCK(cx,CXt_EVAL,SP);
8834     PUSHEVAL(cx,0);
8835
8836     /* prepare to compile string */
8837
8838     save_item(linestr);
8839     sv_setsv(linestr, sv);
8840     sv_catpv(linestr, "\n;");
8841     compiling.cop_filegv = gv_fetchfile("(eval)");
8842     compiling.cop_line = 1;
8843     if (perldb)
8844         save_lines(GvAV(curcop->cop_filegv), linestr);
8845     PUTBACK;
8846     return doeval();
8847 }
8848
8849 PP(pp_leaveeval)
8850 {
8851     dSP;
8852     register SV **mark;
8853     SV **newsp;
8854     I32 gimme;
8855     register CONTEXT *cx;
8856     OP *retop;
8857     I32 optype;
8858     OP *eroot = eval_root;
8859
8860     POPBLOCK(cx);
8861     POPEVAL(cx);
8862     retop = pop_return();
8863
8864     if (gimme == G_SCALAR) {
8865         MARK = newsp + 1;
8866         if (MARK <= SP)
8867             *MARK = sv_mortalcopy(TOPs);
8868         else {
8869             MEXTEND(mark,0);
8870             *MARK = &sv_undef;
8871         }
8872         SP = MARK;
8873     }
8874     else {
8875         for (mark = newsp + 1; mark <= SP; mark++)
8876             *mark = sv_mortalcopy(*mark);
8877                 /* in case LEAVE wipes old return values */
8878     }
8879
8880     if (optype != OP_ENTEREVAL) {
8881         char *name = cx->blk_eval.old_name;
8882
8883         if (gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp) {
8884             (void)hv_store(GvHVn(incgv), name,
8885               strlen(name), newSVsv(GvSV(curcop->cop_filegv)), 0 );
8886         }
8887         else if (optype == OP_REQUIRE)
8888             retop = die("%s did not return a true value", name);
8889         Safefree(name);
8890     }
8891     op_free(eroot);
8892     av_free(comppad);
8893
8894     LEAVE;
8895     sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
8896
8897     RETURNOP(retop);
8898 }
8899
8900 PP(pp_evalonce)
8901 {
8902     dSP;
8903 #ifdef NOTDEF
8904     SP = do_eval(st[1], OP_EVAL, curcop->cop_stash, TRUE,
8905         GIMME, arglast);
8906     if (eval_root) {
8907         sv_free(cSVOP->op_sv);
8908         op[1].arg_ptr.arg_cmd = eval_root;
8909         op[1].op_type = (A_CMD|A_DONT);
8910         op[0].op_type = OP_TRY;
8911     }
8912     RETURN;
8913
8914 #endif
8915     RETURN;
8916 }
8917
8918 PP(pp_entertry)
8919 {
8920     dSP;
8921     register CONTEXT *cx;
8922     I32 gimme = GIMME;
8923
8924     ENTER;
8925     SAVETMPS;
8926
8927     push_return(cLOGOP->op_other->op_next);
8928     PUSHBLOCK(cx,CXt_EVAL,SP);
8929     PUSHEVAL(cx,0);
8930
8931     in_eval = 1;
8932     sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
8933     RETURN;
8934 }
8935
8936 PP(pp_leavetry)
8937 {
8938     dSP;
8939     register SV **mark;
8940     SV **newsp;
8941     I32 gimme;
8942     register CONTEXT *cx;
8943     I32 optype;
8944
8945     POPBLOCK(cx);
8946     POPEVAL(cx);
8947     pop_return();
8948
8949     if (gimme == G_SCALAR) {
8950         MARK = newsp + 1;
8951         if (MARK <= SP)
8952             *MARK = sv_mortalcopy(TOPs);
8953         else {
8954             MEXTEND(mark,0);
8955             *MARK = &sv_undef;
8956         }
8957         SP = MARK;
8958     }
8959     else {
8960         for (mark = newsp + 1; mark <= SP; mark++)
8961             *mark = sv_mortalcopy(*mark);
8962                 /* in case LEAVE wipes old return values */
8963     }
8964
8965     LEAVE;
8966     sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
8967     RETURN;
8968 }
8969
8970 /* Get system info. */
8971
8972 PP(pp_ghbyname)
8973 {
8974 #ifdef HAS_SOCKET
8975     return pp_ghostent(ARGS);
8976 #else
8977     DIE(no_sock_func, "gethostbyname");
8978 #endif
8979 }
8980
8981 PP(pp_ghbyaddr)
8982 {
8983 #ifdef HAS_SOCKET
8984     return pp_ghostent(ARGS);
8985 #else
8986     DIE(no_sock_func, "gethostbyaddr");
8987 #endif
8988 }
8989
8990 PP(pp_ghostent)
8991 {
8992     dSP;
8993 #ifdef HAS_SOCKET
8994     I32 which = op->op_type;
8995     register char **elem;
8996     register SV *sv;
8997     struct hostent *gethostbyname();
8998     struct hostent *gethostbyaddr();
8999 #ifdef HAS_GETHOSTENT
9000     struct hostent *gethostent();
9001 #endif
9002     struct hostent *hent;
9003     unsigned long len;
9004
9005     EXTEND(SP, 10);
9006     if (which == OP_GHBYNAME) {
9007         hent = gethostbyname(POPp);
9008     }
9009     else if (which == OP_GHBYADDR) {
9010         int addrtype = POPi;
9011         SV *addrstr = POPs;
9012         char *addr = SvPVn(addrstr);
9013
9014         hent = gethostbyaddr(addr, SvCUR(addrstr), addrtype);
9015     }
9016     else
9017 #ifdef HAS_GETHOSTENT
9018         hent = gethostent();
9019 #else
9020         DIE("gethostent not implemented");
9021 #endif
9022
9023 #ifdef HOST_NOT_FOUND
9024     if (!hent)
9025         statusvalue = (U16)h_errno & 0xffff;
9026 #endif
9027
9028     if (GIMME != G_ARRAY) {
9029         PUSHs(sv = sv_mortalcopy(&sv_undef));
9030         if (hent) {
9031             if (which == OP_GHBYNAME) {
9032                 sv_setpvn(sv, hent->h_addr, hent->h_length);
9033             }
9034             else
9035                 sv_setpv(sv, hent->h_name);
9036         }
9037         RETURN;
9038     }
9039
9040     if (hent) {
9041         PUSHs(sv = sv_mortalcopy(&sv_no));
9042         sv_setpv(sv, hent->h_name);
9043         PUSHs(sv = sv_mortalcopy(&sv_no));
9044         for (elem = hent->h_aliases; *elem; elem++) {
9045             sv_catpv(sv, *elem);
9046             if (elem[1])
9047                 sv_catpvn(sv, " ", 1);
9048         }
9049         PUSHs(sv = sv_mortalcopy(&sv_no));
9050         sv_setiv(sv, (I32)hent->h_addrtype);
9051         PUSHs(sv = sv_mortalcopy(&sv_no));
9052         len = hent->h_length;
9053         sv_setiv(sv, (I32)len);
9054 #ifdef h_addr
9055         for (elem = hent->h_addr_list; *elem; elem++) {
9056             XPUSHs(sv = sv_mortalcopy(&sv_no));
9057             sv_setpvn(sv, *elem, len);
9058         }
9059 #else
9060         PUSHs(sv = sv_mortalcopy(&sv_no));
9061         sv_setpvn(sv, hent->h_addr, len);
9062 #endif /* h_addr */
9063     }
9064     RETURN;
9065 #else
9066     DIE(no_sock_func, "gethostent");
9067 #endif
9068 }
9069
9070 PP(pp_gnbyname)
9071 {
9072 #ifdef HAS_SOCKET
9073     return pp_gnetent(ARGS);
9074 #else
9075     DIE(no_sock_func, "getnetbyname");
9076 #endif
9077 }
9078
9079 PP(pp_gnbyaddr)
9080 {
9081 #ifdef HAS_SOCKET
9082     return pp_gnetent(ARGS);
9083 #else
9084     DIE(no_sock_func, "getnetbyaddr");
9085 #endif
9086 }
9087
9088 PP(pp_gnetent)
9089 {
9090     dSP;
9091 #ifdef HAS_SOCKET
9092     I32 which = op->op_type;
9093     register char **elem;
9094     register SV *sv;
9095     struct netent *getnetbyname();
9096     struct netent *getnetbyaddr();
9097     struct netent *getnetent();
9098     struct netent *nent;
9099
9100     if (which == OP_GNBYNAME)
9101         nent = getnetbyname(POPp);
9102     else if (which == OP_GNBYADDR) {
9103         int addrtype = POPi;
9104         unsigned long addr = U_L(POPn);
9105         nent = getnetbyaddr((long)addr, addrtype);
9106     }
9107     else
9108         nent = getnetent();
9109
9110     EXTEND(SP, 4);
9111     if (GIMME != G_ARRAY) {
9112         PUSHs(sv = sv_mortalcopy(&sv_undef));
9113         if (nent) {
9114             if (which == OP_GNBYNAME)
9115                 sv_setiv(sv, (I32)nent->n_net);
9116             else
9117                 sv_setpv(sv, nent->n_name);
9118         }
9119         RETURN;
9120     }
9121
9122     if (nent) {
9123         PUSHs(sv = sv_mortalcopy(&sv_no));
9124         sv_setpv(sv, nent->n_name);
9125         PUSHs(sv = sv_mortalcopy(&sv_no));
9126         for (elem = nent->n_aliases; *elem; elem++) {
9127             sv_catpv(sv, *elem);
9128             if (elem[1])
9129                 sv_catpvn(sv, " ", 1);
9130         }
9131         PUSHs(sv = sv_mortalcopy(&sv_no));
9132         sv_setiv(sv, (I32)nent->n_addrtype);
9133         PUSHs(sv = sv_mortalcopy(&sv_no));
9134         sv_setiv(sv, (I32)nent->n_net);
9135     }
9136
9137     RETURN;
9138 #else
9139     DIE(no_sock_func, "getnetent");
9140 #endif
9141 }
9142
9143 PP(pp_gpbyname)
9144 {
9145 #ifdef HAS_SOCKET
9146     return pp_gprotoent(ARGS);
9147 #else
9148     DIE(no_sock_func, "getprotobyname");
9149 #endif
9150 }
9151
9152 PP(pp_gpbynumber)
9153 {
9154 #ifdef HAS_SOCKET
9155     return pp_gprotoent(ARGS);
9156 #else
9157     DIE(no_sock_func, "getprotobynumber");
9158 #endif
9159 }
9160
9161 PP(pp_gprotoent)
9162 {
9163     dSP;
9164 #ifdef HAS_SOCKET
9165     I32 which = op->op_type;
9166     register char **elem;
9167     register SV *sv;
9168     struct protoent *getprotobyname();
9169     struct protoent *getprotobynumber();
9170     struct protoent *getprotoent();
9171     struct protoent *pent;
9172
9173     if (which == OP_GPBYNAME)
9174         pent = getprotobyname(POPp);
9175     else if (which == OP_GPBYNUMBER)
9176         pent = getprotobynumber(POPi);
9177     else
9178         pent = getprotoent();
9179
9180     EXTEND(SP, 3);
9181     if (GIMME != G_ARRAY) {
9182         PUSHs(sv = sv_mortalcopy(&sv_undef));
9183         if (pent) {
9184             if (which == OP_GPBYNAME)
9185                 sv_setiv(sv, (I32)pent->p_proto);
9186             else
9187                 sv_setpv(sv, pent->p_name);
9188         }
9189         RETURN;
9190     }
9191
9192     if (pent) {
9193         PUSHs(sv = sv_mortalcopy(&sv_no));
9194         sv_setpv(sv, pent->p_name);
9195         PUSHs(sv = sv_mortalcopy(&sv_no));
9196         for (elem = pent->p_aliases; *elem; elem++) {
9197             sv_catpv(sv, *elem);
9198             if (elem[1])
9199                 sv_catpvn(sv, " ", 1);
9200         }
9201         PUSHs(sv = sv_mortalcopy(&sv_no));
9202         sv_setiv(sv, (I32)pent->p_proto);
9203     }
9204
9205     RETURN;
9206 #else
9207     DIE(no_sock_func, "getprotoent");
9208 #endif
9209 }
9210
9211 PP(pp_gsbyname)
9212 {
9213 #ifdef HAS_SOCKET
9214     return pp_gservent(ARGS);
9215 #else
9216     DIE(no_sock_func, "getservbyname");
9217 #endif
9218 }
9219
9220 PP(pp_gsbyport)
9221 {
9222 #ifdef HAS_SOCKET
9223     return pp_gservent(ARGS);
9224 #else
9225     DIE(no_sock_func, "getservbyport");
9226 #endif
9227 }
9228
9229 PP(pp_gservent)
9230 {
9231     dSP;
9232 #ifdef HAS_SOCKET
9233     I32 which = op->op_type;
9234     register char **elem;
9235     register SV *sv;
9236     struct servent *getservbyname();
9237     struct servent *getservbynumber();
9238     struct servent *getservent();
9239     struct servent *sent;
9240
9241     if (which == OP_GSBYNAME) {
9242         char *proto = POPp;
9243         char *name = POPp;
9244
9245         if (proto && !*proto)
9246             proto = Nullch;
9247
9248         sent = getservbyname(name, proto);
9249     }
9250     else if (which == OP_GSBYPORT) {
9251         char *proto = POPp;
9252         int port = POPi;
9253
9254         sent = getservbyport(port, proto);
9255     }
9256     else
9257         sent = getservent();
9258
9259     EXTEND(SP, 4);
9260     if (GIMME != G_ARRAY) {
9261         PUSHs(sv = sv_mortalcopy(&sv_undef));
9262         if (sent) {
9263             if (which == OP_GSBYNAME) {
9264 #ifdef HAS_NTOHS
9265                 sv_setiv(sv, (I32)ntohs(sent->s_port));
9266 #else
9267                 sv_setiv(sv, (I32)(sent->s_port));
9268 #endif
9269             }
9270             else
9271                 sv_setpv(sv, sent->s_name);
9272         }
9273         RETURN;
9274     }
9275
9276     if (sent) {
9277         PUSHs(sv = sv_mortalcopy(&sv_no));
9278         sv_setpv(sv, sent->s_name);
9279         PUSHs(sv = sv_mortalcopy(&sv_no));
9280         for (elem = sent->s_aliases; *elem; elem++) {
9281             sv_catpv(sv, *elem);
9282             if (elem[1])
9283                 sv_catpvn(sv, " ", 1);
9284         }
9285         PUSHs(sv = sv_mortalcopy(&sv_no));
9286 #ifdef HAS_NTOHS
9287         sv_setiv(sv, (I32)ntohs(sent->s_port));
9288 #else
9289         sv_setiv(sv, (I32)(sent->s_port));
9290 #endif
9291         PUSHs(sv = sv_mortalcopy(&sv_no));
9292         sv_setpv(sv, sent->s_proto);
9293     }
9294
9295     RETURN;
9296 #else
9297     DIE(no_sock_func, "getservent");
9298 #endif
9299 }
9300
9301 PP(pp_shostent)
9302 {
9303     dSP; dTARGET;
9304 #ifdef HAS_SOCKET
9305     SETi( sethostent(TOPi) );
9306     RETURN;
9307 #else
9308     DIE(no_sock_func, "sethostent");
9309 #endif
9310 }
9311
9312 PP(pp_snetent)
9313 {
9314     dSP; dTARGET;
9315 #ifdef HAS_SOCKET
9316     SETi( setnetent(TOPi) );
9317     RETURN;
9318 #else
9319     DIE(no_sock_func, "setnetent");
9320 #endif
9321 }
9322
9323 PP(pp_sprotoent)
9324 {
9325     dSP; dTARGET;
9326 #ifdef HAS_SOCKET
9327     SETi( setprotoent(TOPi) );
9328     RETURN;
9329 #else
9330     DIE(no_sock_func, "setprotoent");
9331 #endif
9332 }
9333
9334 PP(pp_sservent)
9335 {
9336     dSP; dTARGET;
9337 #ifdef HAS_SOCKET
9338     SETi( setservent(TOPi) );
9339     RETURN;
9340 #else
9341     DIE(no_sock_func, "setservent");
9342 #endif
9343 }
9344
9345 PP(pp_ehostent)
9346 {
9347     dSP; dTARGET;
9348 #ifdef HAS_SOCKET
9349     XPUSHi( endhostent() );
9350     RETURN;
9351 #else
9352     DIE(no_sock_func, "endhostent");
9353 #endif
9354 }
9355
9356 PP(pp_enetent)
9357 {
9358     dSP; dTARGET;
9359 #ifdef HAS_SOCKET
9360     XPUSHi( endnetent() );
9361     RETURN;
9362 #else
9363     DIE(no_sock_func, "endnetent");
9364 #endif
9365 }
9366
9367 PP(pp_eprotoent)
9368 {
9369     dSP; dTARGET;
9370 #ifdef HAS_SOCKET
9371     XPUSHi( endprotoent() );
9372     RETURN;
9373 #else
9374     DIE(no_sock_func, "endprotoent");
9375 #endif
9376 }
9377
9378 PP(pp_eservent)
9379 {
9380     dSP; dTARGET;
9381 #ifdef HAS_SOCKET
9382     XPUSHi( endservent() );
9383     RETURN;
9384 #else
9385     DIE(no_sock_func, "endservent");
9386 #endif
9387 }
9388
9389 PP(pp_gpwnam)
9390 {
9391 #ifdef HAS_PASSWD
9392     return pp_gpwent(ARGS);
9393 #else
9394     DIE(no_func, "getpwnam");
9395 #endif
9396 }
9397
9398 PP(pp_gpwuid)
9399 {
9400 #ifdef HAS_PASSWD
9401     return pp_gpwent(ARGS);
9402 #else
9403     DIE(no_func, "getpwuid");
9404 #endif
9405 }
9406
9407 PP(pp_gpwent)
9408 {
9409     dSP;
9410 #ifdef HAS_PASSWD
9411     I32 which = op->op_type;
9412     register AV *ary = stack;
9413     register SV *sv;
9414     struct passwd *getpwnam();
9415     struct passwd *getpwuid();
9416     struct passwd *getpwent();
9417     struct passwd *pwent;
9418
9419     if (which == OP_GPWNAM)
9420         pwent = getpwnam(POPp);
9421     else if (which == OP_GPWUID)
9422         pwent = getpwuid(POPi);
9423     else
9424         pwent = getpwent();
9425
9426     EXTEND(SP, 10);
9427     if (GIMME != G_ARRAY) {
9428         PUSHs(sv = sv_mortalcopy(&sv_undef));
9429         if (pwent) {
9430             if (which == OP_GPWNAM)
9431                 sv_setiv(sv, (I32)pwent->pw_uid);
9432             else
9433                 sv_setpv(sv, pwent->pw_name);
9434         }
9435         RETURN;
9436     }
9437
9438     if (pwent) {
9439         PUSHs(sv = sv_mortalcopy(&sv_no));
9440         sv_setpv(sv, pwent->pw_name);
9441         PUSHs(sv = sv_mortalcopy(&sv_no));
9442         sv_setpv(sv, pwent->pw_passwd);
9443         PUSHs(sv = sv_mortalcopy(&sv_no));
9444         sv_setiv(sv, (I32)pwent->pw_uid);
9445         PUSHs(sv = sv_mortalcopy(&sv_no));
9446         sv_setiv(sv, (I32)pwent->pw_gid);
9447         PUSHs(sv = sv_mortalcopy(&sv_no));
9448 #ifdef PWCHANGE
9449         sv_setiv(sv, (I32)pwent->pw_change);
9450 #else
9451 #ifdef PWQUOTA
9452         sv_setiv(sv, (I32)pwent->pw_quota);
9453 #else
9454 #ifdef PWAGE
9455         sv_setpv(sv, pwent->pw_age);
9456 #endif
9457 #endif
9458 #endif
9459         PUSHs(sv = sv_mortalcopy(&sv_no));
9460 #ifdef PWCLASS
9461         sv_setpv(sv, pwent->pw_class);
9462 #else
9463 #ifdef PWCOMMENT
9464         sv_setpv(sv, pwent->pw_comment);
9465 #endif
9466 #endif
9467         PUSHs(sv = sv_mortalcopy(&sv_no));
9468         sv_setpv(sv, pwent->pw_gecos);
9469         PUSHs(sv = sv_mortalcopy(&sv_no));
9470         sv_setpv(sv, pwent->pw_dir);
9471         PUSHs(sv = sv_mortalcopy(&sv_no));
9472         sv_setpv(sv, pwent->pw_shell);
9473 #ifdef PWEXPIRE
9474         PUSHs(sv = sv_mortalcopy(&sv_no));
9475         sv_setiv(sv, (I32)pwent->pw_expire);
9476 #endif
9477     }
9478     RETURN;
9479 #else
9480     DIE(no_func, "getpwent");
9481 #endif
9482 }
9483
9484 PP(pp_spwent)
9485 {
9486     dSP; dTARGET;
9487 #ifdef HAS_PASSWD
9488     setpwent();
9489     RETPUSHYES;
9490 #else
9491     DIE(no_func, "setpwent");
9492 #endif
9493 }
9494
9495 PP(pp_epwent)
9496 {
9497     dSP; dTARGET;
9498 #ifdef HAS_PASSWD
9499     endpwent();
9500     RETPUSHYES;
9501 #else
9502     DIE(no_func, "endpwent");
9503 #endif
9504 }
9505
9506 PP(pp_ggrnam)
9507 {
9508 #ifdef HAS_GROUP
9509     return pp_ggrent(ARGS);
9510 #else
9511     DIE(no_func, "getgrnam");
9512 #endif
9513 }
9514
9515 PP(pp_ggrgid)
9516 {
9517 #ifdef HAS_GROUP
9518     return pp_ggrent(ARGS);
9519 #else
9520     DIE(no_func, "getgrgid");
9521 #endif
9522 }
9523
9524 PP(pp_ggrent)
9525 {
9526     dSP;
9527 #ifdef HAS_GROUP
9528     I32 which = op->op_type;
9529     register char **elem;
9530     register SV *sv;
9531     struct group *getgrnam();
9532     struct group *getgrgid();
9533     struct group *getgrent();
9534     struct group *grent;
9535
9536     if (which == OP_GGRNAM)
9537         grent = getgrnam(POPp);
9538     else if (which == OP_GGRGID)
9539         grent = getgrgid(POPi);
9540     else
9541         grent = getgrent();
9542
9543     EXTEND(SP, 4);
9544     if (GIMME != G_ARRAY) {
9545         PUSHs(sv = sv_mortalcopy(&sv_undef));
9546         if (grent) {
9547             if (which == OP_GGRNAM)
9548                 sv_setiv(sv, (I32)grent->gr_gid);
9549             else
9550                 sv_setpv(sv, grent->gr_name);
9551         }
9552         RETURN;
9553     }
9554
9555     if (grent) {
9556         PUSHs(sv = sv_mortalcopy(&sv_no));
9557         sv_setpv(sv, grent->gr_name);
9558         PUSHs(sv = sv_mortalcopy(&sv_no));
9559         sv_setpv(sv, grent->gr_passwd);
9560         PUSHs(sv = sv_mortalcopy(&sv_no));
9561         sv_setiv(sv, (I32)grent->gr_gid);
9562         PUSHs(sv = sv_mortalcopy(&sv_no));
9563         for (elem = grent->gr_mem; *elem; elem++) {
9564             sv_catpv(sv, *elem);
9565             if (elem[1])
9566                 sv_catpvn(sv, " ", 1);
9567         }
9568     }
9569
9570     RETURN;
9571 #else
9572     DIE(no_func, "getgrent");
9573 #endif
9574 }
9575
9576 PP(pp_sgrent)
9577 {
9578     dSP; dTARGET;
9579 #ifdef HAS_GROUP
9580     setgrent();
9581     RETPUSHYES;
9582 #else
9583     DIE(no_func, "setgrent");
9584 #endif
9585 }
9586
9587 PP(pp_egrent)
9588 {
9589     dSP; dTARGET;
9590 #ifdef HAS_GROUP
9591     endgrent();
9592     RETPUSHYES;
9593 #else
9594     DIE(no_func, "endgrent");
9595 #endif
9596 }
9597
9598 PP(pp_getlogin)
9599 {
9600     dSP; dTARGET;
9601 #ifdef HAS_GETLOGIN
9602     char *tmps;
9603     EXTEND(SP, 1);
9604     if (!(tmps = getlogin()))
9605         RETPUSHUNDEF;
9606     PUSHp(tmps, strlen(tmps));
9607     RETURN;
9608 #else
9609     DIE(no_func, "getlogin");
9610 #endif
9611 }
9612
9613 /* Miscellaneous. */
9614
9615 PP(pp_syscall)
9616 {
9617 #ifdef HAS_SYSCALL
9618     dSP; dMARK; dORIGMARK; dTARGET;
9619     register I32 items = SP - MARK;
9620     unsigned long a[20];
9621     register I32 i = 0;
9622     I32 retval = -1;
9623
9624 #ifdef TAINT
9625     while (++MARK <= SP)
9626         TAINT_IF((*MARK)->sv_tainted);
9627     MARK = ORIGMARK;
9628     TAINT_PROPER("syscall");
9629 #endif
9630
9631     /* This probably won't work on machines where sizeof(long) != sizeof(int)
9632      * or where sizeof(long) != sizeof(char*).  But such machines will
9633      * not likely have syscall implemented either, so who cares?
9634      */
9635     while (++MARK <= SP) {
9636         if (SvNIOK(*MARK) || !i)
9637             a[i++] = SvIVn(*MARK);
9638         else
9639             a[i++] = (unsigned long)SvPV(*MARK);
9640         if (i > 15)
9641             break;
9642     }
9643     switch (items) {
9644     default:
9645         DIE("Too many args to syscall");
9646     case 0:
9647         DIE("Too few args to syscall");
9648     case 1:
9649         retval = syscall(a[0]);
9650         break;
9651     case 2:
9652         retval = syscall(a[0],a[1]);
9653         break;
9654     case 3:
9655         retval = syscall(a[0],a[1],a[2]);
9656         break;
9657     case 4:
9658         retval = syscall(a[0],a[1],a[2],a[3]);
9659         break;
9660     case 5:
9661         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
9662         break;
9663     case 6:
9664         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
9665         break;
9666     case 7:
9667         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
9668         break;
9669     case 8:
9670         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
9671         break;
9672 #ifdef atarist
9673     case 9:
9674         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
9675         break;
9676     case 10:
9677         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
9678         break;
9679     case 11:
9680         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
9681           a[10]);
9682         break;
9683     case 12:
9684         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
9685           a[10],a[11]);
9686         break;
9687     case 13:
9688         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
9689           a[10],a[11],a[12]);
9690         break;
9691     case 14:
9692         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
9693           a[10],a[11],a[12],a[13]);
9694         break;
9695 #endif /* atarist */
9696     }
9697     SP = ORIGMARK;
9698     PUSHi(retval);
9699     RETURN;
9700 #else
9701     DIE(no_func, "syscall");
9702 #endif
9703 }