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