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