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