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