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