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