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