perl.c

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