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