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     SET_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            /* Handle first BEGIN of -d. */
 831           && (DBcv || (DBcv = GvCV(DBsub)))
 832            /* Try harder, since this may have been a sighandler, thus
 833             * curstash may be meaningless. */
 834           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
 835         op->op_private |= OPpENTERSUB_DB;
 836
 837     if (flags & G_EVAL) {
 838         Copy(top_env, oldtop, 1, Sigjmp_buf);
 839
 840         cLOGOP->op_other = op;
 841         markstack_ptr--;
 842         /* we're trying to emulate pp_entertry() here */
 843         {
 844             register CONTEXT *cx;
 845             I32 gimme = GIMME;
 846
 847             ENTER;
 848             SAVETMPS;
 849
 850             push_return(op->op_next);
 851             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
 852             PUSHEVAL(cx, 0, 0);
 853             eval_root = op;             /* Only needed so that goto works right. */
 854
 855             in_eval = 1;
 856             if (flags & G_KEEPERR)
 857                 in_eval |= 4;
 858             else
 859                 sv_setpv(GvSV(errgv),"");
 860         }
 861         markstack_ptr++;
 862
 863     restart:
 864         switch (Sigsetjmp(top_env,1)) {
 865         case 0:
 866             break;
 867         case 1:
 868 #ifdef VMS
 869             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
 870 #else
 871         statusvalue = 1;
 872 #endif
 873             /* FALL THROUGH */
 874         case 2:
 875             /* my_exit() was called */
 876             curstash = defstash;
 877             FREETMPS;
 878             Copy(oldtop, top_env, 1, Sigjmp_buf);
 879             if (statusvalue)
 880                 croak("Callback called exit");
 881             my_exit(statusvalue);
 882             /* NOTREACHED */
 883         case 3:
 884             if (restartop) {
 885                 op = restartop;
 886                 restartop = 0;
 887                 goto restart;
 888             }
 889             stack_sp = stack_base + oldmark;
 890             if (flags & G_ARRAY)
 891                 retval = 0;
 892             else {
 893                 retval = 1;
 894                 *++stack_sp = &sv_undef;
 895             }
 896             goto cleanup;
 897         }
 898     }
 899
 900     if (op == (OP*)&myop)
 901         op = pp_entersub();
 902     if (op)
 903         runops();
 904     retval = stack_sp - (stack_base + oldmark);
 905     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
 906         sv_setpv(GvSV(errgv),"");
 907
 908   cleanup:
 909     if (flags & G_EVAL) {
 910         if (scopestack_ix > oldscope) {
 911             SV **newsp;
 912             PMOP *newpm;
 913             I32 gimme;
 914             register CONTEXT *cx;
 915             I32 optype;
 916
 917             POPBLOCK(cx,newpm);
 918             POPEVAL(cx);
 919             pop_return();
 920             curpm = newpm;
 921             LEAVE;
 922         }
 923         Copy(oldtop, top_env, 1, Sigjmp_buf);
 924     }
 925     if (flags & G_DISCARD) {
 926         stack_sp = stack_base + oldmark;
 927         retval = 0;
 928         FREETMPS;
 929         LEAVE;
 930     }
 931     return retval;
 932 }
 933
 934 /* Eval a string. The G_EVAL flag is always assumed. */
 935
 936 I32
 937 perl_eval_sv(sv, flags)
 938 SV* sv;
 939 I32 flags;              /* See G_* flags in cop.h */
 940 {
 941     UNOP myop;          /* fake syntax tree node */
 942     SV** sp = stack_sp;
 943     I32 oldmark = sp - stack_base;
 944     I32 retval;
 945     Sigjmp_buf oldtop;
 946     I32 oldscope;
 947
 948     if (flags & G_DISCARD) {
 949         ENTER;
 950         SAVETMPS;
 951     }
 952
 953     SAVESPTR(op);
 954     op = (OP*)&myop;
 955     Zero(op, 1, UNOP);
 956     EXTEND(stack_sp, 1);
 957     *++stack_sp = sv;
 958     oldscope = scopestack_ix;
 959
 960     if (!(flags & G_NOARGS))
 961         myop.op_flags = OPf_STACKED;
 962     myop.op_next = Nullop;
 963     myop.op_type = OP_ENTEREVAL;
 964     myop.op_flags |= OPf_KNOW;
 965     if (flags & G_KEEPERR)
 966         myop.op_flags |= OPf_SPECIAL;
 967     if (flags & G_ARRAY)
 968         myop.op_flags |= OPf_LIST;
 969
 970     Copy(top_env, oldtop, 1, Sigjmp_buf);
 971
 972 restart:
 973     switch (Sigsetjmp(top_env,1)) {
 974     case 0:
 975         break;
 976     case 1:
 977 #ifdef VMS
 978         statusvalue = 255;      /* XXX I don't think we use 1 anymore. */
 979 #else
 980     statusvalue = 1;
 981 #endif
 982         /* FALL THROUGH */
 983     case 2:
 984         /* my_exit() was called */
 985         curstash = defstash;
 986         FREETMPS;
 987         Copy(oldtop, top_env, 1, Sigjmp_buf);
 988         if (statusvalue)
 989             croak("Callback called exit");
 990         my_exit(statusvalue);
 991         /* NOTREACHED */
 992     case 3:
 993         if (restartop) {
 994             op = restartop;
 995             restartop = 0;
 996             goto restart;
 997         }
 998         stack_sp = stack_base + oldmark;
 999         if (flags & G_ARRAY)
1000             retval = 0;
1001         else {
1002             retval = 1;
1003             *++stack_sp = &sv_undef;
1004         }
1005         goto cleanup;
1006     }
1007
1008     if (op == (OP*)&myop)
1009         op = pp_entereval();
1010     if (op)
1011         runops();
1012     retval = stack_sp - (stack_base + oldmark);
1013     if (!(flags & G_KEEPERR))
1014         sv_setpv(GvSV(errgv),"");
1015
1016   cleanup:
1017     Copy(oldtop, top_env, 1, Sigjmp_buf);
1018     if (flags & G_DISCARD) {
1019         stack_sp = stack_base + oldmark;
1020         retval = 0;
1021         FREETMPS;
1022         LEAVE;
1023     }
1024     return retval;
1025 }
1026
1027 /* Require a module. */
1028
1029 void
1030 perl_require_pv(pv)
1031 char* pv;
1032 {
1033     SV* sv = sv_newmortal();
1034     sv_setpv(sv, "require '");
1035     sv_catpv(sv, pv);
1036     sv_catpv(sv, "'");
1037     perl_eval_sv(sv, G_DISCARD);
1038 }
1039
1040 void
1041 magicname(sym,name,namlen)
1042 char *sym;
1043 char *name;
1044 I32 namlen;
1045 {
1046     register GV *gv;
1047
1048     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1049         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1050 }
1051
1052 #if defined(DOSISH)
1053 #    define PERLLIB_SEP ';'
1054 #else
1055 #  if defined(VMS)
1056 #    define PERLLIB_SEP '|'
1057 #  else
1058 #    define PERLLIB_SEP ':'
1059 #  endif
1060 #endif
1061 #ifndef PERLLIB_MANGLE
1062 #  define PERLLIB_MANGLE(s,n) (s)
1063 #endif
1064
1065 static void
1066 incpush(p)
1067 char *p;
1068 {
1069     char *s;
1070
1071     if (!p)
1072         return;
1073
1074     /* Break at all separators */
1075     while (*p) {
1076         /* First, skip any consecutive separators */
1077         while ( *p == PERLLIB_SEP ) {
1078             /* Uncomment the next line for PATH semantics */
1079             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1080             p++;
1081         }
1082         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1083             av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1084                                           (STRLEN)(s - p)));
1085             p = s + 1;
1086         } else {
1087             av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1088             break;
1089         }
1090     }
1091 }
1092
1093 static void
1094 usage(name)             /* XXX move this out into a module ? */
1095 char *name;
1096 {
1097     /* This message really ought to be max 23 lines.
1098      * Removed -h because the user already knows that opton. Others? */
1099     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1100     printf("\n  -0[octal]       specify record separator (\\0, if no argument)");
1101     printf("\n  -a              autosplit mode with -n or -p (splits $_ into @F)");
1102     printf("\n  -c              check syntax only (runs BEGIN and END blocks)");
1103     printf("\n  -d[:debugger]   run scripts under debugger");
1104     printf("\n  -D[number/list] set debugging flags (argument is a bit mask or flags)");
1105     printf("\n  -e 'command'    one line of script. Several -e's allowed. Omit [programfile].");
1106     printf("\n  -F/pattern/     split() pattern for autosplit (-a). The //'s are optional.");
1107     printf("\n  -i[extension]   edit <> files in place (make backup if extension supplied)");
1108     printf("\n  -Idirectory     specify @INC/#include directory (may be used more then once)");
1109     printf("\n  -l[octal]       enable line ending processing, specifies line teminator");
1110     printf("\n  -[mM][-]module.. executes `use/no module...' before executing your script.");
1111     printf("\n  -n              assume 'while (<>) { ... }' loop arround your script");
1112     printf("\n  -p              assume loop like -n but print line also like sed");
1113     printf("\n  -P              run script through C preprocessor before compilation");
1114     printf("\n  -s              enable some switch parsing for switches after script name");
1115     printf("\n  -S              look for the script using PATH environment variable");
1116     printf("\n  -T              turn on tainting checks");
1117     printf("\n  -u              dump core after parsing script");
1118     printf("\n  -U              allow unsafe operations");
1119     printf("\n  -v              print version number and patchlevel of perl");
1120     printf("\n  -V[:variable]   print perl configuration information");
1121     printf("\n  -w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1122     printf("\n  -x[directory]   strip off text before #!perl line and perhaps cd to directory\n");
1123 }
1124
1125 /* This routine handles any switches that can be given during run */
1126
1127 char *
1128 moreswitches(s)
1129 char *s;
1130 {
1131     I32 numlen;
1132     U32 rschar;
1133
1134     switch (*s) {
1135     case '0':
1136         rschar = scan_oct(s, 4, &numlen);
1137         SvREFCNT_dec(nrs);
1138         if (rschar & ~((U8)~0))
1139             nrs = &sv_undef;
1140         else if (!rschar && numlen >= 2)
1141             nrs = newSVpv("", 0);
1142         else {
1143             char ch = rschar;
1144             nrs = newSVpv(&ch, 1);
1145         }
1146         return s + numlen;
1147     case 'F':
1148         minus_F = TRUE;
1149         splitstr = savepv(s + 1);
1150         s += strlen(s);
1151         return s;
1152     case 'a':
1153         minus_a = TRUE;
1154         s++;
1155         return s;
1156     case 'c':
1157         minus_c = TRUE;
1158         s++;
1159         return s;
1160     case 'd':
1161         forbid_setid("-d");
1162         s++;
1163         if (*s == ':' || *s == '=')  {
1164             sprintf(buf, "use Devel::%s;", ++s);
1165             s += strlen(s);
1166             my_setenv("PERL5DB",buf);
1167         }
1168         if (!perldb) {
1169             perldb = TRUE;
1170             init_debugger();
1171         }
1172         return s;
1173     case 'D':
1174 #ifdef DEBUGGING
1175         forbid_setid("-D");
1176         if (isALPHA(s[1])) {
1177             static char debopts[] = "psltocPmfrxuLHXD";
1178             char *d;
1179
1180             for (s++; *s && (d = strchr(debopts,*s)); s++)
1181                 debug |= 1 << (d - debopts);
1182         }
1183         else {
1184             debug = atoi(s+1);
1185             for (s++; isDIGIT(*s); s++) ;
1186         }
1187         debug |= 0x80000000;
1188 #else
1189         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1190         for (s++; isALNUM(*s); s++) ;
1191 #endif
1192         /*SUPPRESS 530*/
1193         return s;
1194     case 'h':
1195         usage(origargv[0]);
1196         exit(0);
1197     case 'i':
1198         if (inplace)
1199             Safefree(inplace);
1200         inplace = savepv(s+1);
1201         /*SUPPRESS 530*/
1202         for (s = inplace; *s && !isSPACE(*s); s++) ;
1203         *s = '\0';
1204         break;
1205     case 'I':
1206         forbid_setid("-I");
1207         if (*++s) {
1208             char *e;
1209             for (e = s; *e && !isSPACE(*e); e++) ;
1210             av_push(GvAVn(incgv),newSVpv(s,e-s));
1211             if (*e)
1212                 return e;
1213         }
1214         else
1215             croak("No space allowed after -I");
1216         break;
1217     case 'l':
1218         minus_l = TRUE;
1219         s++;
1220         if (ors)
1221             Safefree(ors);
1222         if (isDIGIT(*s)) {
1223             ors = savepv("\n");
1224             orslen = 1;
1225             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1226             s += numlen;
1227         }
1228         else {
1229             if (RsPARA(nrs)) {
1230                 ors = "\n\n";
1231                 orslen = 2;
1232             }
1233             else
1234                 ors = SvPV(nrs, orslen);
1235             ors = savepvn(ors, orslen);
1236         }
1237         return s;
1238     case 'M':
1239         forbid_setid("-M");     /* XXX ? */
1240         /* FALL THROUGH */
1241     case 'm':
1242         forbid_setid("-m");     /* XXX ? */
1243         if (*++s) {
1244             char *start;
1245             char *use = "use ";
1246             /* -M-foo == 'no foo'       */
1247             if (*s == '-') { use = "no "; ++s; }
1248             Sv = newSVpv(use,0);
1249             start = s;
1250             /* We allow -M'Module qw(Foo Bar)'  */
1251             while(isALNUM(*s) || *s==':') ++s;
1252             if (*s != '=') {
1253                 sv_catpv(Sv, start);
1254                 if (*(start-1) == 'm') {
1255                     if (*s != '\0')
1256                         croak("Can't use '%c' after -mname", *s);
1257                     sv_catpv( Sv, " ()");
1258                 }
1259             } else {
1260                 sv_catpvn(Sv, start, s-start);
1261                 sv_catpv(Sv, " split(/,/,q{");
1262                 sv_catpv(Sv, ++s);
1263                 sv_catpv(Sv,    "})");
1264             }
1265             s += strlen(s);
1266             if (preambleav == NULL)
1267                 preambleav = newAV();
1268             av_push(preambleav, Sv);
1269         }
1270         else
1271             croak("No space allowed after -%c", *(s-1));
1272         return s;
1273     case 'n':
1274         minus_n = TRUE;
1275         s++;
1276         return s;
1277     case 'p':
1278         minus_p = TRUE;
1279         s++;
1280         return s;
1281     case 's':
1282         forbid_setid("-s");
1283         doswitches = TRUE;
1284         s++;
1285         return s;
1286     case 'T':
1287         tainting = TRUE;
1288         s++;
1289         return s;
1290     case 'u':
1291         do_undump = TRUE;
1292         s++;
1293         return s;
1294     case 'U':
1295         unsafe = TRUE;
1296         s++;
1297         return s;
1298     case 'v':
1299 #if defined(SUBVERSION) && SUBVERSION > 0
1300         printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1301 #else
1302         printf("\nThis is perl, version %s",patchlevel);
1303 #endif
1304
1305         printf("\n\nCopyright 1987-1996, Larry Wall\n");
1306         printf("\n\t+ suidperl security patch");
1307 #ifdef MSDOS
1308         printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1309 #endif
1310 #ifdef DJGPP
1311         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1312 #endif
1313 #ifdef OS2
1314         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1315             "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1316 #endif
1317 #ifdef atarist
1318         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1319 #endif
1320         printf("\n\
1321 Perl may be copied only under the terms of either the Artistic License or the\n\
1322 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1323         exit(0);
1324     case 'w':
1325         dowarn = TRUE;
1326         s++;
1327         return s;
1328     case '*':
1329     case ' ':
1330         if (s[1] == '-')        /* Additional switches on #! line. */
1331             return s+2;
1332         break;
1333     case '-':
1334     case 0:
1335     case '\n':
1336     case '\t':
1337         break;
1338     case 'P':
1339         if (preprocess)
1340             return s+1;
1341         /* FALL THROUGH */
1342     default:
1343         croak("Can't emulate -%.1s on #! line",s);
1344     }
1345     return Nullch;
1346 }
1347
1348 /* compliments of Tom Christiansen */
1349
1350 /* unexec() can be found in the Gnu emacs distribution */
1351
1352 void
1353 my_unexec()
1354 {
1355 #ifdef UNEXEC
1356     int    status;
1357     extern int etext;
1358
1359     sprintf (buf, "%s.perldump", origfilename);
1360     sprintf (tokenbuf, "%s/perl", BIN);
1361
1362     status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1363     if (status)
1364         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1365     exit(status);
1366 #else
1367 #  ifdef VMS
1368 #    include <lib$routines.h>
1369      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1370 #else
1371     ABORT();            /* for use with undump */
1372 #endif
1373 #endif
1374 }
1375
1376 static void
1377 init_main_stash()
1378 {
1379     GV *gv;
1380
1381     /* Note that strtab is a rather special HV.  Assumptions are made
1382        about not iterating on it, and not adding tie magic to it.
1383        It is properly deallocated in perl_destruct() */
1384     strtab = newHV();
1385     HvSHAREKEYS_off(strtab);                    /* mandatory */
1386     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1387          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1388
1389     curstash = defstash = newHV();
1390     curstname = newSVpv("main",4);
1391     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1392     SvREFCNT_dec(GvHV(gv));
1393     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1394     SvREADONLY_on(gv);
1395     HvNAME(defstash) = savepv("main");
1396     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1397     GvMULTI_on(incgv);
1398     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1399     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1400     GvMULTI_on(errgv);
1401     sv_setpvn(GvSV(errgv), "", 0);
1402     curstash = defstash;
1403     compiling.cop_stash = defstash;
1404     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1405     /* We must init $/ before switches are processed. */
1406     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1407 }
1408
1409 #ifdef CAN_PROTOTYPE
1410 static void
1411 open_script(char *scriptname, bool dosearch, SV *sv)
1412 #else
1413 static void
1414 open_script(scriptname,dosearch,sv)
1415 char *scriptname;
1416 bool dosearch;
1417 SV *sv;
1418 #endif
1419 {
1420     char *xfound = Nullch;
1421     char *xfailed = Nullch;
1422     register char *s;
1423     I32 len;
1424     int retval;
1425 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1426 #define SEARCH_EXTS ".bat", ".cmd", NULL
1427 #endif
1428 #ifdef VMS
1429 #  define SEARCH_EXTS ".pl", ".com", NULL
1430 #endif
1431     /* additional extensions to try in each dir if scriptname not found */
1432 #ifdef SEARCH_EXTS
1433     char *ext[] = { SEARCH_EXTS };
1434     int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1435 #endif
1436
1437 #ifdef VMS
1438     if (dosearch) {
1439         int hasdir, idx = 0, deftypes = 1;
1440
1441         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1442         /* The first time through, just add SEARCH_EXTS to whatever we
1443          * already have, so we can check for default file types. */
1444         while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1445             if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1446             strcat(tokenbuf,scriptname);
1447 #else  /* !VMS */
1448     if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1449
1450         bufend = s + strlen(s);
1451         while (*s) {
1452 #ifndef DOSISH
1453             s = cpytill(tokenbuf,s,bufend,':',&len);
1454 #else
1455 #ifdef atarist
1456             for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1457             tokenbuf[len] = '\0';
1458 #else
1459             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1460             tokenbuf[len] = '\0';
1461 #endif
1462 #endif
1463             if (*s)
1464                 s++;
1465 #ifndef DOSISH
1466             if (len && tokenbuf[len-1] != '/')
1467 #else
1468 #ifdef atarist
1469             if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1470 #else
1471             if (len && tokenbuf[len-1] != '\\')
1472 #endif
1473 #endif
1474                 (void)strcat(tokenbuf+len,"/");
1475             (void)strcat(tokenbuf+len,scriptname);
1476 #endif  /* !VMS */
1477
1478 #ifdef SEARCH_EXTS
1479             len = strlen(tokenbuf);
1480             if (extidx > 0)     /* reset after previous loop */
1481                 extidx = 0;
1482             do {
1483 #endif
1484                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1485                 retval = Stat(tokenbuf,&statbuf);
1486 #ifdef SEARCH_EXTS
1487             } while (  retval < 0               /* not there */
1488                     && extidx>=0 && ext[extidx] /* try an extension? */
1489                     && strcpy(tokenbuf+len, ext[extidx++])
1490                 );
1491 #endif
1492             if (retval < 0)
1493                 continue;
1494             if (S_ISREG(statbuf.st_mode)
1495              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1496                 xfound = tokenbuf;              /* bingo! */
1497                 break;
1498             }
1499             if (!xfailed)
1500                 xfailed = savepv(tokenbuf);
1501         }
1502         if (!xfound)
1503             croak("Can't execute %s", xfailed ? xfailed : scriptname );
1504         if (xfailed)
1505             Safefree(xfailed);
1506         scriptname = xfound;
1507     }
1508
1509     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1510         char *s = scriptname + 8;
1511         fdscript = atoi(s);
1512         while (isDIGIT(*s))
1513             s++;
1514         if (*s)
1515             scriptname = s + 1;
1516     }
1517     else
1518         fdscript = -1;
1519     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1520     curcop->cop_filegv = gv_fetchfile(origfilename);
1521     if (strEQ(origfilename,"-"))
1522         scriptname = "";
1523     if (fdscript >= 0) {
1524         rsfp = PerlIO_fdopen(fdscript,"r");
1525 #if defined(HAS_FCNTL) && defined(F_SETFD)
1526         if (rsfp)
1527             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1528 #endif
1529     }
1530     else if (preprocess) {
1531         char *cpp = CPPSTDIN;
1532
1533         if (strEQ(cpp,"cppstdin"))
1534             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1535         else
1536             sprintf(tokenbuf, "%s", cpp);
1537         sv_catpv(sv,"-I");
1538         sv_catpv(sv,PRIVLIB_EXP);
1539 #ifdef MSDOS
1540         (void)sprintf(buf, "\
1541 sed %s -e \"/^[^#]/b\" \
1542  -e \"/^#[      ]*include[      ]/b\" \
1543  -e \"/^#[      ]*define[       ]/b\" \
1544  -e \"/^#[      ]*if[   ]/b\" \
1545  -e \"/^#[      ]*ifdef[        ]/b\" \
1546  -e \"/^#[      ]*ifndef[       ]/b\" \
1547  -e \"/^#[      ]*else/b\" \
1548  -e \"/^#[      ]*elif[         ]/b\" \
1549  -e \"/^#[      ]*undef[        ]/b\" \
1550  -e \"/^#[      ]*endif/b\" \
1551  -e \"s/^#.*//\" \
1552  %s | %s -C %s %s",
1553           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1554 #else
1555         (void)sprintf(buf, "\
1556 %s %s -e '/^[^#]/b' \
1557  -e '/^#[       ]*include[      ]/b' \
1558  -e '/^#[       ]*define[       ]/b' \
1559  -e '/^#[       ]*if[   ]/b' \
1560  -e '/^#[       ]*ifdef[        ]/b' \
1561  -e '/^#[       ]*ifndef[       ]/b' \
1562  -e '/^#[       ]*else/b' \
1563  -e '/^#[       ]*elif[         ]/b' \
1564  -e '/^#[       ]*undef[        ]/b' \
1565  -e '/^#[       ]*endif/b' \
1566  -e 's/^[       ]*#.*//' \
1567  %s | %s -C %s %s",
1568 #ifdef LOC_SED
1569           LOC_SED,
1570 #else
1571           "sed",
1572 #endif
1573           (doextract ? "-e '1,/^#/d\n'" : ""),
1574 #endif
1575           scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1576         doextract = FALSE;
1577 #ifdef IAMSUID                          /* actually, this is caught earlier */
1578         if (euid != uid && !euid) {     /* if running suidperl */
1579 #ifdef HAS_SETEUID
1580             (void)seteuid(uid);         /* musn't stay setuid root */
1581 #else
1582 #ifdef HAS_SETREUID
1583             (void)setreuid((Uid_t)-1, uid);
1584 #else
1585 #ifdef HAS_SETRESUID
1586             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1587 #else
1588             setuid(uid);
1589 #endif
1590 #endif
1591 #endif
1592             if (geteuid() != uid)
1593                 croak("Can't do seteuid!\n");
1594         }
1595 #endif /* IAMSUID */
1596         rsfp = my_popen(buf,"r");
1597     }
1598     else if (!*scriptname) {
1599         forbid_setid("program input from stdin");
1600         rsfp = PerlIO_stdin();
1601     }
1602     else {
1603         rsfp = PerlIO_open(scriptname,"r");
1604 #if defined(HAS_FCNTL) && defined(F_SETFD)
1605         if (rsfp)
1606             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1607 #endif
1608     }
1609     if (e_tmpname) {
1610         e_fp = rsfp;
1611     }
1612     if (!rsfp) {
1613 #ifdef DOSUID
1614 #ifndef IAMSUID         /* in case script is not readable before setuid */
1615         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1616           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1617             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1618             execv(buf, origargv);       /* try again */
1619             croak("Can't do setuid\n");
1620         }
1621 #endif
1622 #endif
1623         croak("Can't open perl script \"%s\": %s\n",
1624           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1625     }
1626 }
1627
1628 static void
1629 validate_suid(validarg, scriptname)
1630 char *validarg;
1631 char *scriptname;
1632 {
1633     int which;
1634
1635     /* do we need to emulate setuid on scripts? */
1636
1637     /* This code is for those BSD systems that have setuid #! scripts disabled
1638      * in the kernel because of a security problem.  Merely defining DOSUID
1639      * in perl will not fix that problem, but if you have disabled setuid
1640      * scripts in the kernel, this will attempt to emulate setuid and setgid
1641      * on scripts that have those now-otherwise-useless bits set.  The setuid
1642      * root version must be called suidperl or sperlN.NNN.  If regular perl
1643      * discovers that it has opened a setuid script, it calls suidperl with
1644      * the same argv that it had.  If suidperl finds that the script it has
1645      * just opened is NOT setuid root, it sets the effective uid back to the
1646      * uid.  We don't just make perl setuid root because that loses the
1647      * effective uid we had before invoking perl, if it was different from the
1648      * uid.
1649      *
1650      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1651      * be defined in suidperl only.  suidperl must be setuid root.  The
1652      * Configure script will set this up for you if you want it.
1653      */
1654
1655 #ifdef DOSUID
1656     char *s, *s2;
1657
1658     if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
1659         croak("Can't stat script \"%s\"",origfilename);
1660     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1661         I32 len;
1662
1663 #ifdef IAMSUID
1664 #ifndef HAS_SETREUID
1665         /* On this access check to make sure the directories are readable,
1666          * there is actually a small window that the user could use to make
1667          * filename point to an accessible directory.  So there is a faint
1668          * chance that someone could execute a setuid script down in a
1669          * non-accessible directory.  I don't know what to do about that.
1670          * But I don't think it's too important.  The manual lies when
1671          * it says access() is useful in setuid programs.
1672          */
1673         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1674             croak("Permission denied");
1675 #else
1676         /* If we can swap euid and uid, then we can determine access rights
1677          * with a simple stat of the file, and then compare device and
1678          * inode to make sure we did stat() on the same file we opened.
1679          * Then we just have to make sure he or she can execute it.
1680          */
1681         {
1682             struct stat tmpstatbuf;
1683
1684             if (
1685 #ifdef HAS_SETREUID
1686                 setreuid(euid,uid) < 0
1687 #else
1688 # if HAS_SETRESUID
1689                 setresuid(euid,uid,(Uid_t)-1) < 0
1690 # endif
1691 #endif
1692                 || getuid() != euid || geteuid() != uid)
1693                 croak("Can't swap uid and euid");       /* really paranoid */
1694             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1695                 croak("Permission denied");     /* testing full pathname here */
1696             if (tmpstatbuf.st_dev != statbuf.st_dev ||
1697                 tmpstatbuf.st_ino != statbuf.st_ino) {
1698                 (void)PerlIO_close(rsfp);
1699                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
1700                     PerlIO_printf(rsfp,
1701 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1702 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1703                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1704                         statbuf.st_dev, statbuf.st_ino,
1705                         SvPVX(GvSV(curcop->cop_filegv)),
1706                         statbuf.st_uid, statbuf.st_gid);
1707                     (void)my_pclose(rsfp);
1708                 }
1709                 croak("Permission denied\n");
1710             }
1711             if (
1712 #ifdef HAS_SETREUID
1713               setreuid(uid,euid) < 0
1714 #else
1715 # if defined(HAS_SETRESUID)
1716               setresuid(uid,euid,(Uid_t)-1) < 0
1717 # endif
1718 #endif
1719               || getuid() != uid || geteuid() != euid)
1720                 croak("Can't reswap uid and euid");
1721             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
1722                 croak("Permission denied\n");
1723         }
1724 #endif /* HAS_SETREUID */
1725 #endif /* IAMSUID */
1726
1727         if (!S_ISREG(statbuf.st_mode))
1728             croak("Permission denied");
1729         if (statbuf.st_mode & S_IWOTH)
1730             croak("Setuid/gid script is writable by world");
1731         doswitches = FALSE;             /* -s is insecure in suid */
1732         curcop->cop_line++;
1733         if (sv_gets(linestr, rsfp, 0) == Nullch ||
1734           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
1735             croak("No #! line");
1736         s = SvPV(linestr,na)+2;
1737         if (*s == ' ') s++;
1738         while (!isSPACE(*s)) s++;
1739         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
1740                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
1741         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1742             croak("Not a perl script");
1743         while (*s == ' ' || *s == '\t') s++;
1744         /*
1745          * #! arg must be what we saw above.  They can invoke it by
1746          * mentioning suidperl explicitly, but they may not add any strange
1747          * arguments beyond what #! says if they do invoke suidperl that way.
1748          */
1749         len = strlen(validarg);
1750         if (strEQ(validarg," PHOOEY ") ||
1751             strnNE(s,validarg,len) || !isSPACE(s[len]))
1752             croak("Args must match #! line");
1753
1754 #ifndef IAMSUID
1755         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1756             euid == statbuf.st_uid)
1757             if (!do_undump)
1758                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1759 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1760 #endif /* IAMSUID */
1761
1762         if (euid) {     /* oops, we're not the setuid root perl */
1763             (void)PerlIO_close(rsfp);
1764 #ifndef IAMSUID
1765             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1766             execv(buf, origargv);       /* try again */
1767 #endif
1768             croak("Can't do setuid\n");
1769         }
1770
1771         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1772 #ifdef HAS_SETEGID
1773             (void)setegid(statbuf.st_gid);
1774 #else
1775 #ifdef HAS_SETREGID
1776            (void)setregid((Gid_t)-1,statbuf.st_gid);
1777 #else
1778 #ifdef HAS_SETRESGID
1779            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1780 #else
1781             setgid(statbuf.st_gid);
1782 #endif
1783 #endif
1784 #endif
1785             if (getegid() != statbuf.st_gid)
1786                 croak("Can't do setegid!\n");
1787         }
1788         if (statbuf.st_mode & S_ISUID) {
1789             if (statbuf.st_uid != euid)
1790 #ifdef HAS_SETEUID
1791                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1792 #else
1793 #ifdef HAS_SETREUID
1794                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1795 #else
1796 #ifdef HAS_SETRESUID
1797                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1798 #else
1799                 setuid(statbuf.st_uid);
1800 #endif
1801 #endif
1802 #endif
1803             if (geteuid() != statbuf.st_uid)
1804                 croak("Can't do seteuid!\n");
1805         }
1806         else if (uid) {                 /* oops, mustn't run as root */
1807 #ifdef HAS_SETEUID
1808           (void)seteuid((Uid_t)uid);
1809 #else
1810 #ifdef HAS_SETREUID
1811           (void)setreuid((Uid_t)-1,(Uid_t)uid);
1812 #else
1813 #ifdef HAS_SETRESUID
1814           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1815 #else
1816           setuid((Uid_t)uid);
1817 #endif
1818 #endif
1819 #endif
1820             if (geteuid() != uid)
1821                 croak("Can't do seteuid!\n");
1822         }
1823         init_ids();
1824         if (!cando(S_IXUSR,TRUE,&statbuf))
1825             croak("Permission denied\n");       /* they can't do this */
1826     }
1827 #ifdef IAMSUID
1828     else if (preprocess)
1829         croak("-P not allowed for setuid/setgid script\n");
1830     else if (fdscript >= 0)
1831         croak("fd script not allowed in suidperl\n");
1832     else
1833         croak("Script is not setuid/setgid in suidperl\n");
1834
1835     /* We absolutely must clear out any saved ids here, so we */
1836     /* exec the real perl, substituting fd script for scriptname. */
1837     /* (We pass script name as "subdir" of fd, which perl will grok.) */
1838     PerlIO_rewind(rsfp);
1839     lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
1840     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1841     if (!origargv[which])
1842         croak("Permission denied");
1843     (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1844     origargv[which] = buf;
1845
1846 #if defined(HAS_FCNTL) && defined(F_SETFD)
1847     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
1848 #endif
1849
1850     (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1851     execv(tokenbuf, origargv);  /* try again */
1852     croak("Can't do setuid\n");
1853 #endif /* IAMSUID */
1854 #else /* !DOSUID */
1855     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1856 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1857         Fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
1858         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1859             ||
1860             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1861            )
1862             if (!do_undump)
1863                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1864 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1865 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1866         /* not set-id, must be wrapped */
1867     }
1868 #endif /* DOSUID */
1869 }
1870
1871 static void
1872 find_beginning()
1873 {
1874     register char *s, *s2;
1875
1876     /* skip forward in input to the real script? */
1877
1878     forbid_setid("-x");
1879     while (doextract) {
1880         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1881             croak("No Perl script found in input\n");
1882         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1883             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
1884             doextract = FALSE;
1885             while (*s && !(isSPACE (*s) || *s == '#')) s++;
1886             s2 = s;
1887             while (*s == ' ' || *s == '\t') s++;
1888             if (*s++ == '-') {
1889                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1890                 if (strnEQ(s2-4,"perl",4))
1891                     /*SUPPRESS 530*/
1892                     while (s = moreswitches(s)) ;
1893             }
1894             if (cddir && chdir(cddir) < 0)
1895                 croak("Can't chdir to %s",cddir);
1896         }
1897     }
1898 }
1899
1900 static void
1901 init_ids()
1902 {
1903     uid = (int)getuid();
1904     euid = (int)geteuid();
1905     gid = (int)getgid();
1906     egid = (int)getegid();
1907 #ifdef VMS
1908     uid |= gid << 16;
1909     euid |= egid << 16;
1910 #endif
1911     tainting |= (uid && (euid != uid || egid != gid));
1912 }
1913
1914 static void
1915 forbid_setid(s)
1916 char *s;
1917 {
1918     if (euid != uid)
1919         croak("No %s allowed while running setuid", s);
1920     if (egid != gid)
1921         croak("No %s allowed while running setgid", s);
1922 }
1923
1924 static void
1925 init_debugger()
1926 {
1927     curstash = debstash;
1928     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1929     AvREAL_off(dbargs);
1930     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1931     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1932     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1933     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1934     sv_setiv(DBsingle, 0);
1935     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1936     sv_setiv(DBtrace, 0);
1937     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1938     sv_setiv(DBsignal, 0);
1939     curstash = defstash;
1940 }
1941
1942 static void
1943 init_stacks()
1944 {
1945     curstack = newAV();
1946     mainstack = curstack;                       /* remember in case we switch stacks */
1947     AvREAL_off(curstack);                       /* not a real array */
1948     av_extend(curstack,127);
1949
1950     stack_base = AvARRAY(curstack);
1951     stack_sp = stack_base;
1952     stack_max = stack_base + 127;
1953
1954     /* Shouldn't these stacks be per-interpreter? */
1955     if (markstack) {
1956         markstack_ptr = markstack;
1957     } else {
1958         New(54,markstack,64,I32);
1959         markstack_ptr = markstack;
1960         markstack_max = markstack + 64;
1961     }
1962
1963     if (scopestack) {
1964         scopestack_ix = 0;
1965     } else {
1966         New(54,scopestack,32,I32);
1967         scopestack_ix = 0;
1968         scopestack_max = 32;
1969     }
1970
1971     if (savestack) {
1972         savestack_ix = 0;
1973     } else {
1974         New(54,savestack,128,ANY);
1975         savestack_ix = 0;
1976         savestack_max = 128;
1977     }
1978
1979     if (retstack) {
1980         retstack_ix = 0;
1981     } else {
1982         New(54,retstack,16,OP*);
1983         retstack_ix = 0;
1984         retstack_max = 16;
1985    }
1986
1987     cxstack_max = 8192 / sizeof(CONTEXT) - 2;   /* Use most of 8K. */
1988     New(50,cxstack,cxstack_max + 1,CONTEXT);
1989     cxstack_ix  = -1;
1990
1991     New(50,tmps_stack,128,SV*);
1992     tmps_ix = -1;
1993     tmps_max = 128;
1994
1995     DEBUG( {
1996         New(51,debname,128,char);
1997         New(52,debdelim,128,char);
1998     } )
1999 }
2000
2001 static void
2002 nuke_stacks()
2003 {
2004     Safefree(cxstack);
2005     Safefree(tmps_stack);
2006 }
2007
2008 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2009
2010 static void
2011 init_lexer()
2012 {
2013     tmpfp = rsfp;
2014     lex_start(linestr);
2015     rsfp = tmpfp;
2016     subname = newSVpv("main",4);
2017 }
2018
2019 static void
2020 init_predump_symbols()
2021 {
2022     GV *tmpgv;
2023     GV *othergv;
2024
2025     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2026
2027     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2028     GvMULTI_on(stdingv);
2029     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2030     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2031     GvMULTI_on(tmpgv);
2032     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2033
2034     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2035     GvMULTI_on(tmpgv);
2036     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2037     setdefout(tmpgv);
2038     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2039     GvMULTI_on(tmpgv);
2040     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2041
2042     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2043     GvMULTI_on(othergv);
2044     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2045     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2046     GvMULTI_on(tmpgv);
2047     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2048
2049     statname = NEWSV(66,0);             /* last filename we did stat on */
2050
2051     if (!osname)
2052         osname = savepv(OSNAME);
2053 }
2054
2055 static void
2056 init_postdump_symbols(argc,argv,env)
2057 register int argc;
2058 register char **argv;
2059 register char **env;
2060 {
2061     char *s;
2062     SV *sv;
2063     GV* tmpgv;
2064
2065     argc--,argv++;      /* skip name of script */
2066     if (doswitches) {
2067         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2068             if (!argv[0][1])
2069                 break;
2070             if (argv[0][1] == '-') {
2071                 argc--,argv++;
2072                 break;
2073             }
2074             if (s = strchr(argv[0], '=')) {
2075                 *s++ = '\0';
2076                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2077             }
2078             else
2079                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2080         }
2081     }
2082     toptarget = NEWSV(0,0);
2083     sv_upgrade(toptarget, SVt_PVFM);
2084     sv_setpvn(toptarget, "", 0);
2085     bodytarget = NEWSV(0,0);
2086     sv_upgrade(bodytarget, SVt_PVFM);
2087     sv_setpvn(bodytarget, "", 0);
2088     formtarget = bodytarget;
2089
2090     TAINT;
2091     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2092         sv_setpv(GvSV(tmpgv),origfilename);
2093         magicname("0", "0", 1);
2094     }
2095     if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2096         time(&basetime);
2097     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2098         sv_setpv(GvSV(tmpgv),origargv[0]);
2099     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2100         GvMULTI_on(argvgv);
2101         (void)gv_AVadd(argvgv);
2102         av_clear(GvAVn(argvgv));
2103         for (; argc > 0; argc--,argv++) {
2104             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2105         }
2106     }
2107     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2108         HV *hv;
2109         GvMULTI_on(envgv);
2110         hv = GvHVn(envgv);
2111         hv_clear(hv);
2112 #ifndef VMS  /* VMS doesn't have environ array */
2113         /* Note that if the supplied env parameter is actually a copy
2114            of the global environ then it may now point to free'd memory
2115            if the environment has been modified since. To avoid this
2116            problem we treat env==NULL as meaning 'use the default'
2117         */
2118         if (!env)
2119             env = environ;
2120         if (env != environ) {
2121             environ[0] = Nullch;
2122             hv_magic(hv, envgv, 'E');
2123         }
2124         for (; *env; env++) {
2125             if (!(s = strchr(*env,'=')))
2126                 continue;
2127             *s++ = '\0';
2128             sv = newSVpv(s--,0);
2129             sv_magic(sv, sv, 'e', *env, s - *env);
2130             (void)hv_store(hv, *env, s - *env, sv, 0);
2131             *s = '=';
2132         }
2133 #endif
2134 #ifdef DYNAMIC_ENV_FETCH
2135         HvNAME(hv) = savepv(ENV_HV_NAME);
2136 #endif
2137         hv_magic(hv, envgv, 'E');
2138     }
2139     TAINT_NOT;
2140     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2141         sv_setiv(GvSV(tmpgv),(I32)getpid());
2142 }
2143
2144 static void
2145 init_perllib()
2146 {
2147     char *s;
2148     if (!tainting) {
2149 #ifndef VMS
2150         s = getenv("PERL5LIB");
2151         if (s)
2152             incpush(s);
2153         else
2154             incpush(getenv("PERLLIB"));
2155 #else /* VMS */
2156         /* Treat PERL5?LIB as a possible search list logical name -- the
2157          * "natural" VMS idiom for a Unix path string.  We allow each
2158          * element to be a set of |-separated directories for compatibility.
2159          */
2160         char buf[256];
2161         int idx = 0;
2162         if (my_trnlnm("PERL5LIB",buf,0))
2163             do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2164         else
2165             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2166 #endif /* VMS */
2167     }
2168
2169 /* Use the ~-expanded versions of APPLIB (undocumented),
2170     ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2171 */
2172 #ifdef APPLLIB_EXP
2173     incpush(APPLLIB_EXP);
2174 #endif
2175
2176 #ifdef ARCHLIB_EXP
2177     incpush(ARCHLIB_EXP);
2178 #endif
2179 #ifndef PRIVLIB_EXP
2180 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2181 #endif
2182     incpush(PRIVLIB_EXP);
2183
2184 #ifdef SITEARCH_EXP
2185     incpush(SITEARCH_EXP);
2186 #endif
2187 #ifdef SITELIB_EXP
2188     incpush(SITELIB_EXP);
2189 #endif
2190 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2191     incpush(OLDARCHLIB_EXP);
2192 #endif
2193
2194     if (!tainting)
2195         incpush(".");
2196 }
2197
2198 void
2199 calllist(list)
2200 AV* list;
2201 {
2202     Sigjmp_buf oldtop;
2203     STRLEN len;
2204     line_t oldline = curcop->cop_line;
2205
2206     Copy(top_env, oldtop, 1, Sigjmp_buf);
2207
2208     while (AvFILL(list) >= 0) {
2209         CV *cv = (CV*)av_shift(list);
2210
2211         SAVEFREESV(cv);
2212
2213         switch (Sigsetjmp(top_env,1)) {
2214         case 0: {
2215                 SV* atsv = GvSV(errgv);
2216                 PUSHMARK(stack_sp);
2217                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2218                 (void)SvPV(atsv, len);
2219                 if (len) {
2220                     Copy(oldtop, top_env, 1, Sigjmp_buf);
2221                     curcop = &compiling;
2222                     curcop->cop_line = oldline;
2223                     if (list == beginav)
2224                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2225                     else
2226                         sv_catpv(atsv, "END failed--cleanup aborted");
2227                     croak("%s", SvPVX(atsv));
2228                 }
2229             }
2230             break;
2231         case 1:
2232 #ifdef VMS
2233             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
2234 #else
2235         statusvalue = 1;
2236 #endif
2237             /* FALL THROUGH */
2238         case 2:
2239             /* my_exit() was called */
2240             curstash = defstash;
2241             if (endav)
2242                 calllist(endav);
2243             FREETMPS;
2244             Copy(oldtop, top_env, 1, Sigjmp_buf);
2245             curcop = &compiling;
2246             curcop->cop_line = oldline;
2247             if (statusvalue) {
2248                 if (list == beginav)
2249                     croak("BEGIN failed--compilation aborted");
2250                 else
2251                     croak("END failed--cleanup aborted");
2252             }
2253             my_exit(statusvalue);
2254             /* NOTREACHED */
2255             return;
2256         case 3:
2257             if (!restartop) {
2258                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2259                 FREETMPS;
2260                 break;
2261             }
2262             Copy(oldtop, top_env, 1, Sigjmp_buf);
2263             curcop = &compiling;
2264             curcop->cop_line = oldline;
2265             Siglongjmp(top_env, 3);
2266         }
2267     }
2268
2269     Copy(oldtop, top_env, 1, Sigjmp_buf);
2270 }
2271