perl.c

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