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