perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (c) 1987-1996 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  */
   9
  10 /*
  11  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
  12  */
  13
  14 #include "EXTERN.h"
  15 #include "perl.h"
  16 #include "patchlevel.h"
  17
  18 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  19 #ifdef I_UNISTD
  20 #include <unistd.h>
  21 #endif
  22
  23 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
  24
  25 #ifdef IAMSUID
  26 #ifndef DOSUID
  27 #define DOSUID
  28 #endif
  29 #endif
  30
  31 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  32 #ifdef DOSUID
  33 #undef DOSUID
  34 #endif
  35 #endif
  36
  37 static void find_beginning _((void));
  38 static void forbid_setid _((char *));
  39 static void incpush _((char *));
  40 static void init_ids _((void));
  41 static void init_debugger _((void));
  42 static void init_lexer _((void));
  43 static void init_main_stash _((void));
  44 static void init_perllib _((void));
  45 static void init_postdump_symbols _((int, char **, char **));
  46 static void init_predump_symbols _((void));
  47 static void init_stacks _((void));
  48 static void nuke_stacks _((void));
  49 static void open_script _((char *, bool, SV *));
  50 static void usage _((char *));
  51 static void validate_suid _((char *, char*));
  52
  53 static int fdscript = -1;
  54
  55 PerlInterpreter *
  56 perl_alloc()
  57 {
  58     PerlInterpreter *sv_interp;
  59
  60     curinterp = 0;
  61     New(53, sv_interp, 1, PerlInterpreter);
  62     return sv_interp;
  63 }
  64
  65 void
  66 perl_construct( sv_interp )
  67 register PerlInterpreter *sv_interp;
  68 {
  69     if (!(curinterp = sv_interp))
  70         return;
  71
  72 #ifdef MULTIPLICITY
  73     Zero(sv_interp, 1, PerlInterpreter);
  74 #endif
  75
  76     /* Init the real globals? */
  77     if (!linestr) {
  78         linestr = NEWSV(65,80);
  79         sv_upgrade(linestr,SVt_PVIV);
  80
  81         if (!SvREADONLY(&sv_undef)) {
  82             SvREADONLY_on(&sv_undef);
  83
  84             sv_setpv(&sv_no,No);
  85             SvNV(&sv_no);
  86             SvREADONLY_on(&sv_no);
  87
  88             sv_setpv(&sv_yes,Yes);
  89             SvNV(&sv_yes);
  90             SvREADONLY_on(&sv_yes);
  91         }
  92
  93         nrs = newSVpv("\n", 1);
  94         rs = SvREFCNT_inc(nrs);
  95
  96 #ifdef MSDOS
  97         /*
  98          * There is no way we can refer to them from Perl so close them to save
  99          * space.  The other alternative would be to provide STDAUX and STDPRN
 100          * filehandles.
 101          */
 102         (void)fclose(stdaux);
 103         (void)fclose(stdprn);
 104 #endif
 105     }
 106
 107 #ifdef MULTIPLICITY
 108     chopset     = " \n-";
 109     copline     = NOLINE;
 110     curcop      = &compiling;
 111     dbargs      = 0;
 112     dlmax       = 128;
 113     laststatval = -1;
 114     laststype   = OP_STAT;
 115     maxscream   = -1;
 116     maxsysfd    = MAXSYSFD;
 117     rsfp        = Nullfp;
 118     statname    = Nullsv;
 119     tmps_floor  = -1;
 120     perl_destruct_level = 1;
 121 #endif
 122
 123     init_ids();
 124
 125     SET_NUMERIC_STANDARD();
 126 #if defined(SUBVERSION) && SUBVERSION > 0
 127     sprintf(patchlevel, "%7.5f",   (double) 5
 128                                 + ((double) PATCHLEVEL / (double) 1000)
 129                                 + ((double) SUBVERSION / (double) 100000));
 130 #else
 131     sprintf(patchlevel, "%5.3f", (double) 5 +
 132                                 ((double) PATCHLEVEL / (double) 1000));
 133 #endif
 134
 135 #if defined(LOCAL_PATCH_COUNT)
 136     localpatches = local_patches;       /* For possible -v */
 137 #endif
 138
 139     PerlIO_init();      /* Hook to IO system */
 140
 141     fdpid = newAV();    /* for remembering popen pids by fd */
 142     pidstatus = newHV();/* for remembering status of dead pids */
 143
 144     init_stacks();
 145     ENTER;
 146 }
 147
 148 void
 149 perl_destruct(sv_interp)
 150 register PerlInterpreter *sv_interp;
 151 {
 152     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 153     I32 last_sv_count;
 154     HV *hv;
 155
 156     if (!(curinterp = sv_interp))
 157         return;
 158
 159     destruct_level = perl_destruct_level;
 160 #ifdef DEBUGGING
 161     {
 162         char *s;
 163         if (s = getenv("PERL_DESTRUCT_LEVEL")) {
 164             int i = atoi(s);
 165             if (destruct_level < i)
 166                 destruct_level = i;
 167         }
 168     }
 169 #endif
 170
 171     /* unhook hooks which will soon be, or use, destroyed data */
 172     SvREFCNT_dec(warnhook);
 173     warnhook = Nullsv;
 174     SvREFCNT_dec(diehook);
 175     diehook = Nullsv;
 176     SvREFCNT_dec(parsehook);
 177     parsehook = Nullsv;
 178
 179     LEAVE;
 180     FREETMPS;
 181
 182     /* We must account for everything.  First the syntax tree. */
 183     if (main_root) {
 184         curpad = AvARRAY(comppad);
 185         op_free(main_root);
 186         main_root = 0;
 187     }
 188     if (sv_objcount) {
 189         /*
 190          * Try to destruct global references.  We do this first so that the
 191          * destructors and destructees still exist.  Some sv's might remain.
 192          * Non-referenced objects are on their own.
 193          */
 194
 195         dirty = TRUE;
 196         sv_clean_objs();
 197     }
 198
 199     if (destruct_level == 0){
 200
 201         DEBUG_P(debprofdump());
 202
 203         /* The exit() function will do everything that needs doing. */
 204         return;
 205     }
 206
 207     /* loosen bonds of global variables */
 208
 209     setdefout(Nullgv);
 210
 211     sv_free(nrs);
 212     nrs = Nullsv;
 213
 214     sv_free(lastscream);
 215     lastscream = Nullsv;
 216
 217     sv_free(statname);
 218     statname = Nullsv;
 219     statgv = Nullgv;
 220     laststatval = -1;
 221
 222     sv_free((SV*)beginav);
 223     beginav = Nullav;
 224     sv_free((SV*)endav);
 225     endav = Nullav;
 226
 227     /* Prepare to destruct main symbol table.  */
 228
 229     hv = defstash;
 230     defstash = 0;
 231     SvREFCNT_dec(hv);
 232
 233     FREETMPS;
 234     if (destruct_level >= 2) {
 235         if (scopestack_ix != 0)
 236             warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
 237         if (savestack_ix != 0)
 238             warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
 239         if (tmps_floor != -1)
 240             warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
 241         if (cxstack_ix != -1)
 242             warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
 243     }
 244
 245     /* Now absolutely destruct everything, somehow or other, loops or no. */
 246     last_sv_count = 0;
 247     SvFLAGS(strtab) |= SVTYPEMASK;              /* don't clean out strtab now */
 248     while (sv_count != 0 && sv_count != last_sv_count) {
 249         last_sv_count = sv_count;
 250         sv_clean_all();
 251     }
 252     SvFLAGS(strtab) &= ~SVTYPEMASK;
 253     SvFLAGS(strtab) |= SVt_PVHV;
 254
 255     /* Destruct the global string table. */
 256     {
 257         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 258          * so that sv_free() won't fail on them.
 259          */
 260         I32 riter;
 261         I32 max;
 262         HE *hent;
 263         HE **array;
 264
 265         riter = 0;
 266         max = HvMAX(strtab);
 267         array = HvARRAY(strtab);
 268         hent = array[0];
 269         for (;;) {
 270             if (hent) {
 271                 warn("Unbalanced string table refcount: (%d) for \"%s\"",
 272                      HeVAL(hent) - Nullsv, HeKEY(hent));
 273                 HeVAL(hent) = Nullsv;
 274                 hent = HeNEXT(hent);
 275             }
 276             if (!hent) {
 277                 if (++riter > max)
 278                     break;
 279                 hent = array[riter];
 280             }
 281         }
 282     }
 283     SvREFCNT_dec(strtab);
 284
 285     if (sv_count != 0)
 286         warn("Scalars leaked: %d\n", sv_count);
 287
 288     sv_free_arenas();
 289
 290     linestr = NULL;             /* No SVs have survived, need to clean out */
 291     if (origfilename)
 292         Safefree(origfilename);
 293     nuke_stacks();
 294     hints = 0;                  /* Reset hints. Should hints be per-interpreter ? */
 295
 296     DEBUG_P(debprofdump());
 297 }
 298
 299 void
 300 perl_free(sv_interp)
 301 PerlInterpreter *sv_interp;
 302 {
 303     if (!(curinterp = sv_interp))
 304         return;
 305     Safefree(sv_interp);
 306 }
 307 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
 308 char *getenv _((char *)); /* Usually in <stdlib.h> */
 309 #endif
 310
 311 int
 312 perl_parse(sv_interp, xsinit, argc, argv, env)
 313 PerlInterpreter *sv_interp;
 314 void (*xsinit)_((void));
 315 int argc;
 316 char **argv;
 317 char **env;
 318 {
 319     register SV *sv;
 320     register char *s;
 321     char *scriptname = NULL;
 322     VOL bool dosearch = FALSE;
 323     char *validarg = "";
 324     AV* comppadlist;
 325
 326 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 327 #ifdef IAMSUID
 328 #undef IAMSUID
 329     croak("suidperl is no longer needed since the kernel can now execute\n\
 330 setuid perl scripts securely.\n");
 331 #endif
 332 #endif
 333
 334     if (!(curinterp = sv_interp))
 335         return 255;
 336
 337 #if defined(NeXT) && defined(__DYNAMIC__)
 338     _dyld_lookup_and_bind
 339         ("__environ", (unsigned long *) &environ_pointer, NULL);
 340 #endif /* environ */
 341
 342     origargv = argv;
 343     origargc = argc;
 344 #ifndef VMS  /* VMS doesn't have environ array */
 345     origenviron = environ;
 346 #endif
 347     e_tmpname = Nullch;
 348
 349     if (do_undump) {
 350
 351         /* Come here if running an undumped a.out. */
 352
 353         origfilename = savepv(argv[0]);
 354         do_undump = FALSE;
 355         cxstack_ix = -1;                /* start label stack again */
 356         init_ids();
 357         init_postdump_symbols(argc,argv,env);
 358         return 0;
 359     }
 360
 361     if (main_root)
 362         op_free(main_root);
 363     main_root = 0;
 364
 365     switch (Sigsetjmp(top_env,1)) {
 366     case 1:
 367 #ifdef VMS
 368         statusvalue = 255;
 369 #else
 370         statusvalue = 1;
 371 #endif
 372     case 2:
 373         curstash = defstash;
 374         if (endav)
 375             calllist(endav);
 376         return(statusvalue);    /* my_exit() was called */
 377     case 3:
 378         PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
 379         return 1;
 380     }
 381
 382     sv_setpvn(linestr,"",0);
 383     sv = newSVpv("",0);         /* first used for -I flags */
 384     SAVEFREESV(sv);
 385     init_main_stash();
 386     for (argc--,argv++; argc > 0; argc--,argv++) {
 387         if (argv[0][0] != '-' || !argv[0][1])
 388             break;
 389 #ifdef DOSUID
 390     if (*validarg)
 391         validarg = " PHOOEY ";
 392     else
 393         validarg = argv[0];
 394 #endif
 395         s = argv[0]+1;
 396       reswitch:
 397         switch (*s) {
 398         case '0':
 399         case 'F':
 400         case 'a':
 401         case 'c':
 402         case 'd':
 403         case 'D':
 404         case 'h':
 405         case 'i':
 406         case 'l':
 407         case 'M':
 408         case 'm':
 409         case 'n':
 410         case 'p':
 411         case 's':
 412         case 'T':
 413         case 'u':
 414         case 'U':
 415         case 'v':
 416         case 'w':
 417             if (s = moreswitches(s))
 418                 goto reswitch;
 419             break;
 420
 421         case 'e':
 422             if (euid != uid || egid != gid)
 423                 croak("No -e allowed in setuid scripts");
 424             if (!e_fp) {
 425                 e_tmpname = savepv(TMPPATH);
 426                 (void)mktemp(e_tmpname);
 427                 if (!*e_tmpname)
 428                     croak("Can't mktemp()");
 429                 e_fp = PerlIO_open(e_tmpname,"w");
 430                 if (!e_fp)
 431                     croak("Cannot open temporary file");
 432             }
 433             if (*++s)
 434                 PerlIO_puts(e_fp,s);
 435             else if (argv[1]) {
 436                 PerlIO_puts(e_fp,argv[1]);
 437                 argc--,argv++;
 438             }
 439             else
 440                 croak("No code specified for -e");
 441             (void)PerlIO_putc(e_fp,'\n');
 442             break;
 443         case 'I':
 444             forbid_setid("-I");
 445             sv_catpv(sv,"-");
 446             sv_catpv(sv,s);
 447             sv_catpv(sv," ");
 448             if (*++s) {
 449                 av_push(GvAVn(incgv),newSVpv(s,0));
 450             }
 451             else if (argv[1]) {
 452                 av_push(GvAVn(incgv),newSVpv(argv[1],0));
 453                 sv_catpv(sv,argv[1]);
 454                 argc--,argv++;
 455                 sv_catpv(sv," ");
 456             }
 457             break;
 458         case 'P':
 459             forbid_setid("-P");
 460             preprocess = TRUE;
 461             s++;
 462             goto reswitch;
 463         case 'S':
 464             forbid_setid("-S");
 465             dosearch = TRUE;
 466             s++;
 467             goto reswitch;
 468         case 'V':
 469             if (!preambleav)
 470                 preambleav = newAV();
 471             av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
 472             if (*++s != ':')  {
 473                 Sv = newSVpv("print myconfig();",0);
 474 #ifdef VMS
 475                 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
 476 #else
 477                 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 478 #endif
 479 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
 480                 strcpy(buf,"\"  Compile-time options:");
 481 #  ifdef DEBUGGING
 482                 strcat(buf," DEBUGGING");
 483 #  endif
 484 #  ifdef NOEMBED
 485                 strcat(buf," NOEMBED");
 486 #  endif
 487 #  ifdef MULTIPLICITY
 488                 strcat(buf," MULTIPLICITY");
 489 #  endif
 490                 strcat(buf,"\\n\",");
 491                 sv_catpv(Sv,buf);
 492 #endif
 493 #if defined(LOCAL_PATCH_COUNT)
 494                 if (LOCAL_PATCH_COUNT > 0)
 495                 {   int i;
 496                     sv_catpv(Sv,"print \"  Locally applied patches:\\n\",");
 497                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
 498                         if (localpatches[i]) {
 499                             sprintf(buf,"\"  \\t%s\\n\",",localpatches[i]);
 500                             sv_catpv(Sv,buf);
 501                         }
 502                     }
 503                 }
 504 #endif
 505                 sprintf(buf,"\"  Built under %s\\n\",",OSNAME);
 506                 sv_catpv(Sv,buf);
 507 #ifdef __DATE__
 508 #  ifdef __TIME__
 509                 sprintf(buf,"\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 510 #  else
 511                 sprintf(buf,"\"  Compiled on %s\\n\"",__DATE__);
 512 #  endif
 513                 sv_catpv(Sv,buf);
 514 #endif
 515                 sv_catpv(Sv,"; $\"=\"\\n    \"; print \"  \\@INC:\\n    @INC\\n\"");
 516             }
 517             else {
 518                 Sv = newSVpv("config_vars(qw(",0);
 519                 sv_catpv(Sv, ++s);
 520                 sv_catpv(Sv, "))");
 521                 s += strlen(s);
 522             }
 523             av_push(preambleav, Sv);
 524             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
 525             goto reswitch;
 526         case 'x':
 527             doextract = TRUE;
 528             s++;
 529             if (*s)
 530                 cddir = savepv(s);
 531             break;
 532         case '-':
 533             argc--,argv++;
 534             goto switch_end;
 535         case 0:
 536             break;
 537         default:
 538             croak("Unrecognized switch: -%s",s);
 539         }
 540     }
 541   switch_end:
 542     if (!scriptname)
 543         scriptname = argv[0];
 544     if (e_fp) {
 545         if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
 546             croak("Can't write to temp file for -e: %s", Strerror(errno));
 547         e_fp = Nullfp;
 548         argc++,argv--;
 549         scriptname = e_tmpname;
 550     }
 551     else if (scriptname == Nullch) {
 552 #ifdef MSDOS
 553         if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
 554             moreswitches("h");
 555 #endif
 556         scriptname = "-";
 557     }
 558
 559     init_perllib();
 560
 561     open_script(scriptname,dosearch,sv);
 562
 563     validate_suid(validarg, scriptname);
 564
 565     if (doextract)
 566         find_beginning();
 567
 568     compcv = (CV*)NEWSV(1104,0);
 569     sv_upgrade((SV *)compcv, SVt_PVCV);
 570     CvUNIQUE_on(compcv);
 571
 572     comppad = newAV();
 573     av_push(comppad, Nullsv);
 574     curpad = AvARRAY(comppad);
 575     comppad_name = newAV();
 576     comppad_name_fill = 0;
 577     min_intro_pending = 0;
 578     padix = 0;
 579
 580     comppadlist = newAV();
 581     AvREAL_off(comppadlist);
 582     av_store(comppadlist, 0, (SV*)comppad_name);
 583     av_store(comppadlist, 1, (SV*)comppad);
 584     CvPADLIST(compcv) = comppadlist;
 585
 586     boot_core_UNIVERSAL();
 587     if (xsinit)
 588         (*xsinit)();    /* in case linked C routines want magical variables */
 589 #ifdef VMS
 590     init_os_extras();
 591 #endif
 592
 593     init_predump_symbols();
 594     if (!do_undump)
 595         init_postdump_symbols(argc,argv,env);
 596
 597     init_lexer();
 598
 599     /* now parse the script */
 600
 601     error_count = 0;
 602     if (yyparse() || error_count) {
 603         if (minus_c)
 604             croak("%s had compilation errors.\n", origfilename);
 605         else {
 606             croak("Execution of %s aborted due to compilation errors.\n",
 607                 origfilename);
 608         }
 609     }
 610     curcop->cop_line = 0;
 611     curstash = defstash;
 612     preprocess = FALSE;
 613     if (e_tmpname) {
 614         (void)UNLINK(e_tmpname);
 615         Safefree(e_tmpname);
 616         e_tmpname = Nullch;
 617     }
 618
 619     /* now that script is parsed, we can modify record separator */
 620     SvREFCNT_dec(rs);
 621     rs = SvREFCNT_inc(nrs);
 622     sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
 623
 624     if (do_undump)
 625         my_unexec();
 626
 627     if (dowarn)
 628         gv_check(defstash);
 629
 630     LEAVE;
 631     FREETMPS;
 632
 633 #ifdef DEBUGGING_MSTATS
 634     if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
 635         dump_mstats("after compilation:");
 636 #endif
 637
 638     ENTER;
 639     restartop = 0;
 640     return 0;
 641 }
 642
 643 int
 644 perl_run(sv_interp)
 645 PerlInterpreter *sv_interp;
 646 {
 647     if (!(curinterp = sv_interp))
 648         return 255;
 649     switch (Sigsetjmp(top_env,1)) {
 650     case 1:
 651         cxstack_ix = -1;                /* start context stack again */
 652         break;
 653     case 2:
 654         curstash = defstash;
 655         if (endav)
 656             calllist(endav);
 657         FREETMPS;
 658 #ifdef DEBUGGING_MSTATS
 659         if (getenv("PERL_DEBUG_MSTATS"))
 660             dump_mstats("after execution:  ");
 661 #endif
 662         return(statusvalue);            /* my_exit() was called */
 663     case 3:
 664         if (!restartop) {
 665             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
 666             FREETMPS;
 667             return 1;
 668         }
 669         if (curstack != mainstack) {
 670             dSP;
 671             SWITCHSTACK(curstack, mainstack);
 672         }
 673         break;
 674     }
 675
 676     DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
 677                     sawampersand ? "Enabling" : "Omitting"));
 678
 679     if (!restartop) {
 680         DEBUG_x(dump_all());
 681         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
 682
 683         if (minus_c) {
 684             PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
 685             my_exit(0);
 686         }
 687         if (perldb && DBsingle)
 688            sv_setiv(DBsingle, 1);
 689     }
 690
 691     /* do it */
 692
 693     if (restartop) {
 694         op = restartop;
 695         restartop = 0;
 696         runops();
 697     }
 698     else if (main_start) {
 699         op = main_start;
 700         runops();
 701     }
 702
 703     my_exit(0);
 704     return 0;
 705 }
 706
 707 void
 708 my_exit(status)
 709 U32 status;
 710 {
 711     register CONTEXT *cx;
 712     I32 gimme;
 713     SV **newsp;
 714
 715     statusvalue = FIXSTATUS(status);
 716     if (cxstack_ix >= 0) {
 717         if (cxstack_ix > 0)
 718             dounwind(0);
 719         POPBLOCK(cx,curpm);
 720         LEAVE;
 721     }
 722     Siglongjmp(top_env, 2);
 723 }
 724
 725 SV*
 726 perl_get_sv(name, create)
 727 char* name;
 728 I32 create;
 729 {
 730     GV* gv = gv_fetchpv(name, create, SVt_PV);
 731     if (gv)
 732         return GvSV(gv);
 733     return Nullsv;
 734 }
 735
 736 AV*
 737 perl_get_av(name, create)
 738 char* name;
 739 I32 create;
 740 {
 741     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
 742     if (create)
 743         return GvAVn(gv);
 744     if (gv)
 745         return GvAV(gv);
 746     return Nullav;
 747 }
 748
 749 HV*
 750 perl_get_hv(name, create)
 751 char* name;
 752 I32 create;
 753 {
 754     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
 755     if (create)
 756         return GvHVn(gv);
 757     if (gv)
 758         return GvHV(gv);
 759     return Nullhv;
 760 }
 761
 762 CV*
 763 perl_get_cv(name, create)
 764 char* name;
 765 I32 create;
 766 {
 767     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
 768     if (create && !GvCV(gv))
 769         return newSUB(start_subparse(),
 770                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
 771                       Nullop,
 772                       Nullop);
 773     if (gv)
 774         return GvCV(gv);
 775     return Nullcv;
 776 }
 777
 778 /* Be sure to refetch the stack pointer after calling these routines. */
 779
 780 I32
 781 perl_call_argv(subname, flags, argv)
 782 char *subname;
 783 I32 flags;              /* See G_* flags in cop.h */
 784 register char **argv;   /* null terminated arg list */
 785 {
 786     dSP;
 787
 788     PUSHMARK(sp);
 789     if (argv) {
 790         while (*argv) {
 791             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
 792             argv++;
 793         }
 794         PUTBACK;
 795     }
 796     return perl_call_pv(subname, flags);
 797 }
 798
 799 I32
 800 perl_call_pv(subname, flags)
 801 char *subname;          /* name of the subroutine */
 802 I32 flags;              /* See G_* flags in cop.h */
 803 {
 804     return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
 805 }
 806
 807 I32
 808 perl_call_method(methname, flags)
 809 char *methname;         /* name of the subroutine */
 810 I32 flags;              /* See G_* flags in cop.h */
 811 {
 812     dSP;
 813     OP myop;
 814     if (!op)
 815         op = &myop;
 816     XPUSHs(sv_2mortal(newSVpv(methname,0)));
 817     PUTBACK;
 818     pp_method();
 819     return perl_call_sv(*stack_sp--, flags);
 820 }
 821
 822 /* May be called with any of a CV, a GV, or an SV containing the name. */
 823 I32
 824 perl_call_sv(sv, flags)
 825 SV* sv;
 826 I32 flags;              /* See G_* flags in cop.h */
 827 {
 828     LOGOP myop;         /* fake syntax tree node */
 829     SV** sp = stack_sp;
 830     I32 oldmark = TOPMARK;
 831     I32 retval;
 832     Sigjmp_buf oldtop;
 833     I32 oldscope;
 834     static CV *DBcv;
 835
 836     if (flags & G_DISCARD) {
 837         ENTER;
 838         SAVETMPS;
 839     }
 840
 841     SAVESPTR(op);
 842     op = (OP*)&myop;
 843     Zero(op, 1, LOGOP);
 844     EXTEND(stack_sp, 1);
 845     *++stack_sp = sv;
 846     oldscope = scopestack_ix;
 847
 848     if (!(flags & G_NOARGS))
 849         myop.op_flags = OPf_STACKED;
 850     myop.op_next = Nullop;
 851     myop.op_flags |= OPf_KNOW;
 852     if (flags & G_ARRAY)
 853       myop.op_flags |= OPf_LIST;
 854
 855     if (perldb && curstash != debstash
 856            /* Handle first BEGIN of -d. */
 857           && (DBcv || (DBcv = GvCV(DBsub)))
 858            /* Try harder, since this may have been a sighandler, thus
 859             * curstash may be meaningless. */
 860           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
 861         op->op_private |= OPpENTERSUB_DB;
 862
 863     if (flags & G_EVAL) {
 864         Copy(top_env, oldtop, 1, Sigjmp_buf);
 865
 866         cLOGOP->op_other = op;
 867         markstack_ptr--;
 868         /* we're trying to emulate pp_entertry() here */
 869         {
 870             register CONTEXT *cx;
 871             I32 gimme = GIMME;
 872
 873             ENTER;
 874             SAVETMPS;
 875
 876             push_return(op->op_next);
 877             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
 878             PUSHEVAL(cx, 0, 0);
 879             eval_root = op;             /* Only needed so that goto works right. */
 880
 881             in_eval = 1;
 882             if (flags & G_KEEPERR)
 883                 in_eval |= 4;
 884             else
 885                 sv_setpv(GvSV(errgv),"");
 886         }
 887         markstack_ptr++;
 888
 889     restart:
 890         switch (Sigsetjmp(top_env,1)) {
 891         case 0:
 892             break;
 893         case 1:
 894 #ifdef VMS
 895             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
 896 #else
 897         statusvalue = 1;
 898 #endif
 899             /* FALL THROUGH */
 900         case 2:
 901             /* my_exit() was called */
 902             curstash = defstash;
 903             FREETMPS;
 904             Copy(oldtop, top_env, 1, Sigjmp_buf);
 905             if (statusvalue)
 906                 croak("Callback called exit");
 907             my_exit(statusvalue);
 908             /* NOTREACHED */
 909         case 3:
 910             if (restartop) {
 911                 op = restartop;
 912                 restartop = 0;
 913                 goto restart;
 914             }
 915             stack_sp = stack_base + oldmark;
 916             if (flags & G_ARRAY)
 917                 retval = 0;
 918             else {
 919                 retval = 1;
 920                 *++stack_sp = &sv_undef;
 921             }
 922             goto cleanup;
 923         }
 924     }
 925
 926     if (op == (OP*)&myop)
 927         op = pp_entersub();
 928     if (op)
 929         runops();
 930     retval = stack_sp - (stack_base + oldmark);
 931     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
 932         sv_setpv(GvSV(errgv),"");
 933
 934   cleanup:
 935     if (flags & G_EVAL) {
 936         if (scopestack_ix > oldscope) {
 937             SV **newsp;
 938             PMOP *newpm;
 939             I32 gimme;
 940             register CONTEXT *cx;
 941             I32 optype;
 942
 943             POPBLOCK(cx,newpm);
 944             POPEVAL(cx);
 945             pop_return();
 946             curpm = newpm;
 947             LEAVE;
 948         }
 949         Copy(oldtop, top_env, 1, Sigjmp_buf);
 950     }
 951     if (flags & G_DISCARD) {
 952         stack_sp = stack_base + oldmark;
 953         retval = 0;
 954         FREETMPS;
 955         LEAVE;
 956     }
 957     return retval;
 958 }
 959
 960 /* Eval a string. The G_EVAL flag is always assumed. */
 961
 962 I32
 963 perl_eval_sv(sv, flags)
 964 SV* sv;
 965 I32 flags;              /* See G_* flags in cop.h */
 966 {
 967     UNOP myop;          /* fake syntax tree node */
 968     SV** sp = stack_sp;
 969     I32 oldmark = sp - stack_base;
 970     I32 retval;
 971     Sigjmp_buf oldtop;
 972     I32 oldscope;
 973
 974     if (flags & G_DISCARD) {
 975         ENTER;
 976         SAVETMPS;
 977     }
 978
 979     SAVESPTR(op);
 980     op = (OP*)&myop;
 981     Zero(op, 1, UNOP);
 982     EXTEND(stack_sp, 1);
 983     *++stack_sp = sv;
 984     oldscope = scopestack_ix;
 985
 986     if (!(flags & G_NOARGS))
 987         myop.op_flags = OPf_STACKED;
 988     myop.op_next = Nullop;
 989     myop.op_type = OP_ENTEREVAL;
 990     myop.op_flags |= OPf_KNOW;
 991     if (flags & G_KEEPERR)
 992         myop.op_flags |= OPf_SPECIAL;
 993     if (flags & G_ARRAY)
 994         myop.op_flags |= OPf_LIST;
 995
 996     Copy(top_env, oldtop, 1, Sigjmp_buf);
 997
 998 restart:
 999     switch (Sigsetjmp(top_env,1)) {
1000     case 0:
1001         break;
1002     case 1:
1003 #ifdef VMS
1004         statusvalue = 255;      /* XXX I don't think we use 1 anymore. */
1005 #else
1006     statusvalue = 1;
1007 #endif
1008         /* FALL THROUGH */
1009     case 2:
1010         /* my_exit() was called */
1011         curstash = defstash;
1012         FREETMPS;
1013         Copy(oldtop, top_env, 1, Sigjmp_buf);
1014         if (statusvalue)
1015             croak("Callback called exit");
1016         my_exit(statusvalue);
1017         /* NOTREACHED */
1018     case 3:
1019         if (restartop) {
1020             op = restartop;
1021             restartop = 0;
1022             goto restart;
1023         }
1024         stack_sp = stack_base + oldmark;
1025         if (flags & G_ARRAY)
1026             retval = 0;
1027         else {
1028             retval = 1;
1029             *++stack_sp = &sv_undef;
1030         }
1031         goto cleanup;
1032     }
1033
1034     if (op == (OP*)&myop)
1035         op = pp_entereval();
1036     if (op)
1037         runops();
1038     retval = stack_sp - (stack_base + oldmark);
1039     if (!(flags & G_KEEPERR))
1040         sv_setpv(GvSV(errgv),"");
1041
1042   cleanup:
1043     Copy(oldtop, top_env, 1, Sigjmp_buf);
1044     if (flags & G_DISCARD) {
1045         stack_sp = stack_base + oldmark;
1046         retval = 0;
1047         FREETMPS;
1048         LEAVE;
1049     }
1050     return retval;
1051 }
1052
1053 /* Require a module. */
1054
1055 void
1056 perl_require_pv(pv)
1057 char* pv;
1058 {
1059     SV* sv = sv_newmortal();
1060     sv_setpv(sv, "require '");
1061     sv_catpv(sv, pv);
1062     sv_catpv(sv, "'");
1063     perl_eval_sv(sv, G_DISCARD);
1064 }
1065
1066 void
1067 magicname(sym,name,namlen)
1068 char *sym;
1069 char *name;
1070 I32 namlen;
1071 {
1072     register GV *gv;
1073
1074     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1075         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1076 }
1077
1078 #if defined(DOSISH)
1079 #    define PERLLIB_SEP ';'
1080 #else
1081 #  if defined(VMS)
1082 #    define PERLLIB_SEP '|'
1083 #  else
1084 #    define PERLLIB_SEP ':'
1085 #  endif
1086 #endif
1087 #ifndef PERLLIB_MANGLE
1088 #  define PERLLIB_MANGLE(s,n) (s)
1089 #endif
1090
1091 static void
1092 incpush(p)
1093 char *p;
1094 {
1095     char *s;
1096
1097     if (!p)
1098         return;
1099
1100     /* Break at all separators */
1101     while (*p) {
1102         /* First, skip any consecutive separators */
1103         while ( *p == PERLLIB_SEP ) {
1104             /* Uncomment the next line for PATH semantics */
1105             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1106             p++;
1107         }
1108         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1109             av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1110                                           (STRLEN)(s - p)));
1111             p = s + 1;
1112         } else {
1113             av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1114             break;
1115         }
1116     }
1117 }
1118
1119 static void
1120 usage(name)             /* XXX move this out into a module ? */
1121 char *name;
1122 {
1123     /* This message really ought to be max 23 lines.
1124      * Removed -h because the user already knows that opton. Others? */
1125     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1126     printf("\n  -0[octal]       specify record separator (\\0, if no argument)");
1127     printf("\n  -a              autosplit mode with -n or -p (splits $_ into @F)");
1128     printf("\n  -c              check syntax only (runs BEGIN and END blocks)");
1129     printf("\n  -d[:debugger]   run scripts under debugger");
1130     printf("\n  -D[number/list] set debugging flags (argument is a bit mask or flags)");
1131     printf("\n  -e 'command'    one line of script. Several -e's allowed. Omit [programfile].");
1132     printf("\n  -F/pattern/     split() pattern for autosplit (-a). The //'s are optional.");
1133     printf("\n  -i[extension]   edit <> files in place (make backup if extension supplied)");
1134     printf("\n  -Idirectory     specify @INC/#include directory (may be used more then once)");
1135     printf("\n  -l[octal]       enable line ending processing, specifies line teminator");
1136     printf("\n  -[mM][-]module.. executes `use/no module...' before executing your script.");
1137     printf("\n  -n              assume 'while (<>) { ... }' loop arround your script");
1138     printf("\n  -p              assume loop like -n but print line also like sed");
1139     printf("\n  -P              run script through C preprocessor before compilation");
1140     printf("\n  -s              enable some switch parsing for switches after script name");
1141     printf("\n  -S              look for the script using PATH environment variable");
1142     printf("\n  -T              turn on tainting checks");
1143     printf("\n  -u              dump core after parsing script");
1144     printf("\n  -U              allow unsafe operations");
1145     printf("\n  -v              print version number and patchlevel of perl");
1146     printf("\n  -V[:variable]   print perl configuration information");
1147     printf("\n  -w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1148     printf("\n  -x[directory]   strip off text before #!perl line and perhaps cd to directory\n");
1149 }
1150
1151 /* This routine handles any switches that can be given during run */
1152
1153 char *
1154 moreswitches(s)
1155 char *s;
1156 {
1157     I32 numlen;
1158     U32 rschar;
1159
1160     switch (*s) {
1161     case '0':
1162         rschar = scan_oct(s, 4, &numlen);
1163         SvREFCNT_dec(nrs);
1164         if (rschar & ~((U8)~0))
1165             nrs = &sv_undef;
1166         else if (!rschar && numlen >= 2)
1167             nrs = newSVpv("", 0);
1168         else {
1169             char ch = rschar;
1170             nrs = newSVpv(&ch, 1);
1171         }
1172         return s + numlen;
1173     case 'F':
1174         minus_F = TRUE;
1175         splitstr = savepv(s + 1);
1176         s += strlen(s);
1177         return s;
1178     case 'a':
1179         minus_a = TRUE;
1180         s++;
1181         return s;
1182     case 'c':
1183         minus_c = TRUE;
1184         s++;
1185         return s;
1186     case 'd':
1187         forbid_setid("-d");
1188         s++;
1189         if (*s == ':' || *s == '=')  {
1190             sprintf(buf, "use Devel::%s;", ++s);
1191             s += strlen(s);
1192             my_setenv("PERL5DB",buf);
1193         }
1194         if (!perldb) {
1195             perldb = TRUE;
1196             init_debugger();
1197         }
1198         return s;
1199     case 'D':
1200 #ifdef DEBUGGING
1201         forbid_setid("-D");
1202         if (isALPHA(s[1])) {
1203             static char debopts[] = "psltocPmfrxuLHXD";
1204             char *d;
1205
1206             for (s++; *s && (d = strchr(debopts,*s)); s++)
1207                 debug |= 1 << (d - debopts);
1208         }
1209         else {
1210             debug = atoi(s+1);
1211             for (s++; isDIGIT(*s); s++) ;
1212         }
1213         debug |= 0x80000000;
1214 #else
1215         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1216         for (s++; isALNUM(*s); s++) ;
1217 #endif
1218         /*SUPPRESS 530*/
1219         return s;
1220     case 'h':
1221         usage(origargv[0]);
1222         exit(0);
1223     case 'i':
1224         if (inplace)
1225             Safefree(inplace);
1226         inplace = savepv(s+1);
1227         /*SUPPRESS 530*/
1228         for (s = inplace; *s && !isSPACE(*s); s++) ;
1229         *s = '\0';
1230         break;
1231     case 'I':
1232         forbid_setid("-I");
1233         if (*++s) {
1234             char *e;
1235             for (e = s; *e && !isSPACE(*e); e++) ;
1236             av_push(GvAVn(incgv),newSVpv(s,e-s));
1237             if (*e)
1238                 return e;
1239         }
1240         else
1241             croak("No space allowed after -I");
1242         break;
1243     case 'l':
1244         minus_l = TRUE;
1245         s++;
1246         if (ors)
1247             Safefree(ors);
1248         if (isDIGIT(*s)) {
1249             ors = savepv("\n");
1250             orslen = 1;
1251             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1252             s += numlen;
1253         }
1254         else {
1255             if (RsPARA(nrs)) {
1256                 ors = "\n\n";
1257                 orslen = 2;
1258             }
1259             else
1260                 ors = SvPV(nrs, orslen);
1261             ors = savepvn(ors, orslen);
1262         }
1263         return s;
1264     case 'M':
1265         forbid_setid("-M");     /* XXX ? */
1266         /* FALL THROUGH */
1267     case 'm':
1268         forbid_setid("-m");     /* XXX ? */
1269         if (*++s) {
1270             char *start;
1271             char *use = "use ";
1272             /* -M-foo == 'no foo'       */
1273             if (*s == '-') { use = "no "; ++s; }
1274             Sv = newSVpv(use,0);
1275             start = s;
1276             /* We allow -M'Module qw(Foo Bar)'  */
1277             while(isALNUM(*s) || *s==':') ++s;
1278             if (*s != '=') {
1279                 sv_catpv(Sv, start);
1280                 if (*(start-1) == 'm') {
1281                     if (*s != '\0')
1282                         croak("Can't use '%c' after -mname", *s);
1283                     sv_catpv( Sv, " ()");
1284                 }
1285             } else {
1286                 sv_catpvn(Sv, start, s-start);
1287                 sv_catpv(Sv, " split(/,/,q{");
1288                 sv_catpv(Sv, ++s);
1289                 sv_catpv(Sv,    "})");
1290             }
1291             s += strlen(s);
1292             if (preambleav == NULL)
1293                 preambleav = newAV();
1294             av_push(preambleav, Sv);
1295         }
1296         else
1297             croak("No space allowed after -%c", *(s-1));
1298         return s;
1299     case 'n':
1300         minus_n = TRUE;
1301         s++;
1302         return s;
1303     case 'p':
1304         minus_p = TRUE;
1305         s++;
1306         return s;
1307     case 's':
1308         forbid_setid("-s");
1309         doswitches = TRUE;
1310         s++;
1311         return s;
1312     case 'T':
1313         tainting = TRUE;
1314         s++;
1315         return s;
1316     case 'u':
1317         do_undump = TRUE;
1318         s++;
1319         return s;
1320     case 'U':
1321         unsafe = TRUE;
1322         s++;
1323         return s;
1324     case 'v':
1325 #if defined(SUBVERSION) && SUBVERSION > 0
1326         printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1327 #else
1328         printf("\nThis is perl, version %s",patchlevel);
1329 #endif
1330
1331         printf("\n\nCopyright 1987-1996, Larry Wall\n");
1332         printf("\n\t+ suidperl security patch");
1333 #ifdef MSDOS
1334         printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1335 #endif
1336 #ifdef DJGPP
1337         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1338 #endif
1339 #ifdef OS2
1340         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1341             "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1342 #endif
1343 #ifdef atarist
1344         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1345 #endif
1346         printf("\n\
1347 Perl may be copied only under the terms of either the Artistic License or the\n\
1348 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1349         exit(0);
1350     case 'w':
1351         dowarn = TRUE;
1352         s++;
1353         return s;
1354     case '*':
1355     case ' ':
1356         if (s[1] == '-')        /* Additional switches on #! line. */
1357             return s+2;
1358         break;
1359     case '-':
1360     case 0:
1361     case '\n':
1362     case '\t':
1363         break;
1364     case 'P':
1365         if (preprocess)
1366             return s+1;
1367         /* FALL THROUGH */
1368     default:
1369         croak("Can't emulate -%.1s on #! line",s);
1370     }
1371     return Nullch;
1372 }
1373
1374 /* compliments of Tom Christiansen */
1375
1376 /* unexec() can be found in the Gnu emacs distribution */
1377
1378 void
1379 my_unexec()
1380 {
1381 #ifdef UNEXEC
1382     int    status;
1383     extern int etext;
1384
1385     sprintf (buf, "%s.perldump", origfilename);
1386     sprintf (tokenbuf, "%s/perl", BIN);
1387
1388     status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1389     if (status)
1390         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1391     exit(status);
1392 #else
1393 #  ifdef VMS
1394 #    include <lib$routines.h>
1395      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1396 #else
1397     ABORT();            /* for use with undump */
1398 #endif
1399 #endif
1400 }
1401
1402 static void
1403 init_main_stash()
1404 {
1405     GV *gv;
1406
1407     /* Note that strtab is a rather special HV.  Assumptions are made
1408        about not iterating on it, and not adding tie magic to it.
1409        It is properly deallocated in perl_destruct() */
1410     strtab = newHV();
1411     HvSHAREKEYS_off(strtab);                    /* mandatory */
1412     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1413          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1414
1415     curstash = defstash = newHV();
1416     curstname = newSVpv("main",4);
1417     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1418     SvREFCNT_dec(GvHV(gv));
1419     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1420     SvREADONLY_on(gv);
1421     HvNAME(defstash) = savepv("main");
1422     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1423     GvMULTI_on(incgv);
1424     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1425     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1426     GvMULTI_on(errgv);
1427     sv_setpvn(GvSV(errgv), "", 0);
1428     curstash = defstash;
1429     compiling.cop_stash = defstash;
1430     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1431     /* We must init $/ before switches are processed. */
1432     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1433 }
1434
1435 #ifdef CAN_PROTOTYPE
1436 static void
1437 open_script(char *scriptname, bool dosearch, SV *sv)
1438 #else
1439 static void
1440 open_script(scriptname,dosearch,sv)
1441 char *scriptname;
1442 bool dosearch;
1443 SV *sv;
1444 #endif
1445 {
1446     char *xfound = Nullch;
1447     char *xfailed = Nullch;
1448     register char *s;
1449     I32 len;
1450     int retval;
1451 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1452 #define SEARCH_EXTS ".bat", ".cmd", NULL
1453 #endif
1454 #ifdef VMS
1455 #  define SEARCH_EXTS ".pl", ".com", NULL
1456 #endif
1457     /* additional extensions to try in each dir if scriptname not found */
1458 #ifdef SEARCH_EXTS
1459     char *ext[] = { SEARCH_EXTS };
1460     int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1461 #endif
1462
1463 #ifdef VMS
1464     if (dosearch) {
1465         int hasdir, idx = 0, deftypes = 1;
1466
1467         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1468         /* The first time through, just add SEARCH_EXTS to whatever we
1469          * already have, so we can check for default file types. */
1470         while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1471             if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1472             strcat(tokenbuf,scriptname);
1473 #else  /* !VMS */
1474     if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1475
1476         bufend = s + strlen(s);
1477         while (*s) {
1478 #ifndef DOSISH
1479             s = cpytill(tokenbuf,s,bufend,':',&len);
1480 #else
1481 #ifdef atarist
1482             for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1483             tokenbuf[len] = '\0';
1484 #else
1485             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1486             tokenbuf[len] = '\0';
1487 #endif
1488 #endif
1489             if (*s)
1490                 s++;
1491 #ifndef DOSISH
1492             if (len && tokenbuf[len-1] != '/')
1493 #else
1494 #ifdef atarist
1495             if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1496 #else
1497             if (len && tokenbuf[len-1] != '\\')
1498 #endif
1499 #endif
1500                 (void)strcat(tokenbuf+len,"/");
1501             (void)strcat(tokenbuf+len,scriptname);
1502 #endif  /* !VMS */
1503
1504 #ifdef SEARCH_EXTS
1505             len = strlen(tokenbuf);
1506             if (extidx > 0)     /* reset after previous loop */
1507                 extidx = 0;
1508             do {
1509 #endif
1510                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1511                 retval = Stat(tokenbuf,&statbuf);
1512 #ifdef SEARCH_EXTS
1513             } while (  retval < 0               /* not there */
1514                     && extidx>=0 && ext[extidx] /* try an extension? */
1515                     && strcpy(tokenbuf+len, ext[extidx++])
1516                 );
1517 #endif
1518             if (retval < 0)
1519                 continue;
1520             if (S_ISREG(statbuf.st_mode)
1521              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1522                 xfound = tokenbuf;              /* bingo! */
1523                 break;
1524             }
1525             if (!xfailed)
1526                 xfailed = savepv(tokenbuf);
1527         }
1528         if (!xfound)
1529             croak("Can't execute %s", xfailed ? xfailed : scriptname );
1530         if (xfailed)
1531             Safefree(xfailed);
1532         scriptname = xfound;
1533     }
1534
1535     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1536         char *s = scriptname + 8;
1537         fdscript = atoi(s);
1538         while (isDIGIT(*s))
1539             s++;
1540         if (*s)
1541             scriptname = s + 1;
1542     }
1543     else
1544         fdscript = -1;
1545     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1546     curcop->cop_filegv = gv_fetchfile(origfilename);
1547     if (strEQ(origfilename,"-"))
1548         scriptname = "";
1549     if (fdscript >= 0) {
1550         rsfp = PerlIO_fdopen(fdscript,"r");
1551 #if defined(HAS_FCNTL) && defined(F_SETFD)
1552         if (rsfp)
1553             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1554 #endif
1555     }
1556     else if (preprocess) {
1557         char *cpp = CPPSTDIN;
1558
1559         if (strEQ(cpp,"cppstdin"))
1560             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1561         else
1562             sprintf(tokenbuf, "%s", cpp);
1563         sv_catpv(sv,"-I");
1564         sv_catpv(sv,PRIVLIB_EXP);
1565 #ifdef MSDOS
1566         (void)sprintf(buf, "\
1567 sed %s -e \"/^[^#]/b\" \
1568  -e \"/^#[      ]*include[      ]/b\" \
1569  -e \"/^#[      ]*define[       ]/b\" \
1570  -e \"/^#[      ]*if[   ]/b\" \
1571  -e \"/^#[      ]*ifdef[        ]/b\" \
1572  -e \"/^#[      ]*ifndef[       ]/b\" \
1573  -e \"/^#[      ]*else/b\" \
1574  -e \"/^#[      ]*elif[         ]/b\" \
1575  -e \"/^#[      ]*undef[        ]/b\" \
1576  -e \"/^#[      ]*endif/b\" \
1577  -e \"s/^#.*//\" \
1578  %s | %s -C %s %s",
1579           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1580 #else
1581         (void)sprintf(buf, "\
1582 %s %s -e '/^[^#]/b' \
1583  -e '/^#[       ]*include[      ]/b' \
1584  -e '/^#[       ]*define[       ]/b' \
1585  -e '/^#[       ]*if[   ]/b' \
1586  -e '/^#[       ]*ifdef[        ]/b' \
1587  -e '/^#[       ]*ifndef[       ]/b' \
1588  -e '/^#[       ]*else/b' \
1589  -e '/^#[       ]*elif[         ]/b' \
1590  -e '/^#[       ]*undef[        ]/b' \
1591  -e '/^#[       ]*endif/b' \
1592  -e 's/^[       ]*#.*//' \
1593  %s | %s -C %s %s",
1594 #ifdef LOC_SED
1595           LOC_SED,
1596 #else
1597           "sed",
1598 #endif
1599           (doextract ? "-e '1,/^#/d\n'" : ""),
1600 #endif
1601           scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1602         doextract = FALSE;
1603 #ifdef IAMSUID                          /* actually, this is caught earlier */
1604         if (euid != uid && !euid) {     /* if running suidperl */
1605 #ifdef HAS_SETEUID
1606             (void)seteuid(uid);         /* musn't stay setuid root */
1607 #else
1608 #ifdef HAS_SETREUID
1609             (void)setreuid((Uid_t)-1, uid);
1610 #else
1611 #ifdef HAS_SETRESUID
1612             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1613 #else
1614             setuid(uid);
1615 #endif
1616 #endif
1617 #endif
1618             if (geteuid() != uid)
1619                 croak("Can't do seteuid!\n");
1620         }
1621 #endif /* IAMSUID */
1622         rsfp = my_popen(buf,"r");
1623     }
1624     else if (!*scriptname) {
1625         forbid_setid("program input from stdin");
1626         rsfp = PerlIO_stdin();
1627     }
1628     else {
1629         rsfp = PerlIO_open(scriptname,"r");
1630 #if defined(HAS_FCNTL) && defined(F_SETFD)
1631         if (rsfp)
1632             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1633 #endif
1634     }
1635     if (e_tmpname) {
1636         e_fp = rsfp;
1637     }
1638     if (!rsfp) {
1639 #ifdef DOSUID
1640 #ifndef IAMSUID         /* in case script is not readable before setuid */
1641         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1642           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1643             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1644             execv(buf, origargv);       /* try again */
1645             croak("Can't do setuid\n");
1646         }
1647 #endif
1648 #endif
1649         croak("Can't open perl script \"%s\": %s\n",
1650           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1651     }
1652 }
1653
1654 static void
1655 validate_suid(validarg, scriptname)
1656 char *validarg;
1657 char *scriptname;
1658 {
1659     int which;
1660
1661     /* do we need to emulate setuid on scripts? */
1662
1663     /* This code is for those BSD systems that have setuid #! scripts disabled
1664      * in the kernel because of a security problem.  Merely defining DOSUID
1665      * in perl will not fix that problem, but if you have disabled setuid
1666      * scripts in the kernel, this will attempt to emulate setuid and setgid
1667      * on scripts that have those now-otherwise-useless bits set.  The setuid
1668      * root version must be called suidperl or sperlN.NNN.  If regular perl
1669      * discovers that it has opened a setuid script, it calls suidperl with
1670      * the same argv that it had.  If suidperl finds that the script it has
1671      * just opened is NOT setuid root, it sets the effective uid back to the
1672      * uid.  We don't just make perl setuid root because that loses the
1673      * effective uid we had before invoking perl, if it was different from the
1674      * uid.
1675      *
1676      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1677      * be defined in suidperl only.  suidperl must be setuid root.  The
1678      * Configure script will set this up for you if you want it.
1679      */
1680
1681 #ifdef DOSUID
1682     char *s, *s2;
1683
1684     if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
1685         croak("Can't stat script \"%s\"",origfilename);
1686     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1687         I32 len;
1688
1689 #ifdef IAMSUID
1690 #ifndef HAS_SETREUID
1691         /* On this access check to make sure the directories are readable,
1692          * there is actually a small window that the user could use to make
1693          * filename point to an accessible directory.  So there is a faint
1694          * chance that someone could execute a setuid script down in a
1695          * non-accessible directory.  I don't know what to do about that.
1696          * But I don't think it's too important.  The manual lies when
1697          * it says access() is useful in setuid programs.
1698          */
1699         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1700             croak("Permission denied");
1701 #else
1702         /* If we can swap euid and uid, then we can determine access rights
1703          * with a simple stat of the file, and then compare device and
1704          * inode to make sure we did stat() on the same file we opened.
1705          * Then we just have to make sure he or she can execute it.
1706          */
1707         {
1708             struct stat tmpstatbuf;
1709
1710             if (
1711 #ifdef HAS_SETREUID
1712                 setreuid(euid,uid) < 0
1713 #else
1714 # if HAS_SETRESUID
1715                 setresuid(euid,uid,(Uid_t)-1) < 0
1716 # endif
1717 #endif
1718                 || getuid() != euid || geteuid() != uid)
1719                 croak("Can't swap uid and euid");       /* really paranoid */
1720             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1721                 croak("Permission denied");     /* testing full pathname here */
1722             if (tmpstatbuf.st_dev != statbuf.st_dev ||
1723                 tmpstatbuf.st_ino != statbuf.st_ino) {
1724                 (void)PerlIO_close(rsfp);
1725                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
1726                     PerlIO_printf(rsfp,
1727 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1728 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1729                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1730                         statbuf.st_dev, statbuf.st_ino,
1731                         SvPVX(GvSV(curcop->cop_filegv)),
1732                         statbuf.st_uid, statbuf.st_gid);
1733                     (void)my_pclose(rsfp);
1734                 }
1735                 croak("Permission denied\n");
1736             }
1737             if (
1738 #ifdef HAS_SETREUID
1739               setreuid(uid,euid) < 0
1740 #else
1741 # if defined(HAS_SETRESUID)
1742               setresuid(uid,euid,(Uid_t)-1) < 0
1743 # endif
1744 #endif
1745               || getuid() != uid || geteuid() != euid)
1746                 croak("Can't reswap uid and euid");
1747             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
1748                 croak("Permission denied\n");
1749         }
1750 #endif /* HAS_SETREUID */
1751 #endif /* IAMSUID */
1752
1753         if (!S_ISREG(statbuf.st_mode))
1754             croak("Permission denied");
1755         if (statbuf.st_mode & S_IWOTH)
1756             croak("Setuid/gid script is writable by world");
1757         doswitches = FALSE;             /* -s is insecure in suid */
1758         curcop->cop_line++;
1759         if (sv_gets(linestr, rsfp, 0) == Nullch ||
1760           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
1761             croak("No #! line");
1762         s = SvPV(linestr,na)+2;
1763         if (*s == ' ') s++;
1764         while (!isSPACE(*s)) s++;
1765         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
1766                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
1767         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1768             croak("Not a perl script");
1769         while (*s == ' ' || *s == '\t') s++;
1770         /*
1771          * #! arg must be what we saw above.  They can invoke it by
1772          * mentioning suidperl explicitly, but they may not add any strange
1773          * arguments beyond what #! says if they do invoke suidperl that way.
1774          */
1775         len = strlen(validarg);
1776         if (strEQ(validarg," PHOOEY ") ||
1777             strnNE(s,validarg,len) || !isSPACE(s[len]))
1778             croak("Args must match #! line");
1779
1780 #ifndef IAMSUID
1781         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1782             euid == statbuf.st_uid)
1783             if (!do_undump)
1784                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1785 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1786 #endif /* IAMSUID */
1787
1788         if (euid) {     /* oops, we're not the setuid root perl */
1789             (void)PerlIO_close(rsfp);
1790 #ifndef IAMSUID
1791             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1792             execv(buf, origargv);       /* try again */
1793 #endif
1794             croak("Can't do setuid\n");
1795         }
1796
1797         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1798 #ifdef HAS_SETEGID
1799             (void)setegid(statbuf.st_gid);
1800 #else
1801 #ifdef HAS_SETREGID
1802            (void)setregid((Gid_t)-1,statbuf.st_gid);
1803 #else
1804 #ifdef HAS_SETRESGID
1805            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1806 #else
1807             setgid(statbuf.st_gid);
1808 #endif
1809 #endif
1810 #endif
1811             if (getegid() != statbuf.st_gid)
1812                 croak("Can't do setegid!\n");
1813         }
1814         if (statbuf.st_mode & S_ISUID) {
1815             if (statbuf.st_uid != euid)
1816 #ifdef HAS_SETEUID
1817                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1818 #else
1819 #ifdef HAS_SETREUID
1820                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1821 #else
1822 #ifdef HAS_SETRESUID
1823                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1824 #else
1825                 setuid(statbuf.st_uid);
1826 #endif
1827 #endif
1828 #endif
1829             if (geteuid() != statbuf.st_uid)
1830                 croak("Can't do seteuid!\n");
1831         }
1832         else if (uid) {                 /* oops, mustn't run as root */
1833 #ifdef HAS_SETEUID
1834           (void)seteuid((Uid_t)uid);
1835 #else
1836 #ifdef HAS_SETREUID
1837           (void)setreuid((Uid_t)-1,(Uid_t)uid);
1838 #else
1839 #ifdef HAS_SETRESUID
1840           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1841 #else
1842           setuid((Uid_t)uid);
1843 #endif
1844 #endif
1845 #endif
1846             if (geteuid() != uid)
1847                 croak("Can't do seteuid!\n");
1848         }
1849         init_ids();
1850         if (!cando(S_IXUSR,TRUE,&statbuf))
1851             croak("Permission denied\n");       /* they can't do this */
1852     }
1853 #ifdef IAMSUID
1854     else if (preprocess)
1855         croak("-P not allowed for setuid/setgid script\n");
1856     else if (fdscript >= 0)
1857         croak("fd script not allowed in suidperl\n");
1858     else
1859         croak("Script is not setuid/setgid in suidperl\n");
1860
1861     /* We absolutely must clear out any saved ids here, so we */
1862     /* exec the real perl, substituting fd script for scriptname. */
1863     /* (We pass script name as "subdir" of fd, which perl will grok.) */
1864     PerlIO_rewind(rsfp);
1865     lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
1866     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1867     if (!origargv[which])
1868         croak("Permission denied");
1869     (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1870     origargv[which] = buf;
1871
1872 #if defined(HAS_FCNTL) && defined(F_SETFD)
1873     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
1874 #endif
1875
1876     (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1877     execv(tokenbuf, origargv);  /* try again */
1878     croak("Can't do setuid\n");
1879 #endif /* IAMSUID */
1880 #else /* !DOSUID */
1881     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1882 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1883         Fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
1884         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1885             ||
1886             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1887            )
1888             if (!do_undump)
1889                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1890 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1891 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1892         /* not set-id, must be wrapped */
1893     }
1894 #endif /* DOSUID */
1895 }
1896
1897 static void
1898 find_beginning()
1899 {
1900     register char *s, *s2;
1901
1902     /* skip forward in input to the real script? */
1903
1904     forbid_setid("-x");
1905     while (doextract) {
1906         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1907             croak("No Perl script found in input\n");
1908         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1909             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
1910             doextract = FALSE;
1911             while (*s && !(isSPACE (*s) || *s == '#')) s++;
1912             s2 = s;
1913             while (*s == ' ' || *s == '\t') s++;
1914             if (*s++ == '-') {
1915                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1916                 if (strnEQ(s2-4,"perl",4))
1917                     /*SUPPRESS 530*/
1918                     while (s = moreswitches(s)) ;
1919             }
1920             if (cddir && chdir(cddir) < 0)
1921                 croak("Can't chdir to %s",cddir);
1922         }
1923     }
1924 }
1925
1926 static void
1927 init_ids()
1928 {
1929     uid = (int)getuid();
1930     euid = (int)geteuid();
1931     gid = (int)getgid();
1932     egid = (int)getegid();
1933 #ifdef VMS
1934     uid |= gid << 16;
1935     euid |= egid << 16;
1936 #endif
1937     tainting |= (uid && (euid != uid || egid != gid));
1938 }
1939
1940 static void
1941 forbid_setid(s)
1942 char *s;
1943 {
1944     if (euid != uid)
1945         croak("No %s allowed while running setuid", s);
1946     if (egid != gid)
1947         croak("No %s allowed while running setgid", s);
1948 }
1949
1950 static void
1951 init_debugger()
1952 {
1953     curstash = debstash;
1954     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1955     AvREAL_off(dbargs);
1956     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1957     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1958     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1959     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1960     sv_setiv(DBsingle, 0);
1961     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1962     sv_setiv(DBtrace, 0);
1963     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1964     sv_setiv(DBsignal, 0);
1965     curstash = defstash;
1966 }
1967
1968 static void
1969 init_stacks()
1970 {
1971     curstack = newAV();
1972     mainstack = curstack;               /* remember in case we switch stacks */
1973     AvREAL_off(curstack);               /* not a real array */
1974     av_extend(curstack,127);
1975
1976     stack_base = AvARRAY(curstack);
1977     stack_sp = stack_base;
1978     stack_max = stack_base + 127;
1979
1980     cxstack_max = 8192 / sizeof(CONTEXT) - 2;   /* Use most of 8K. */
1981     New(50,cxstack,cxstack_max + 1,CONTEXT);
1982     cxstack_ix  = -1;
1983
1984     New(50,tmps_stack,128,SV*);
1985     tmps_ix = -1;
1986     tmps_max = 128;
1987
1988     DEBUG( {
1989         New(51,debname,128,char);
1990         New(52,debdelim,128,char);
1991     } )
1992
1993     /*
1994      * The following stacks almost certainly should be per-interpreter,
1995      * but for now they're not.  XXX
1996      */
1997
1998     if (markstack) {
1999         markstack_ptr = markstack;
2000     } else {
2001         New(54,markstack,64,I32);
2002         markstack_ptr = markstack;
2003         markstack_max = markstack + 64;
2004     }
2005
2006     if (scopestack) {
2007         scopestack_ix = 0;
2008     } else {
2009         New(54,scopestack,32,I32);
2010         scopestack_ix = 0;
2011         scopestack_max = 32;
2012     }
2013
2014     if (savestack) {
2015         savestack_ix = 0;
2016     } else {
2017         New(54,savestack,128,ANY);
2018         savestack_ix = 0;
2019         savestack_max = 128;
2020     }
2021
2022     if (retstack) {
2023         retstack_ix = 0;
2024     } else {
2025         New(54,retstack,16,OP*);
2026         retstack_ix = 0;
2027         retstack_max = 16;
2028     }
2029 }
2030
2031 static void
2032 nuke_stacks()
2033 {
2034     Safefree(cxstack);
2035     Safefree(tmps_stack);
2036     DEBUG( {
2037         Safefree(debname);
2038         Safefree(debdelim);
2039     } )
2040 }
2041
2042 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2043
2044 static void
2045 init_lexer()
2046 {
2047     tmpfp = rsfp;
2048     lex_start(linestr);
2049     rsfp = tmpfp;
2050     subname = newSVpv("main",4);
2051 }
2052
2053 static void
2054 init_predump_symbols()
2055 {
2056     GV *tmpgv;
2057     GV *othergv;
2058
2059     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2060
2061     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2062     GvMULTI_on(stdingv);
2063     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2064     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2065     GvMULTI_on(tmpgv);
2066     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2067
2068     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2069     GvMULTI_on(tmpgv);
2070     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2071     setdefout(tmpgv);
2072     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2073     GvMULTI_on(tmpgv);
2074     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2075
2076     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2077     GvMULTI_on(othergv);
2078     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2079     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2080     GvMULTI_on(tmpgv);
2081     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2082
2083     statname = NEWSV(66,0);             /* last filename we did stat on */
2084
2085     if (!osname)
2086         osname = savepv(OSNAME);
2087 }
2088
2089 static void
2090 init_postdump_symbols(argc,argv,env)
2091 register int argc;
2092 register char **argv;
2093 register char **env;
2094 {
2095     char *s;
2096     SV *sv;
2097     GV* tmpgv;
2098
2099     argc--,argv++;      /* skip name of script */
2100     if (doswitches) {
2101         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2102             if (!argv[0][1])
2103                 break;
2104             if (argv[0][1] == '-') {
2105                 argc--,argv++;
2106                 break;
2107             }
2108             if (s = strchr(argv[0], '=')) {
2109                 *s++ = '\0';
2110                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2111             }
2112             else
2113                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2114         }
2115     }
2116     toptarget = NEWSV(0,0);
2117     sv_upgrade(toptarget, SVt_PVFM);
2118     sv_setpvn(toptarget, "", 0);
2119     bodytarget = NEWSV(0,0);
2120     sv_upgrade(bodytarget, SVt_PVFM);
2121     sv_setpvn(bodytarget, "", 0);
2122     formtarget = bodytarget;
2123
2124     TAINT;
2125     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2126         sv_setpv(GvSV(tmpgv),origfilename);
2127         magicname("0", "0", 1);
2128     }
2129     if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2130         time(&basetime);
2131     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2132         sv_setpv(GvSV(tmpgv),origargv[0]);
2133     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2134         GvMULTI_on(argvgv);
2135         (void)gv_AVadd(argvgv);
2136         av_clear(GvAVn(argvgv));
2137         for (; argc > 0; argc--,argv++) {
2138             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2139         }
2140     }
2141     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2142         HV *hv;
2143         GvMULTI_on(envgv);
2144         hv = GvHVn(envgv);
2145         hv_clear(hv);
2146 #ifndef VMS  /* VMS doesn't have environ array */
2147         /* Note that if the supplied env parameter is actually a copy
2148            of the global environ then it may now point to free'd memory
2149            if the environment has been modified since. To avoid this
2150            problem we treat env==NULL as meaning 'use the default'
2151         */
2152         if (!env)
2153             env = environ;
2154         if (env != environ) {
2155             environ[0] = Nullch;
2156             hv_magic(hv, envgv, 'E');
2157         }
2158         for (; *env; env++) {
2159             if (!(s = strchr(*env,'=')))
2160                 continue;
2161             *s++ = '\0';
2162             sv = newSVpv(s--,0);
2163             sv_magic(sv, sv, 'e', *env, s - *env);
2164             (void)hv_store(hv, *env, s - *env, sv, 0);
2165             *s = '=';
2166         }
2167 #endif
2168 #ifdef DYNAMIC_ENV_FETCH
2169         HvNAME(hv) = savepv(ENV_HV_NAME);
2170 #endif
2171         hv_magic(hv, envgv, 'E');
2172     }
2173     TAINT_NOT;
2174     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2175         sv_setiv(GvSV(tmpgv),(I32)getpid());
2176 }
2177
2178 static void
2179 init_perllib()
2180 {
2181     char *s;
2182     if (!tainting) {
2183 #ifndef VMS
2184         s = getenv("PERL5LIB");
2185         if (s)
2186             incpush(s);
2187         else
2188             incpush(getenv("PERLLIB"));
2189 #else /* VMS */
2190         /* Treat PERL5?LIB as a possible search list logical name -- the
2191          * "natural" VMS idiom for a Unix path string.  We allow each
2192          * element to be a set of |-separated directories for compatibility.
2193          */
2194         char buf[256];
2195         int idx = 0;
2196         if (my_trnlnm("PERL5LIB",buf,0))
2197             do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2198         else
2199             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2200 #endif /* VMS */
2201     }
2202
2203 /* Use the ~-expanded versions of APPLIB (undocumented),
2204     ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2205 */
2206 #ifdef APPLLIB_EXP
2207     incpush(APPLLIB_EXP);
2208 #endif
2209
2210 #ifdef ARCHLIB_EXP
2211     incpush(ARCHLIB_EXP);
2212 #endif
2213 #ifndef PRIVLIB_EXP
2214 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2215 #endif
2216     incpush(PRIVLIB_EXP);
2217
2218 #ifdef SITEARCH_EXP
2219     incpush(SITEARCH_EXP);
2220 #endif
2221 #ifdef SITELIB_EXP
2222     incpush(SITELIB_EXP);
2223 #endif
2224 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2225     incpush(OLDARCHLIB_EXP);
2226 #endif
2227
2228     if (!tainting)
2229         incpush(".");
2230 }
2231
2232 void
2233 calllist(list)
2234 AV* list;
2235 {
2236     Sigjmp_buf oldtop;
2237     STRLEN len;
2238     line_t oldline = curcop->cop_line;
2239
2240     Copy(top_env, oldtop, 1, Sigjmp_buf);
2241
2242     while (AvFILL(list) >= 0) {
2243         CV *cv = (CV*)av_shift(list);
2244
2245         SAVEFREESV(cv);
2246
2247         switch (Sigsetjmp(top_env,1)) {
2248         case 0: {
2249                 SV* atsv = GvSV(errgv);
2250                 PUSHMARK(stack_sp);
2251                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2252                 (void)SvPV(atsv, len);
2253                 if (len) {
2254                     Copy(oldtop, top_env, 1, Sigjmp_buf);
2255                     curcop = &compiling;
2256                     curcop->cop_line = oldline;
2257                     if (list == beginav)
2258                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2259                     else
2260                         sv_catpv(atsv, "END failed--cleanup aborted");
2261                     croak("%s", SvPVX(atsv));
2262                 }
2263             }
2264             break;
2265         case 1:
2266 #ifdef VMS
2267             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
2268 #else
2269         statusvalue = 1;
2270 #endif
2271             /* FALL THROUGH */
2272         case 2:
2273             /* my_exit() was called */
2274             curstash = defstash;
2275             if (endav)
2276                 calllist(endav);
2277             FREETMPS;
2278             Copy(oldtop, top_env, 1, Sigjmp_buf);
2279             curcop = &compiling;
2280             curcop->cop_line = oldline;
2281             if (statusvalue) {
2282                 if (list == beginav)
2283                     croak("BEGIN failed--compilation aborted");
2284                 else
2285                     croak("END failed--cleanup aborted");
2286             }
2287             my_exit(statusvalue);
2288             /* NOTREACHED */
2289             return;
2290         case 3:
2291             if (!restartop) {
2292                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2293                 FREETMPS;
2294                 break;
2295             }
2296             Copy(oldtop, top_env, 1, Sigjmp_buf);
2297             curcop = &compiling;
2298             curcop->cop_line = oldline;
2299             Siglongjmp(top_env, 3);
2300         }
2301     }
2302
2303     Copy(oldtop, top_env, 1, Sigjmp_buf);
2304 }
2305