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         if (rsfp)
1523             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1524 #endif
1525     }
1526     else if (preprocess) {
1527         char *cpp = CPPSTDIN;
1528
1529         if (strEQ(cpp,"cppstdin"))
1530             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1531         else
1532             sprintf(tokenbuf, "%s", cpp);
1533         sv_catpv(sv,"-I");
1534         sv_catpv(sv,PRIVLIB_EXP);
1535 #ifdef MSDOS
1536         (void)sprintf(buf, "\
1537 sed %s -e \"/^[^#]/b\" \
1538  -e \"/^#[      ]*include[      ]/b\" \
1539  -e \"/^#[      ]*define[       ]/b\" \
1540  -e \"/^#[      ]*if[   ]/b\" \
1541  -e \"/^#[      ]*ifdef[        ]/b\" \
1542  -e \"/^#[      ]*ifndef[       ]/b\" \
1543  -e \"/^#[      ]*else/b\" \
1544  -e \"/^#[      ]*elif[         ]/b\" \
1545  -e \"/^#[      ]*undef[        ]/b\" \
1546  -e \"/^#[      ]*endif/b\" \
1547  -e \"s/^#.*//\" \
1548  %s | %s -C %s %s",
1549           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1550 #else
1551         (void)sprintf(buf, "\
1552 %s %s -e '/^[^#]/b' \
1553  -e '/^#[       ]*include[      ]/b' \
1554  -e '/^#[       ]*define[       ]/b' \
1555  -e '/^#[       ]*if[   ]/b' \
1556  -e '/^#[       ]*ifdef[        ]/b' \
1557  -e '/^#[       ]*ifndef[       ]/b' \
1558  -e '/^#[       ]*else/b' \
1559  -e '/^#[       ]*elif[         ]/b' \
1560  -e '/^#[       ]*undef[        ]/b' \
1561  -e '/^#[       ]*endif/b' \
1562  -e 's/^[       ]*#.*//' \
1563  %s | %s -C %s %s",
1564 #ifdef LOC_SED
1565           LOC_SED,
1566 #else
1567           "sed",
1568 #endif
1569           (doextract ? "-e '1,/^#/d\n'" : ""),
1570 #endif
1571           scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1572         doextract = FALSE;
1573 #ifdef IAMSUID                          /* actually, this is caught earlier */
1574         if (euid != uid && !euid) {     /* if running suidperl */
1575 #ifdef HAS_SETEUID
1576             (void)seteuid(uid);         /* musn't stay setuid root */
1577 #else
1578 #ifdef HAS_SETREUID
1579             (void)setreuid((Uid_t)-1, uid);
1580 #else
1581 #ifdef HAS_SETRESUID
1582             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1583 #else
1584             setuid(uid);
1585 #endif
1586 #endif
1587 #endif
1588             if (geteuid() != uid)
1589                 croak("Can't do seteuid!\n");
1590         }
1591 #endif /* IAMSUID */
1592         rsfp = my_popen(buf,"r");
1593     }
1594     else if (!*scriptname) {
1595         forbid_setid("program input from stdin");
1596         rsfp = PerlIO_stdin();
1597     }
1598     else {
1599         rsfp = PerlIO_open(scriptname,"r");
1600 #if defined(HAS_FCNTL) && defined(F_SETFD)
1601         if (rsfp)
1602             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1603 #endif
1604     }
1605     if (e_tmpname) {
1606         e_fp = rsfp;
1607     }
1608     if (!rsfp) {
1609 #ifdef DOSUID
1610 #ifndef IAMSUID         /* in case script is not readable before setuid */
1611         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1612           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1613             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1614             execv(buf, origargv);       /* try again */
1615             croak("Can't do setuid\n");
1616         }
1617 #endif
1618 #endif
1619         croak("Can't open perl script \"%s\": %s\n",
1620           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1621     }
1622 }
1623
1624 static void
1625 validate_suid(validarg, scriptname)
1626 char *validarg;
1627 char *scriptname;
1628 {
1629     int which;
1630
1631     /* do we need to emulate setuid on scripts? */
1632
1633     /* This code is for those BSD systems that have setuid #! scripts disabled
1634      * in the kernel because of a security problem.  Merely defining DOSUID
1635      * in perl will not fix that problem, but if you have disabled setuid
1636      * scripts in the kernel, this will attempt to emulate setuid and setgid
1637      * on scripts that have those now-otherwise-useless bits set.  The setuid
1638      * root version must be called suidperl or sperlN.NNN.  If regular perl
1639      * discovers that it has opened a setuid script, it calls suidperl with
1640      * the same argv that it had.  If suidperl finds that the script it has
1641      * just opened is NOT setuid root, it sets the effective uid back to the
1642      * uid.  We don't just make perl setuid root because that loses the
1643      * effective uid we had before invoking perl, if it was different from the
1644      * uid.
1645      *
1646      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1647      * be defined in suidperl only.  suidperl must be setuid root.  The
1648      * Configure script will set this up for you if you want it.
1649      */
1650
1651 #ifdef DOSUID
1652     char *s, *s2;
1653
1654     if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
1655         croak("Can't stat script \"%s\"",origfilename);
1656     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1657         I32 len;
1658
1659 #ifdef IAMSUID
1660 #ifndef HAS_SETREUID
1661         /* On this access check to make sure the directories are readable,
1662          * there is actually a small window that the user could use to make
1663          * filename point to an accessible directory.  So there is a faint
1664          * chance that someone could execute a setuid script down in a
1665          * non-accessible directory.  I don't know what to do about that.
1666          * But I don't think it's too important.  The manual lies when
1667          * it says access() is useful in setuid programs.
1668          */
1669         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1670             croak("Permission denied");
1671 #else
1672         /* If we can swap euid and uid, then we can determine access rights
1673          * with a simple stat of the file, and then compare device and
1674          * inode to make sure we did stat() on the same file we opened.
1675          * Then we just have to make sure he or she can execute it.
1676          */
1677         {
1678             struct stat tmpstatbuf;
1679
1680             if (
1681 #ifdef HAS_SETREUID
1682                 setreuid(euid,uid) < 0
1683 #else
1684 # if HAS_SETRESUID
1685                 setresuid(euid,uid,(Uid_t)-1) < 0
1686 # endif
1687 #endif
1688                 || getuid() != euid || geteuid() != uid)
1689                 croak("Can't swap uid and euid");       /* really paranoid */
1690             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1691                 croak("Permission denied");     /* testing full pathname here */
1692             if (tmpstatbuf.st_dev != statbuf.st_dev ||
1693                 tmpstatbuf.st_ino != statbuf.st_ino) {
1694                 (void)PerlIO_close(rsfp);
1695                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
1696                     PerlIO_printf(rsfp,
1697 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1698 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1699                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1700                         statbuf.st_dev, statbuf.st_ino,
1701                         SvPVX(GvSV(curcop->cop_filegv)),
1702                         statbuf.st_uid, statbuf.st_gid);
1703                     (void)my_pclose(rsfp);
1704                 }
1705                 croak("Permission denied\n");
1706             }
1707             if (
1708 #ifdef HAS_SETREUID
1709               setreuid(uid,euid) < 0
1710 #else
1711 # if defined(HAS_SETRESUID)
1712               setresuid(uid,euid,(Uid_t)-1) < 0
1713 # endif
1714 #endif
1715               || getuid() != uid || geteuid() != euid)
1716                 croak("Can't reswap uid and euid");
1717             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
1718                 croak("Permission denied\n");
1719         }
1720 #endif /* HAS_SETREUID */
1721 #endif /* IAMSUID */
1722
1723         if (!S_ISREG(statbuf.st_mode))
1724             croak("Permission denied");
1725         if (statbuf.st_mode & S_IWOTH)
1726             croak("Setuid/gid script is writable by world");
1727         doswitches = FALSE;             /* -s is insecure in suid */
1728         curcop->cop_line++;
1729         if (sv_gets(linestr, rsfp, 0) == Nullch ||
1730           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
1731             croak("No #! line");
1732         s = SvPV(linestr,na)+2;
1733         if (*s == ' ') s++;
1734         while (!isSPACE(*s)) s++;
1735         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
1736                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
1737         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1738             croak("Not a perl script");
1739         while (*s == ' ' || *s == '\t') s++;
1740         /*
1741          * #! arg must be what we saw above.  They can invoke it by
1742          * mentioning suidperl explicitly, but they may not add any strange
1743          * arguments beyond what #! says if they do invoke suidperl that way.
1744          */
1745         len = strlen(validarg);
1746         if (strEQ(validarg," PHOOEY ") ||
1747             strnNE(s,validarg,len) || !isSPACE(s[len]))
1748             croak("Args must match #! line");
1749
1750 #ifndef IAMSUID
1751         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1752             euid == statbuf.st_uid)
1753             if (!do_undump)
1754                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1755 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1756 #endif /* IAMSUID */
1757
1758         if (euid) {     /* oops, we're not the setuid root perl */
1759             (void)PerlIO_close(rsfp);
1760 #ifndef IAMSUID
1761             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1762             execv(buf, origargv);       /* try again */
1763 #endif
1764             croak("Can't do setuid\n");
1765         }
1766
1767         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1768 #ifdef HAS_SETEGID
1769             (void)setegid(statbuf.st_gid);
1770 #else
1771 #ifdef HAS_SETREGID
1772            (void)setregid((Gid_t)-1,statbuf.st_gid);
1773 #else
1774 #ifdef HAS_SETRESGID
1775            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1776 #else
1777             setgid(statbuf.st_gid);
1778 #endif
1779 #endif
1780 #endif
1781             if (getegid() != statbuf.st_gid)
1782                 croak("Can't do setegid!\n");
1783         }
1784         if (statbuf.st_mode & S_ISUID) {
1785             if (statbuf.st_uid != euid)
1786 #ifdef HAS_SETEUID
1787                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1788 #else
1789 #ifdef HAS_SETREUID
1790                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1791 #else
1792 #ifdef HAS_SETRESUID
1793                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1794 #else
1795                 setuid(statbuf.st_uid);
1796 #endif
1797 #endif
1798 #endif
1799             if (geteuid() != statbuf.st_uid)
1800                 croak("Can't do seteuid!\n");
1801         }
1802         else if (uid) {                 /* oops, mustn't run as root */
1803 #ifdef HAS_SETEUID
1804           (void)seteuid((Uid_t)uid);
1805 #else
1806 #ifdef HAS_SETREUID
1807           (void)setreuid((Uid_t)-1,(Uid_t)uid);
1808 #else
1809 #ifdef HAS_SETRESUID
1810           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1811 #else
1812           setuid((Uid_t)uid);
1813 #endif
1814 #endif
1815 #endif
1816             if (geteuid() != uid)
1817                 croak("Can't do seteuid!\n");
1818         }
1819         init_ids();
1820         if (!cando(S_IXUSR,TRUE,&statbuf))
1821             croak("Permission denied\n");       /* they can't do this */
1822     }
1823 #ifdef IAMSUID
1824     else if (preprocess)
1825         croak("-P not allowed for setuid/setgid script\n");
1826     else if (fdscript >= 0)
1827         croak("fd script not allowed in suidperl\n");
1828     else
1829         croak("Script is not setuid/setgid in suidperl\n");
1830
1831     /* We absolutely must clear out any saved ids here, so we */
1832     /* exec the real perl, substituting fd script for scriptname. */
1833     /* (We pass script name as "subdir" of fd, which perl will grok.) */
1834     PerlIO_rewind(rsfp);
1835     lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
1836     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1837     if (!origargv[which])
1838         croak("Permission denied");
1839     (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1840     origargv[which] = buf;
1841
1842 #if defined(HAS_FCNTL) && defined(F_SETFD)
1843     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
1844 #endif
1845
1846     (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1847     execv(tokenbuf, origargv);  /* try again */
1848     croak("Can't do setuid\n");
1849 #endif /* IAMSUID */
1850 #else /* !DOSUID */
1851     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1852 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1853         Fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
1854         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1855             ||
1856             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1857            )
1858             if (!do_undump)
1859                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1860 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1861 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1862         /* not set-id, must be wrapped */
1863     }
1864 #endif /* DOSUID */
1865 }
1866
1867 static void
1868 find_beginning()
1869 {
1870     register char *s, *s2;
1871
1872     /* skip forward in input to the real script? */
1873
1874     forbid_setid("-x");
1875     while (doextract) {
1876         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1877             croak("No Perl script found in input\n");
1878         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1879             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
1880             doextract = FALSE;
1881             while (*s && !(isSPACE (*s) || *s == '#')) s++;
1882             s2 = s;
1883             while (*s == ' ' || *s == '\t') s++;
1884             if (*s++ == '-') {
1885                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1886                 if (strnEQ(s2-4,"perl",4))
1887                     /*SUPPRESS 530*/
1888                     while (s = moreswitches(s)) ;
1889             }
1890             if (cddir && chdir(cddir) < 0)
1891                 croak("Can't chdir to %s",cddir);
1892         }
1893     }
1894 }
1895
1896 static void
1897 init_ids()
1898 {
1899     uid = (int)getuid();
1900     euid = (int)geteuid();
1901     gid = (int)getgid();
1902     egid = (int)getegid();
1903 #ifdef VMS
1904     uid |= gid << 16;
1905     euid |= egid << 16;
1906 #endif
1907     tainting |= (uid && (euid != uid || egid != gid));
1908 }
1909
1910 static void
1911 forbid_setid(s)
1912 char *s;
1913 {
1914     if (euid != uid)
1915         croak("No %s allowed while running setuid", s);
1916     if (egid != gid)
1917         croak("No %s allowed while running setgid", s);
1918 }
1919
1920 static void
1921 init_debugger()
1922 {
1923     curstash = debstash;
1924     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1925     AvREAL_off(dbargs);
1926     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1927     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1928     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1929     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1930     sv_setiv(DBsingle, 0);
1931     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1932     sv_setiv(DBtrace, 0);
1933     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1934     sv_setiv(DBsignal, 0);
1935     curstash = defstash;
1936 }
1937
1938 static void
1939 init_stacks()
1940 {
1941     curstack = newAV();
1942     mainstack = curstack;                       /* remember in case we switch stacks */
1943     AvREAL_off(curstack);                       /* not a real array */
1944     av_extend(curstack,127);
1945
1946     stack_base = AvARRAY(curstack);
1947     stack_sp = stack_base;
1948     stack_max = stack_base + 127;
1949
1950     /* Shouldn't these stacks be per-interpreter? */
1951     if (markstack) {
1952         markstack_ptr = markstack;
1953     } else {
1954         New(54,markstack,64,I32);
1955         markstack_ptr = markstack;
1956         markstack_max = markstack + 64;
1957     }
1958
1959     if (scopestack) {
1960         scopestack_ix = 0;
1961     } else {
1962         New(54,scopestack,32,I32);
1963         scopestack_ix = 0;
1964         scopestack_max = 32;
1965     }
1966
1967     if (savestack) {
1968         savestack_ix = 0;
1969     } else {
1970         New(54,savestack,128,ANY);
1971         savestack_ix = 0;
1972         savestack_max = 128;
1973     }
1974
1975     if (retstack) {
1976         retstack_ix = 0;
1977     } else {
1978         New(54,retstack,16,OP*);
1979         retstack_ix = 0;
1980         retstack_max = 16;
1981    }
1982
1983     cxstack_max = 8192 / sizeof(CONTEXT) - 2;   /* Use most of 8K. */
1984     New(50,cxstack,cxstack_max + 1,CONTEXT);
1985     cxstack_ix  = -1;
1986
1987     New(50,tmps_stack,128,SV*);
1988     tmps_ix = -1;
1989     tmps_max = 128;
1990
1991     DEBUG( {
1992         New(51,debname,128,char);
1993         New(52,debdelim,128,char);
1994     } )
1995 }
1996
1997 static void
1998 nuke_stacks()
1999 {
2000     Safefree(cxstack);
2001     Safefree(tmps_stack);
2002 }
2003
2004 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2005
2006 static void
2007 init_lexer()
2008 {
2009     tmpfp = rsfp;
2010     lex_start(linestr);
2011     rsfp = tmpfp;
2012     subname = newSVpv("main",4);
2013 }
2014
2015 static void
2016 init_predump_symbols()
2017 {
2018     GV *tmpgv;
2019     GV *othergv;
2020
2021     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2022
2023     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2024     GvMULTI_on(stdingv);
2025     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2026     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2027     GvMULTI_on(tmpgv);
2028     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2029
2030     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2031     GvMULTI_on(tmpgv);
2032     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2033     setdefout(tmpgv);
2034     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2035     GvMULTI_on(tmpgv);
2036     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2037
2038     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2039     GvMULTI_on(othergv);
2040     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2041     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2042     GvMULTI_on(tmpgv);
2043     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2044
2045     statname = NEWSV(66,0);             /* last filename we did stat on */
2046
2047     if (!osname)
2048         osname = savepv(OSNAME);
2049 }
2050
2051 static void
2052 init_postdump_symbols(argc,argv,env)
2053 register int argc;
2054 register char **argv;
2055 register char **env;
2056 {
2057     char *s;
2058     SV *sv;
2059     GV* tmpgv;
2060
2061     argc--,argv++;      /* skip name of script */
2062     if (doswitches) {
2063         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2064             if (!argv[0][1])
2065                 break;
2066             if (argv[0][1] == '-') {
2067                 argc--,argv++;
2068                 break;
2069             }
2070             if (s = strchr(argv[0], '=')) {
2071                 *s++ = '\0';
2072                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2073             }
2074             else
2075                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2076         }
2077     }
2078     toptarget = NEWSV(0,0);
2079     sv_upgrade(toptarget, SVt_PVFM);
2080     sv_setpvn(toptarget, "", 0);
2081     bodytarget = NEWSV(0,0);
2082     sv_upgrade(bodytarget, SVt_PVFM);
2083     sv_setpvn(bodytarget, "", 0);
2084     formtarget = bodytarget;
2085
2086     TAINT;
2087     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2088         sv_setpv(GvSV(tmpgv),origfilename);
2089         magicname("0", "0", 1);
2090     }
2091     if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2092         time(&basetime);
2093     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2094         sv_setpv(GvSV(tmpgv),origargv[0]);
2095     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2096         GvMULTI_on(argvgv);
2097         (void)gv_AVadd(argvgv);
2098         av_clear(GvAVn(argvgv));
2099         for (; argc > 0; argc--,argv++) {
2100             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2101         }
2102     }
2103     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2104         HV *hv;
2105         GvMULTI_on(envgv);
2106         hv = GvHVn(envgv);
2107         hv_clear(hv);
2108 #ifndef VMS  /* VMS doesn't have environ array */
2109         /* Note that if the supplied env parameter is actually a copy
2110            of the global environ then it may now point to free'd memory
2111            if the environment has been modified since. To avoid this
2112            problem we treat env==NULL as meaning 'use the default'
2113         */
2114         if (!env)
2115             env = environ;
2116         if (env != environ) {
2117             environ[0] = Nullch;
2118             hv_magic(hv, envgv, 'E');
2119         }
2120         for (; *env; env++) {
2121             if (!(s = strchr(*env,'=')))
2122                 continue;
2123             *s++ = '\0';
2124             sv = newSVpv(s--,0);
2125             sv_magic(sv, sv, 'e', *env, s - *env);
2126             (void)hv_store(hv, *env, s - *env, sv, 0);
2127             *s = '=';
2128         }
2129 #endif
2130 #ifdef DYNAMIC_ENV_FETCH
2131         HvNAME(hv) = savepv(ENV_HV_NAME);
2132 #endif
2133         hv_magic(hv, envgv, 'E');
2134     }
2135     TAINT_NOT;
2136     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2137         sv_setiv(GvSV(tmpgv),(I32)getpid());
2138 }
2139
2140 static void
2141 init_perllib()
2142 {
2143     char *s;
2144     if (!tainting) {
2145 #ifndef VMS
2146         s = getenv("PERL5LIB");
2147         if (s)
2148             incpush(s);
2149         else
2150             incpush(getenv("PERLLIB"));
2151 #else /* VMS */
2152         /* Treat PERL5?LIB as a possible search list logical name -- the
2153          * "natural" VMS idiom for a Unix path string.  We allow each
2154          * element to be a set of |-separated directories for compatibility.
2155          */
2156         char buf[256];
2157         int idx = 0;
2158         if (my_trnlnm("PERL5LIB",buf,0))
2159             do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2160         else
2161             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2162 #endif /* VMS */
2163     }
2164
2165 /* Use the ~-expanded versions of APPLIB (undocumented),
2166     ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2167 */
2168 #ifdef APPLLIB_EXP
2169     incpush(APPLLIB_EXP);
2170 #endif
2171
2172 #ifdef ARCHLIB_EXP
2173     incpush(ARCHLIB_EXP);
2174 #endif
2175 #ifndef PRIVLIB_EXP
2176 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2177 #endif
2178     incpush(PRIVLIB_EXP);
2179
2180 #ifdef SITEARCH_EXP
2181     incpush(SITEARCH_EXP);
2182 #endif
2183 #ifdef SITELIB_EXP
2184     incpush(SITELIB_EXP);
2185 #endif
2186 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2187     incpush(OLDARCHLIB_EXP);
2188 #endif
2189
2190     if (!tainting)
2191         incpush(".");
2192 }
2193
2194 void
2195 calllist(list)
2196 AV* list;
2197 {
2198     Sigjmp_buf oldtop;
2199     STRLEN len;
2200     line_t oldline = curcop->cop_line;
2201
2202     Copy(top_env, oldtop, 1, Sigjmp_buf);
2203
2204     while (AvFILL(list) >= 0) {
2205         CV *cv = (CV*)av_shift(list);
2206
2207         SAVEFREESV(cv);
2208
2209         switch (Sigsetjmp(top_env,1)) {
2210         case 0: {
2211                 SV* atsv = GvSV(errgv);
2212                 PUSHMARK(stack_sp);
2213                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2214                 (void)SvPV(atsv, len);
2215                 if (len) {
2216                     Copy(oldtop, top_env, 1, Sigjmp_buf);
2217                     curcop = &compiling;
2218                     curcop->cop_line = oldline;
2219                     if (list == beginav)
2220                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2221                     else
2222                         sv_catpv(atsv, "END failed--cleanup aborted");
2223                     croak("%s", SvPVX(atsv));
2224                 }
2225             }
2226             break;
2227         case 1:
2228 #ifdef VMS
2229             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
2230 #else
2231         statusvalue = 1;
2232 #endif
2233             /* FALL THROUGH */
2234         case 2:
2235             /* my_exit() was called */
2236             curstash = defstash;
2237             if (endav)
2238                 calllist(endav);
2239             FREETMPS;
2240             Copy(oldtop, top_env, 1, Sigjmp_buf);
2241             curcop = &compiling;
2242             curcop->cop_line = oldline;
2243             if (statusvalue) {
2244                 if (list == beginav)
2245                     croak("BEGIN failed--compilation aborted");
2246                 else
2247                     croak("END failed--cleanup aborted");
2248             }
2249             my_exit(statusvalue);
2250             /* NOTREACHED */
2251             return;
2252         case 3:
2253             if (!restartop) {
2254                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2255                 FREETMPS;
2256                 break;
2257             }
2258             Copy(oldtop, top_env, 1, Sigjmp_buf);
2259             curcop = &compiling;
2260             curcop->cop_line = oldline;
2261             Siglongjmp(top_env, 3);
2262         }
2263     }
2264
2265     Copy(oldtop, top_env, 1, Sigjmp_buf);
2266 }
2267