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