perl.c

   1 /*
   2  *    Copyright (c) 1991, 1992, 1993, 1994 Larry Wall
   3  *
   4  *    You may distribute under the terms of either the GNU General Public
   5  *    License or the Artistic License, as specified in the README file.
   6  *
   7  * $Log:        perl.c,v $
   8  * Revision 4.1  92/08/07  18:25:50  lwall
   9  *
  10  * Revision 4.0.1.7  92/06/08  14:50:39  lwall
  11  * patch20: PERLLIB now supports multiple directories
  12  * patch20: running taintperl explicitly now does checks even if $< == $>
  13  * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
  14  * patch20: perl -P now uses location of sed determined by Configure
  15  * patch20: form feed for formats is now specifiable via $^L
  16  * patch20: paragraph mode now skips extra newlines automatically
  17  * patch20: oldeval "1 #comment" didn't work
  18  * patch20: couldn't require . files
  19  * patch20: semantic compilation errors didn't abort execution
  20  *
  21  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
  22  * patch19: default arg for shift was wrong after first subroutine definition
  23  * patch19: op/regexp.t failed from missing arg to bcmp()
  24  *
  25  * Revision 4.0.1.5  91/11/05  18:03:32  lwall
  26  * patch11: random cleanup
  27  * patch11: $0 was being truncated at times
  28  * patch11: cppstdin now installed outside of source directory
  29  * patch11: -P didn't allow use of #elif or #undef
  30  * patch11: prepared for ctype implementations that don't define isascii()
  31  * patch11: added oldeval {}
  32  * patch11: oldeval confused by string containing null
  33  *
  34  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  35  * patch10: perl -v printed incorrect copyright notice
  36  *
  37  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  38  * patch4: changed old $^P to $^X
  39  *
  40  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  41  * patch4: new copyright notice
  42  * patch4: added $^P variable to control calling of perldb routines
  43  * patch4: added $^F variable to specify maximum system fd, default 2
  44  * patch4: debugger lost track of lines in oldeval
  45  *
  46  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  47  * patch1: fixed undefined environ problem
  48  *
  49  * Revision 4.0  91/03/20  01:37:44  lwall
  50  * 4.0 baseline.
  51  *
  52  */
  53
  54 /*SUPPRESS 560*/
  55
  56 #include "EXTERN.h"
  57 #include "perl.h"
  58 #include "perly.h"
  59 #include "patchlevel.h"
  60
  61 char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\nPatch level: ###\n";
  62
  63 #ifdef IAMSUID
  64 #ifndef DOSUID
  65 #define DOSUID
  66 #endif
  67 #endif
  68
  69 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  70 #ifdef DOSUID
  71 #undef DOSUID
  72 #endif
  73 #endif
  74
  75 static void incpush();
  76 static void validate_suid();
  77 static void find_beginning();
  78 static void init_main_stash();
  79 static void open_script();
  80 static void init_debugger();
  81 static void init_stacks();
  82 static void init_lexer();
  83 static void init_predump_symbols();
  84 static void init_postdump_symbols();
  85 static void init_perllib();
  86
  87 PerlInterpreter *
  88 perl_alloc()
  89 {
  90     PerlInterpreter *sv_interp;
  91     PerlInterpreter junk;
  92
  93     curinterp = 0;
  94 /*    Zero(&junk, 1, PerlInterpreter); */
  95     New(53, sv_interp, 1, PerlInterpreter);
  96     return sv_interp;
  97 }
  98
  99 void
 100 perl_construct( sv_interp )
 101 register PerlInterpreter *sv_interp;
 102 {
 103     char* s;
 104
 105     if (!(curinterp = sv_interp))
 106         return;
 107
 108 #ifdef MULTIPLICITY
 109     Zero(sv_interp, 1, PerlInterpreter);
 110 #endif
 111
 112     /* Init the real globals? */
 113     if (!linestr) {
 114         linestr = NEWSV(65,80);
 115         sv_upgrade(linestr,SVt_PVIV);
 116
 117         SvREADONLY_on(&sv_undef);
 118
 119         sv_setpv(&sv_no,No);
 120         SvNV(&sv_no);
 121         SvREADONLY_on(&sv_no);
 122
 123         sv_setpv(&sv_yes,Yes);
 124         SvNV(&sv_yes);
 125         SvREADONLY_on(&sv_yes);
 126
 127 #ifdef MSDOS
 128         /*
 129          * There is no way we can refer to them from Perl so close them to save
 130          * space.  The other alternative would be to provide STDAUX and STDPRN
 131          * filehandles.
 132          */
 133         (void)fclose(stdaux);
 134         (void)fclose(stdprn);
 135 #endif
 136     }
 137
 138 #ifdef MULTIPLICITY
 139     chopset     = " \n-";
 140     copline     = NOLINE;
 141     curcop      = &compiling;
 142     dlmax       = 128;
 143     laststatval = -1;
 144     laststype   = OP_STAT;
 145     maxscream   = -1;
 146     maxsysfd    = MAXSYSFD;
 147     nrs         = "\n";
 148     nrschar     = '\n';
 149     nrslen      = 1;
 150     rs          = "\n";
 151     rschar      = '\n';
 152     rsfp        = Nullfp;
 153     rslen       = 1;
 154     statname    = Nullsv;
 155     tmps_floor  = -1;
 156 #endif
 157
 158     uid = (int)getuid();
 159     euid = (int)geteuid();
 160     gid = (int)getgid();
 161     egid = (int)getegid();
 162     tainting = (euid != uid || egid != gid);
 163     if (s = strchr(rcsid,'#')) {
 164         (void)sprintf(s, "%d\n", PATCHLEVEL);
 165         sprintf(patchlevel,"%3.3s%2.2d", strchr(rcsid,'5'), PATCHLEVEL);
 166     }
 167
 168     fdpid = newAV();    /* for remembering popen pids by fd */
 169     pidstatus = newHV();/* for remembering status of dead pids */
 170
 171     init_stacks();
 172     ENTER;
 173 }
 174
 175 void
 176 perl_destruct(sv_interp)
 177 register PerlInterpreter *sv_interp;
 178 {
 179     I32 last_sv_count;
 180
 181     if (!(curinterp = sv_interp))
 182         return;
 183     LEAVE;
 184     FREE_TMPS();
 185
 186 #ifndef EMBED
 187     /* The exit() function may do everything that needs doing. */
 188     if (!sv_rvcount)
 189         return;
 190 #endif
 191
 192     /* Not so lucky.  We must account for everything.  First the syntax tree. */
 193     if (main_root) {
 194         curpad = AvARRAY(comppad);
 195         op_free(main_root);
 196         main_root = 0;
 197     }
 198
 199     /*
 200      * Try to destruct global references.  We do this first so that the
 201      * destructors and destructees still exist.  This code currently
 202      * will break simple reference loops but may fail on more complicated
 203      * ones.  If so, the code below will clean up, but any destructors
 204      * may fail to find what they're looking for.
 205      */
 206     dirty = TRUE;
 207     if (sv_count != 0)
 208         sv_clean_refs();
 209
 210     /* Delete self-reference from main symbol table */
 211     GvHV(gv_fetchpv("::_main",TRUE, SVt_PVHV)) = 0;
 212     --SvREFCNT(defstash);
 213
 214     /* Try to destruct main symbol table.  May fail on reference loops. */
 215     SvREFCNT_dec(defstash);
 216     defstash = 0;
 217
 218     FREE_TMPS();
 219 #ifdef DEBUGGING
 220     if (scopestack_ix != 0)
 221         warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
 222     if (savestack_ix != 0)
 223         warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
 224     if (tmps_floor != -1)
 225         warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
 226     if (cxstack_ix != -1)
 227         warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
 228 #endif
 229
 230     /* Now absolutely destruct everything, somehow or other, loops or no. */
 231     last_sv_count = 0;
 232     while (sv_count != 0 && sv_count != last_sv_count) {
 233         last_sv_count = sv_count;
 234         sv_clean_all();
 235     }
 236     if (sv_count != 0)
 237         warn("Scalars leaked: %d\n", sv_count);
 238 }
 239
 240 void
 241 perl_free(sv_interp)
 242 PerlInterpreter *sv_interp;
 243 {
 244     if (!(curinterp = sv_interp))
 245         return;
 246     Safefree(sv_interp);
 247 }
 248
 249 int
 250 perl_parse(sv_interp, argc, argv, env)
 251 PerlInterpreter *sv_interp;
 252 register int argc;
 253 register char **argv;
 254 char **env;
 255 {
 256     register SV *sv;
 257     register char *s;
 258     char *scriptname;
 259     char *getenv();
 260     bool dosearch = FALSE;
 261     char *validarg = "";
 262
 263 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 264 #ifdef IAMSUID
 265 #undef IAMSUID
 266     croak("suidperl is no longer needed since the kernel can now execute\n\
 267 setuid perl scripts securely.\n");
 268 #endif
 269 #endif
 270
 271     if (!(curinterp = sv_interp))
 272         return 255;
 273
 274     if (main_root)
 275         op_free(main_root);
 276     main_root = 0;
 277
 278     origargv = argv;
 279     origargc = argc;
 280     origenviron = environ;
 281
 282     switch (setjmp(top_env)) {
 283     case 1:
 284         statusvalue = 255;
 285     case 2:
 286         curstash = defstash;
 287         if (endav)
 288             calllist(endav);
 289         return(statusvalue);    /* my_exit() was called */
 290     case 3:
 291         fprintf(stderr, "panic: top_env\n");
 292         return 1;
 293     }
 294
 295     if (do_undump) {
 296
 297         /* Come here if running an undumped a.out. */
 298
 299         origfilename = savestr(argv[0]);
 300         do_undump = FALSE;
 301         cxstack_ix = -1;                /* start label stack again */
 302         init_postdump_symbols(argc,argv,env);
 303         return 0;
 304     }
 305
 306     sv_setpvn(linestr,"",0);
 307     sv = newSVpv("",0);         /* first used for -I flags */
 308     SAVEFREESV(sv);
 309     init_main_stash();
 310     for (argc--,argv++; argc > 0; argc--,argv++) {
 311         if (argv[0][0] != '-' || !argv[0][1])
 312             break;
 313 #ifdef DOSUID
 314     if (*validarg)
 315         validarg = " PHOOEY ";
 316     else
 317         validarg = argv[0];
 318 #endif
 319         s = argv[0]+1;
 320       reswitch:
 321         switch (*s) {
 322         case '0':
 323         case 'F':
 324         case 'a':
 325         case 'c':
 326         case 'd':
 327         case 'D':
 328         case 'i':
 329         case 'l':
 330         case 'n':
 331         case 'p':
 332         case 's':
 333         case 'T':
 334         case 'u':
 335         case 'U':
 336         case 'v':
 337         case 'w':
 338             if (s = moreswitches(s))
 339                 goto reswitch;
 340             break;
 341
 342         case 'e':
 343             if (euid != uid || egid != gid)
 344                 croak("No -e allowed in setuid scripts");
 345             if (!e_fp) {
 346                 e_tmpname = savestr(TMPPATH);
 347                 (void)mktemp(e_tmpname);
 348                 if (!*e_tmpname)
 349                     croak("Can't mktemp()");
 350                 e_fp = fopen(e_tmpname,"w");
 351                 if (!e_fp)
 352                     croak("Cannot open temporary file");
 353             }
 354             if (argv[1]) {
 355                 fputs(argv[1],e_fp);
 356                 argc--,argv++;
 357             }
 358             (void)putc('\n', e_fp);
 359             break;
 360         case 'I':
 361             taint_not("-I");
 362             sv_catpv(sv,"-");
 363             sv_catpv(sv,s);
 364             sv_catpv(sv," ");
 365             if (*++s) {
 366                 (void)av_push(GvAVn(incgv),newSVpv(s,0));
 367             }
 368             else if (argv[1]) {
 369                 (void)av_push(GvAVn(incgv),newSVpv(argv[1],0));
 370                 sv_catpv(sv,argv[1]);
 371                 argc--,argv++;
 372                 sv_catpv(sv," ");
 373             }
 374             break;
 375         case 'P':
 376             taint_not("-P");
 377             preprocess = TRUE;
 378             s++;
 379             goto reswitch;
 380         case 'S':
 381             taint_not("-S");
 382             dosearch = TRUE;
 383             s++;
 384             goto reswitch;
 385         case 'x':
 386             doextract = TRUE;
 387             s++;
 388             if (*s)
 389                 cddir = savestr(s);
 390             break;
 391         case '-':
 392             argc--,argv++;
 393             goto switch_end;
 394         case 0:
 395             break;
 396         default:
 397             croak("Unrecognized switch: -%s",s);
 398         }
 399     }
 400   switch_end:
 401     scriptname = argv[0];
 402     if (e_fp) {
 403         if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
 404             croak("Can't write to temp file for -e: %s", Strerror(errno));
 405         argc++,argv--;
 406         scriptname = e_tmpname;
 407     }
 408     else if (scriptname == Nullch) {
 409 #ifdef MSDOS
 410         if ( isatty(fileno(stdin)) )
 411             moreswitches("v");
 412 #endif
 413         scriptname = "-";
 414     }
 415
 416     init_perllib();
 417
 418     open_script(scriptname,dosearch,sv);
 419
 420     validate_suid(validarg);
 421
 422     if (doextract)
 423         find_beginning();
 424
 425     if (perldb)
 426         init_debugger();
 427
 428     pad = newAV();
 429     comppad = pad;
 430     av_push(comppad, Nullsv);
 431     curpad = AvARRAY(comppad);
 432     padname = newAV();
 433     comppad_name = padname;
 434     comppad_name_fill = 0;
 435     min_intro_pending = 0;
 436     padix = 0;
 437
 438     perl_init_ext();    /* in case linked C routines want magical variables */
 439
 440     init_predump_symbols();
 441     if (!do_undump)
 442         init_postdump_symbols(argc,argv,env);
 443
 444     init_lexer();
 445
 446     /* now parse the script */
 447
 448     error_count = 0;
 449     if (yyparse() || error_count) {
 450         if (minus_c)
 451             croak("%s had compilation errors.\n", origfilename);
 452         else {
 453             croak("Execution of %s aborted due to compilation errors.\n",
 454                 origfilename);
 455         }
 456     }
 457     curcop->cop_line = 0;
 458     curstash = defstash;
 459     preprocess = FALSE;
 460     if (e_fp) {
 461         e_fp = Nullfp;
 462         (void)UNLINK(e_tmpname);
 463     }
 464
 465     /* now that script is parsed, we can modify record separator */
 466
 467     rs = nrs;
 468     rslen = nrslen;
 469     rschar = nrschar;
 470     rspara = (nrslen == 2);
 471     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs, rslen);
 472
 473     if (do_undump)
 474         my_unexec();
 475
 476     if (dowarn)
 477         gv_check(defstash);
 478
 479     return 0;
 480 }
 481
 482 int
 483 perl_run(sv_interp)
 484 PerlInterpreter *sv_interp;
 485 {
 486     if (!(curinterp = sv_interp))
 487         return 255;
 488     switch (setjmp(top_env)) {
 489     case 1:
 490         cxstack_ix = -1;                /* start context stack again */
 491         break;
 492     case 2:
 493         curstash = defstash;
 494         if (endav)
 495             calllist(endav);
 496         FREE_TMPS();
 497         return(statusvalue);            /* my_exit() was called */
 498     case 3:
 499         if (!restartop) {
 500             fprintf(stderr, "panic: restartop\n");
 501             FREE_TMPS();
 502             return 1;
 503         }
 504         if (stack != mainstack) {
 505             dSP;
 506             SWITCHSTACK(stack, mainstack);
 507         }
 508         break;
 509     }
 510
 511     if (!restartop) {
 512         DEBUG_x(dump_all());
 513         DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
 514
 515         if (minus_c) {
 516             fprintf(stderr,"%s syntax OK\n", origfilename);
 517             my_exit(0);
 518         }
 519     }
 520
 521     /* do it */
 522
 523     if (restartop) {
 524         op = restartop;
 525         restartop = 0;
 526         run();
 527     }
 528     else if (main_start) {
 529         op = main_start;
 530         run();
 531     }
 532
 533     my_exit(0);
 534 }
 535
 536 void
 537 my_exit(status)
 538 int status;
 539 {
 540     statusvalue = (unsigned short)(status & 0xffff);
 541     longjmp(top_env, 2);
 542 }
 543
 544 /* Be sure to refetch the stack pointer after calling these routines. */
 545
 546 int
 547 perl_callargv(subname, sp, gimme, argv)
 548 char *subname;
 549 register I32 sp;        /* current stack pointer */
 550 I32 gimme;              /* TRUE if called in list context */
 551 register char **argv;   /* null terminated arg list, NULL for no arglist */
 552 {
 553     register I32 items = 0;
 554     I32 hasargs = (argv != 0);
 555
 556     av_store(stack, ++sp, Nullsv);      /* reserve spot for sub reference */
 557     if (hasargs) {
 558         while (*argv) {
 559             av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0)));
 560             items++;
 561             argv++;
 562         }
 563     }
 564     return perl_callpv(subname, sp, gimme, hasargs, items);
 565 }
 566
 567 int
 568 perl_callpv(subname, sp, gimme, hasargs, numargs)
 569 char *subname;
 570 I32 sp;                 /* stack pointer after args are pushed */
 571 I32 gimme;              /* TRUE if called in list context */
 572 I32 hasargs;            /* whether to create a @_ array for routine */
 573 I32 numargs;            /* how many args are pushed on the stack */
 574 {
 575     return perl_callsv((SV*)gv_fetchpv(subname, TRUE, SVt_PVCV),
 576                         sp, gimme, hasargs, numargs);
 577 }
 578
 579 /* May be called with any of a CV, a GV, or an SV containing the name. */
 580 int
 581 perl_callsv(sv, sp, gimme, hasargs, numargs)
 582 SV* sv;
 583 I32 sp;                 /* stack pointer after args are pushed */
 584 I32 gimme;              /* TRUE if called in list context */
 585 I32 hasargs;            /* whether to create a @_ array for routine */
 586 I32 numargs;            /* how many args are pushed on the stack */
 587 {
 588     BINOP myop;         /* fake syntax tree node */
 589
 590     ENTER;
 591     SAVETMPS;
 592     SAVESPTR(op);
 593     stack_base = AvARRAY(stack);
 594     stack_sp = stack_base + sp - numargs - 1;
 595     op = (OP*)&myop;
 596     Zero(op, 1, BINOP);
 597     pp_pushmark();      /* doesn't look at op, actually, except to return */
 598     *++stack_sp = sv;
 599     stack_sp += numargs;
 600
 601     if (hasargs) {
 602         myop.op_flags = OPf_STACKED;
 603         myop.op_last = (OP*)&myop;
 604     }
 605     myop.op_next = Nullop;
 606
 607     if (op = pp_entersubr())
 608         run();
 609     FREE_TMPS();
 610     LEAVE;
 611     return stack_sp - stack_base;
 612 }
 613
 614 void
 615 magicname(sym,name,namlen)
 616 char *sym;
 617 char *name;
 618 I32 namlen;
 619 {
 620     register GV *gv;
 621
 622     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
 623         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
 624 }
 625
 626 #ifdef DOSISH
 627 #define PERLLIB_SEP ';'
 628 #else
 629 #define PERLLIB_SEP ':'
 630 #endif
 631
 632 static void
 633 incpush(p)
 634 char *p;
 635 {
 636     char *s;
 637
 638     if (!p)
 639         return;
 640
 641     /* Break at all separators */
 642     while (*p) {
 643         /* First, skip any consecutive separators */
 644         while ( *p == PERLLIB_SEP ) {
 645             /* Uncomment the next line for PATH semantics */
 646             /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */
 647             p++;
 648         }
 649         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
 650             (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p)));
 651             p = s + 1;
 652         } else {
 653             (void)av_push(GvAVn(incgv), newSVpv(p, 0));
 654             break;
 655         }
 656     }
 657 }
 658
 659 /* This routine handles any switches that can be given during run */
 660
 661 char *
 662 moreswitches(s)
 663 char *s;
 664 {
 665     I32 numlen;
 666
 667     switch (*s) {
 668     case '0':
 669         nrschar = scan_oct(s, 4, &numlen);
 670         nrs = nsavestr("\n",1);
 671         *nrs = nrschar;
 672         if (nrschar > 0377) {
 673             nrslen = 0;
 674             nrs = "";
 675         }
 676         else if (!nrschar && numlen >= 2) {
 677             nrslen = 2;
 678             nrs = "\n\n";
 679             nrschar = '\n';
 680         }
 681         return s + numlen;
 682     case 'F':
 683         minus_F = TRUE;
 684         splitstr = savestr(s + 1);
 685         s += strlen(s);
 686         return s;
 687     case 'a':
 688         minus_a = TRUE;
 689         s++;
 690         return s;
 691     case 'c':
 692         minus_c = TRUE;
 693         s++;
 694         return s;
 695     case 'd':
 696         taint_not("-d");
 697         perldb = TRUE;
 698         s++;
 699         return s;
 700     case 'D':
 701 #ifdef DEBUGGING
 702         taint_not("-D");
 703         if (isALPHA(s[1])) {
 704             static char debopts[] = "psltocPmfrxuLHXD";
 705             char *d;
 706
 707             for (s++; *s && (d = strchr(debopts,*s)); s++)
 708                 debug |= 1 << (d - debopts);
 709         }
 710         else {
 711             debug = atoi(s+1);
 712             for (s++; isDIGIT(*s); s++) ;
 713         }
 714         debug |= 0x80000000;
 715 #else
 716         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
 717         for (s++; isDIGIT(*s); s++) ;
 718 #endif
 719         /*SUPPRESS 530*/
 720         return s;
 721     case 'i':
 722         if (inplace)
 723             Safefree(inplace);
 724         inplace = savestr(s+1);
 725         /*SUPPRESS 530*/
 726         for (s = inplace; *s && !isSPACE(*s); s++) ;
 727         *s = '\0';
 728         break;
 729     case 'I':
 730         taint_not("-I");
 731         if (*++s) {
 732             (void)av_push(GvAVn(incgv),newSVpv(s,0));
 733         }
 734         else
 735             croak("No space allowed after -I");
 736         break;
 737     case 'l':
 738         minus_l = TRUE;
 739         s++;
 740         if (isDIGIT(*s)) {
 741             ors = savestr("\n");
 742             orslen = 1;
 743             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
 744             s += numlen;
 745         }
 746         else {
 747             ors = nsavestr(nrs,nrslen);
 748             orslen = nrslen;
 749         }
 750         return s;
 751     case 'n':
 752         minus_n = TRUE;
 753         s++;
 754         return s;
 755     case 'p':
 756         minus_p = TRUE;
 757         s++;
 758         return s;
 759     case 's':
 760         taint_not("-s");
 761         doswitches = TRUE;
 762         s++;
 763         return s;
 764     case 'T':
 765         tainting = TRUE;
 766         s++;
 767         return s;
 768     case 'u':
 769         do_undump = TRUE;
 770         s++;
 771         return s;
 772     case 'U':
 773         unsafe = TRUE;
 774         s++;
 775         return s;
 776     case 'v':
 777         fputs("\nThis is perl, version 5.0, Alpha 9 (unsupported)\n\n",stdout);
 778         fputs(rcsid,stdout);
 779         fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993, 1994 Larry Wall\n",stdout);
 780 #ifdef MSDOS
 781         fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
 782         stdout);
 783 #ifdef OS2
 784         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
 785         stdout);
 786 #endif
 787 #endif
 788 #ifdef atarist
 789         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
 790 #endif
 791         fputs("\n\
 792 Perl may be copied only under the terms of either the Artistic License or the\n\
 793 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
 794 #ifdef MSDOS
 795         usage(origargv[0]);
 796 #endif
 797         exit(0);
 798     case 'w':
 799         dowarn = TRUE;
 800         s++;
 801         return s;
 802     case ' ':
 803         if (s[1] == '-')        /* Additional switches on #! line. */
 804             return s+2;
 805         break;
 806     case 0:
 807     case '\n':
 808     case '\t':
 809         break;
 810     default:
 811         croak("Switch meaningless after -x: -%s",s);
 812     }
 813     return Nullch;
 814 }
 815
 816 /* compliments of Tom Christiansen */
 817
 818 /* unexec() can be found in the Gnu emacs distribution */
 819
 820 void
 821 my_unexec()
 822 {
 823 #ifdef UNEXEC
 824     int    status;
 825     extern int etext;
 826
 827     sprintf (buf, "%s.perldump", origfilename);
 828     sprintf (tokenbuf, "%s/perl", BIN);
 829
 830     status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
 831     if (status)
 832         fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
 833     my_exit(status);
 834 #else
 835     ABORT();            /* for use with undump */
 836 #endif
 837 }
 838
 839 static void
 840 init_main_stash()
 841 {
 842     GV *gv;
 843     curstash = defstash = newHV();
 844     curstname = newSVpv("main",4);
 845     GvHV(gv = gv_fetchpv("_main",TRUE, SVt_PVHV)) = (HV*)SvREFCNT_inc(defstash);
 846     SvREADONLY_on(gv);
 847     HvNAME(defstash) = savestr("main");
 848     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
 849     SvMULTI_on(incgv);
 850     defgv = gv_fetchpv("_",TRUE, SVt_PV);
 851     curstash = defstash;
 852     compiling.cop_stash = defstash;
 853 }
 854
 855 static void
 856 open_script(scriptname,dosearch,sv)
 857 char *scriptname;
 858 bool dosearch;
 859 SV *sv;
 860 {
 861     char *xfound = Nullch;
 862     char *xfailed = Nullch;
 863     register char *s;
 864     I32 len;
 865
 866     if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
 867
 868         bufend = s + strlen(s);
 869         while (*s) {
 870 #ifndef DOSISH
 871             s = cpytill(tokenbuf,s,bufend,':',&len);
 872 #else
 873 #ifdef atarist
 874             for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
 875             tokenbuf[len] = '\0';
 876 #else
 877             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
 878             tokenbuf[len] = '\0';
 879 #endif
 880 #endif
 881             if (*s)
 882                 s++;
 883 #ifndef DOSISH
 884             if (len && tokenbuf[len-1] != '/')
 885 #else
 886 #ifdef atarist
 887             if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
 888 #else
 889             if (len && tokenbuf[len-1] != '\\')
 890 #endif
 891 #endif
 892                 (void)strcat(tokenbuf+len,"/");
 893             (void)strcat(tokenbuf+len,scriptname);
 894             DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
 895             if (stat(tokenbuf,&statbuf) < 0)            /* not there? */
 896                 continue;
 897             if (S_ISREG(statbuf.st_mode)
 898              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
 899                 xfound = tokenbuf;              /* bingo! */
 900                 break;
 901             }
 902             if (!xfailed)
 903                 xfailed = savestr(tokenbuf);
 904         }
 905         if (!xfound)
 906             croak("Can't execute %s", xfailed ? xfailed : scriptname );
 907         if (xfailed)
 908             Safefree(xfailed);
 909         scriptname = xfound;
 910     }
 911
 912     origfilename = savestr(e_fp ? "-e" : scriptname);
 913     curcop->cop_filegv = gv_fetchfile(origfilename);
 914     if (strEQ(origfilename,"-"))
 915         scriptname = "";
 916     if (preprocess) {
 917         char *cpp = CPPSTDIN;
 918
 919         if (strEQ(cpp,"cppstdin"))
 920             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
 921         else
 922             sprintf(tokenbuf, "%s", cpp);
 923         sv_catpv(sv,"-I");
 924         sv_catpv(sv,PRIVLIB);
 925 #ifdef MSDOS
 926         (void)sprintf(buf, "\
 927 sed %s -e \"/^[^#]/b\" \
 928  -e \"/^#[      ]*include[      ]/b\" \
 929  -e \"/^#[      ]*define[       ]/b\" \
 930  -e \"/^#[      ]*if[   ]/b\" \
 931  -e \"/^#[      ]*ifdef[        ]/b\" \
 932  -e \"/^#[      ]*ifndef[       ]/b\" \
 933  -e \"/^#[      ]*else/b\" \
 934  -e \"/^#[      ]*elif[         ]/b\" \
 935  -e \"/^#[      ]*undef[        ]/b\" \
 936  -e \"/^#[      ]*endif/b\" \
 937  -e \"s/^#.*//\" \
 938  %s | %s -C %s %s",
 939           (doextract ? "-e \"1,/^#/d\n\"" : ""),
 940 #else
 941         (void)sprintf(buf, "\
 942 %s %s -e '/^[^#]/b' \
 943  -e '/^#[       ]*include[      ]/b' \
 944  -e '/^#[       ]*define[       ]/b' \
 945  -e '/^#[       ]*if[   ]/b' \
 946  -e '/^#[       ]*ifdef[        ]/b' \
 947  -e '/^#[       ]*ifndef[       ]/b' \
 948  -e '/^#[       ]*else/b' \
 949  -e '/^#[       ]*elif[         ]/b' \
 950  -e '/^#[       ]*undef[        ]/b' \
 951  -e '/^#[       ]*endif/b' \
 952  -e 's/^[       ]*#.*//' \
 953  %s | %s -C %s %s",
 954 #ifdef LOC_SED
 955           LOC_SED,
 956 #else
 957           "sed",
 958 #endif
 959           (doextract ? "-e '1,/^#/d\n'" : ""),
 960 #endif
 961           scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
 962         DEBUG_P(fprintf(stderr, "%s\n", buf));
 963         doextract = FALSE;
 964 #ifdef IAMSUID                          /* actually, this is caught earlier */
 965         if (euid != uid && !euid) {     /* if running suidperl */
 966 #ifdef HAS_SETEUID
 967             (void)seteuid(uid);         /* musn't stay setuid root */
 968 #else
 969 #ifdef HAS_SETREUID
 970             (void)setreuid((Uid_t)-1, uid);
 971 #else
 972 #ifdef HAS_SETRESUID
 973             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
 974 #else
 975             setuid(uid);
 976 #endif
 977 #endif
 978 #endif
 979             if (geteuid() != uid)
 980                 croak("Can't do seteuid!\n");
 981         }
 982 #endif /* IAMSUID */
 983         rsfp = my_popen(buf,"r");
 984     }
 985     else if (!*scriptname) {
 986         taint_not("program input from stdin");
 987         rsfp = stdin;
 988     }
 989     else
 990         rsfp = fopen(scriptname,"r");
 991     if ((FILE*)rsfp == Nullfp) {
 992 #ifdef DOSUID
 993 #ifndef IAMSUID         /* in case script is not readable before setuid */
 994         if (euid && stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
 995           statbuf.st_mode & (S_ISUID|S_ISGID)) {
 996             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
 997             execv(buf, origargv);       /* try again */
 998             croak("Can't do setuid\n");
 999         }
1000 #endif
1001 #endif
1002         croak("Can't open perl script \"%s\": %s\n",
1003           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1004     }
1005 }
1006
1007 static void
1008 validate_suid(validarg)
1009 char *validarg;
1010 {
1011     char *s;
1012     /* do we need to emulate setuid on scripts? */
1013
1014     /* This code is for those BSD systems that have setuid #! scripts disabled
1015      * in the kernel because of a security problem.  Merely defining DOSUID
1016      * in perl will not fix that problem, but if you have disabled setuid
1017      * scripts in the kernel, this will attempt to emulate setuid and setgid
1018      * on scripts that have those now-otherwise-useless bits set.  The setuid
1019      * root version must be called suidperl or sperlN.NNN.  If regular perl
1020      * discovers that it has opened a setuid script, it calls suidperl with
1021      * the same argv that it had.  If suidperl finds that the script it has
1022      * just opened is NOT setuid root, it sets the effective uid back to the
1023      * uid.  We don't just make perl setuid root because that loses the
1024      * effective uid we had before invoking perl, if it was different from the
1025      * uid.
1026      *
1027      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1028      * be defined in suidperl only.  suidperl must be setuid root.  The
1029      * Configure script will set this up for you if you want it.
1030      */
1031
1032 #ifdef DOSUID
1033     if (fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
1034         croak("Can't stat script \"%s\"",origfilename);
1035     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1036         I32 len;
1037
1038 #ifdef IAMSUID
1039 #ifndef HAS_SETREUID
1040         /* On this access check to make sure the directories are readable,
1041          * there is actually a small window that the user could use to make
1042          * filename point to an accessible directory.  So there is a faint
1043          * chance that someone could execute a setuid script down in a
1044          * non-accessible directory.  I don't know what to do about that.
1045          * But I don't think it's too important.  The manual lies when
1046          * it says access() is useful in setuid programs.
1047          */
1048         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1049             croak("Permission denied");
1050 #else
1051         /* If we can swap euid and uid, then we can determine access rights
1052          * with a simple stat of the file, and then compare device and
1053          * inode to make sure we did stat() on the same file we opened.
1054          * Then we just have to make sure he or she can execute it.
1055          */
1056         {
1057             struct stat tmpstatbuf;
1058
1059             if (
1060 #ifdef HAS_SETREUID
1061                 setreuid(euid,uid) < 0
1062 #elif HAS_SETRESUID
1063                 setresuid(euid,uid,(Uid_t)-1) < 0
1064 #endif
1065                 || getuid() != euid || geteuid() != uid)
1066                 croak("Can't swap uid and euid");       /* really paranoid */
1067             if (stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1068                 croak("Permission denied");     /* testing full pathname here */
1069             if (tmpstatbuf.st_dev != statbuf.st_dev ||
1070                 tmpstatbuf.st_ino != statbuf.st_ino) {
1071                 (void)fclose(rsfp);
1072                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
1073                     fprintf(rsfp,
1074 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1075 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1076                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1077                         statbuf.st_dev, statbuf.st_ino,
1078                         SvPVX(GvSV(curcop->cop_filegv)),
1079                         statbuf.st_uid, statbuf.st_gid);
1080                     (void)my_pclose(rsfp);
1081                 }
1082                 croak("Permission denied\n");
1083             }
1084             if (
1085 #ifdef HAS_SETREUID
1086               setreuid(uid,euid) < 0
1087 #elif defined(HAS_SETRESUID)
1088               setresuid(uid,euid,(Uid_t)-1) < 0
1089 #endif
1090               || getuid() != uid || geteuid() != euid)
1091                 croak("Can't reswap uid and euid");
1092             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
1093                 croak("Permission denied\n");
1094         }
1095 #endif /* HAS_SETREUID */
1096 #endif /* IAMSUID */
1097
1098         if (!S_ISREG(statbuf.st_mode))
1099             croak("Permission denied");
1100         if (statbuf.st_mode & S_IWOTH)
1101             croak("Setuid/gid script is writable by world");
1102         doswitches = FALSE;             /* -s is insecure in suid */
1103         curcop->cop_line++;
1104         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1105           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
1106             croak("No #! line");
1107         s = tokenbuf+2;
1108         if (*s == ' ') s++;
1109         while (!isSPACE(*s)) s++;
1110         if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1111             croak("Not a perl script");
1112         while (*s == ' ' || *s == '\t') s++;
1113         /*
1114          * #! arg must be what we saw above.  They can invoke it by
1115          * mentioning suidperl explicitly, but they may not add any strange
1116          * arguments beyond what #! says if they do invoke suidperl that way.
1117          */
1118         len = strlen(validarg);
1119         if (strEQ(validarg," PHOOEY ") ||
1120             strnNE(s,validarg,len) || !isSPACE(s[len]))
1121             croak("Args must match #! line");
1122
1123 #ifndef IAMSUID
1124         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1125             euid == statbuf.st_uid)
1126             if (!do_undump)
1127                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1128 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1129 #endif /* IAMSUID */
1130
1131         if (euid) {     /* oops, we're not the setuid root perl */
1132             (void)fclose(rsfp);
1133 #ifndef IAMSUID
1134             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1135             execv(buf, origargv);       /* try again */
1136 #endif
1137             croak("Can't do setuid\n");
1138         }
1139
1140         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1141 #ifdef HAS_SETEGID
1142             (void)setegid(statbuf.st_gid);
1143 #else
1144 #ifdef HAS_SETREGID
1145            (void)setregid((Gid_t)-1,statbuf.st_gid);
1146 #else
1147 #ifdef HAS_SETRESGID
1148            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1149 #else
1150             setgid(statbuf.st_gid);
1151 #endif
1152 #endif
1153 #endif
1154             if (getegid() != statbuf.st_gid)
1155                 croak("Can't do setegid!\n");
1156         }
1157         if (statbuf.st_mode & S_ISUID) {
1158             if (statbuf.st_uid != euid)
1159 #ifdef HAS_SETEUID
1160                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1161 #else
1162 #ifdef HAS_SETREUID
1163                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1164 #else
1165 #ifdef HAS_SETRESUID
1166                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1167 #else
1168                 setuid(statbuf.st_uid);
1169 #endif
1170 #endif
1171 #endif
1172             if (geteuid() != statbuf.st_uid)
1173                 croak("Can't do seteuid!\n");
1174         }
1175         else if (uid) {                 /* oops, mustn't run as root */
1176 #ifdef HAS_SETEUID
1177           (void)seteuid((Uid_t)uid);
1178 #else
1179 #ifdef HAS_SETREUID
1180           (void)setreuid((Uid_t)-1,(Uid_t)uid);
1181 #else
1182 #ifdef HAS_SETRESUID
1183           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1184 #else
1185           setuid((Uid_t)uid);
1186 #endif
1187 #endif
1188 #endif
1189             if (geteuid() != uid)
1190                 croak("Can't do seteuid!\n");
1191         }
1192         uid = (int)getuid();
1193         euid = (int)geteuid();
1194         gid = (int)getgid();
1195         egid = (int)getegid();
1196         tainting |= (euid != uid || egid != gid);
1197         if (!cando(S_IXUSR,TRUE,&statbuf))
1198             croak("Permission denied\n");       /* they can't do this */
1199     }
1200 #ifdef IAMSUID
1201     else if (preprocess)
1202         croak("-P not allowed for setuid/setgid script\n");
1203     else
1204         croak("Script is not setuid/setgid in suidperl\n");
1205 #endif /* IAMSUID */
1206 #else /* !DOSUID */
1207     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1208 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1209         fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
1210         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1211             ||
1212             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1213            )
1214             if (!do_undump)
1215                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1216 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1217 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1218         /* not set-id, must be wrapped */
1219     }
1220 #endif /* DOSUID */
1221 }
1222
1223 static void
1224 find_beginning()
1225 {
1226     register char *s;
1227
1228     /* skip forward in input to the real script? */
1229
1230     taint_not("-x");
1231     while (doextract) {
1232         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1233             croak("No Perl script found in input\n");
1234         if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1235             ungetc('\n',rsfp);          /* to keep line count right */
1236             doextract = FALSE;
1237             if (s = instr(s,"perl -")) {
1238                 s += 6;
1239                 /*SUPPRESS 530*/
1240                 while (s = moreswitches(s)) ;
1241             }
1242             if (cddir && chdir(cddir) < 0)
1243                 croak("Can't chdir to %s",cddir);
1244         }
1245     }
1246 }
1247
1248 static void
1249 init_debugger()
1250 {
1251     GV* tmpgv;
1252
1253     debstash = newHV();
1254     GvHV(gv_fetchpv("::_DB",TRUE, SVt_PVHV)) = debstash;
1255     curstash = debstash;
1256     dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE, SVt_PVAV))));
1257     SvMULTI_on(tmpgv);
1258     AvREAL_off(dbargs);
1259     DBgv = gv_fetchpv("DB",TRUE, SVt_PVGV);
1260     SvMULTI_on(DBgv);
1261     DBline = gv_fetchpv("dbline",TRUE, SVt_PVAV);
1262     SvMULTI_on(DBline);
1263     DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE, SVt_PVHV));
1264     SvMULTI_on(tmpgv);
1265     DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE, SVt_PV)));
1266     SvMULTI_on(tmpgv);
1267     DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE, SVt_PV)));
1268     SvMULTI_on(tmpgv);
1269     DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE, SVt_PV)));
1270     SvMULTI_on(tmpgv);
1271     curstash = defstash;
1272 }
1273
1274 static void
1275 init_stacks()
1276 {
1277     stack = newAV();
1278     mainstack = stack;                  /* remember in case we switch stacks */
1279     AvREAL_off(stack);                  /* not a real array */
1280     av_fill(stack,127); av_fill(stack,-1);      /* preextend stack */
1281
1282     stack_base = AvARRAY(stack);
1283     stack_sp = stack_base;
1284     stack_max = stack_base + 127;
1285
1286     New(54,markstack,64,int);
1287     markstack_ptr = markstack;
1288     markstack_max = markstack + 64;
1289
1290     New(54,scopestack,32,int);
1291     scopestack_ix = 0;
1292     scopestack_max = 32;
1293
1294     New(54,savestack,128,ANY);
1295     savestack_ix = 0;
1296     savestack_max = 128;
1297
1298     New(54,retstack,16,OP*);
1299     retstack_ix = 0;
1300     retstack_max = 16;
1301
1302     New(50,cxstack,128,CONTEXT);
1303     cxstack_ix  = -1;
1304     cxstack_max = 128;
1305
1306     New(50,tmps_stack,128,SV*);
1307     tmps_ix = -1;
1308     tmps_max = 128;
1309
1310     DEBUG( {
1311         New(51,debname,128,char);
1312         New(52,debdelim,128,char);
1313     } )
1314 }
1315
1316 static void
1317 init_lexer()
1318 {
1319     FILE* tmpfp = rsfp;
1320
1321     lex_start(linestr);
1322     rsfp = tmpfp;
1323     subname = newSVpv("main",4);
1324 }
1325
1326 static void
1327 init_predump_symbols()
1328 {
1329     GV *tmpgv;
1330
1331     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1332
1333     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1334     SvMULTI_on(stdingv);
1335     if (!GvIO(stdingv))
1336         GvIO(stdingv) = newIO();
1337     IoIFP(GvIO(stdingv)) = stdin;
1338     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PVIO);
1339     GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(stdingv));
1340     SvMULTI_on(tmpgv);
1341
1342     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1343     SvMULTI_on(tmpgv);
1344     if (!GvIO(tmpgv))
1345         GvIO(tmpgv) = newIO();
1346     IoOFP(GvIO(tmpgv)) = IoIFP(GvIO(tmpgv)) = stdout;
1347     defoutgv = tmpgv;
1348     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PVIO);
1349     GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(defoutgv));
1350     SvMULTI_on(tmpgv);
1351
1352     curoutgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1353     SvMULTI_on(curoutgv);
1354     if (!GvIO(curoutgv))
1355         GvIO(curoutgv) = newIO();
1356     IoOFP(GvIO(curoutgv)) = IoIFP(GvIO(curoutgv)) = stderr;
1357     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PVIO);
1358     GvIO(tmpgv) = (IO*)SvREFCNT_inc(GvIO(curoutgv));
1359     SvMULTI_on(tmpgv);
1360     curoutgv = defoutgv;                /* switch back to STDOUT */
1361
1362     statname = NEWSV(66,0);             /* last filename we did stat on */
1363 }
1364
1365 static void
1366 init_postdump_symbols(argc,argv,env)
1367 register int argc;
1368 register char **argv;
1369 register char **env;
1370 {
1371     char *s;
1372     SV *sv;
1373     GV* tmpgv;
1374
1375     argc--,argv++;      /* skip name of script */
1376     if (doswitches) {
1377         for (; argc > 0 && **argv == '-'; argc--,argv++) {
1378             if (!argv[0][1])
1379                 break;
1380             if (argv[0][1] == '-') {
1381                 argc--,argv++;
1382                 break;
1383             }
1384             if (s = strchr(argv[0], '=')) {
1385                 *s++ = '\0';
1386                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1387             }
1388             else
1389                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1390         }
1391     }
1392     toptarget = NEWSV(0,0);
1393     sv_upgrade(toptarget, SVt_PVFM);
1394     sv_setpvn(toptarget, "", 0);
1395     tmpgv = gv_fetchpv("\001",TRUE, SVt_PV);
1396     bodytarget = GvSV(tmpgv);
1397     sv_upgrade(bodytarget, SVt_PVFM);
1398     sv_setpvn(bodytarget, "", 0);
1399     formtarget = bodytarget;
1400
1401     tainted = 1;
1402     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1403         sv_setpv(GvSV(tmpgv),origfilename);
1404         magicname("0", "0", 1);
1405     }
1406     if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1407         time(&basetime);
1408     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1409         sv_setpv(GvSV(tmpgv),origargv[0]);
1410     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1411         SvMULTI_on(argvgv);
1412         (void)gv_AVadd(argvgv);
1413         av_clear(GvAVn(argvgv));
1414         for (; argc > 0; argc--,argv++) {
1415             (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1416         }
1417     }
1418     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1419         HV *hv;
1420         SvMULTI_on(envgv);
1421         hv = GvHVn(envgv);
1422         hv_clear(hv);
1423         if (env != environ) {
1424             environ[0] = Nullch;
1425             hv_magic(hv, envgv, 'E');
1426         }
1427         for (; *env; env++) {
1428             if (!(s = strchr(*env,'=')))
1429                 continue;
1430             *s++ = '\0';
1431             sv = newSVpv(s--,0);
1432             sv_magic(sv, sv, 'e', *env, s - *env);
1433             (void)hv_store(hv, *env, s - *env, sv, 0);
1434             *s = '=';
1435         }
1436         hv_magic(hv, envgv, 'E');
1437     }
1438     tainted = 0;
1439     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1440         sv_setiv(GvSV(tmpgv),(I32)getpid());
1441
1442 }
1443
1444 static void
1445 init_perllib()
1446 {
1447     char *s;
1448     if (!tainting) {
1449         s = getenv("PERL5LIB");
1450         if (s)
1451             incpush(s);
1452         else
1453             incpush(getenv("PERLLIB"));
1454     }
1455
1456 #ifndef PRIVLIB
1457 #define PRIVLIB "/usr/local/lib/perl5:/usr/local/lib/perl"
1458 #endif
1459     incpush(PRIVLIB);
1460     (void)av_push(GvAVn(incgv),newSVpv(".",1));
1461 }
1462
1463 void
1464 calllist(list)
1465 AV* list;
1466 {
1467     jmp_buf oldtop;
1468     I32 sp = stack_sp - stack_base;
1469
1470     av_store(stack, ++sp, Nullsv);      /* reserve spot for sub reference */
1471     Copy(top_env, oldtop, 1, jmp_buf);
1472
1473     while (AvFILL(list) >= 0) {
1474         CV *cv = (CV*)av_shift(list);
1475
1476         SAVEFREESV(cv);
1477         switch (setjmp(top_env)) {
1478         case 0:
1479             perl_callsv((SV*)cv, sp, G_SCALAR, 0, 0);
1480             break;
1481         case 1:
1482             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
1483             /* FALL THROUGH */
1484         case 2:
1485             /* my_exit() was called */
1486             curstash = defstash;
1487             if (endav)
1488                 calllist(endav);
1489             FREE_TMPS();
1490             if (statusvalue) {
1491                 if (list == beginav)
1492                     warn("BEGIN failed--execution aborted");
1493                 else
1494                     warn("END failed--execution aborted");
1495             }
1496             Copy(oldtop, top_env, 1, jmp_buf);
1497             my_exit(statusvalue);
1498             /* NOTREACHED */
1499             return;
1500         case 3:
1501             if (!restartop) {
1502                 fprintf(stderr, "panic: restartop\n");
1503                 FREE_TMPS();
1504                 break;
1505             }
1506             if (stack != mainstack) {
1507                 dSP;
1508                 SWITCHSTACK(stack, mainstack);
1509             }
1510             op = restartop;
1511             restartop = 0;
1512             run();
1513             break;
1514         }
1515     }
1516
1517     Copy(oldtop, top_env, 1, jmp_buf);
1518 }
1519