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