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