perl.c

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