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