perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (c) 1987-1998 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 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
  24 char *getenv _((char *)); /* Usually in <stdlib.h> */
  25 #endif
  26
  27 #ifdef I_FCNTL
  28 #include <fcntl.h>
  29 #endif
  30 #ifdef I_SYS_FILE
  31 #include <sys/file.h>
  32 #endif
  33
  34 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
  35
  36 #ifdef IAMSUID
  37 #ifndef DOSUID
  38 #define DOSUID
  39 #endif
  40 #endif
  41
  42 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  43 #ifdef DOSUID
  44 #undef DOSUID
  45 #endif
  46 #endif
  47
  48 #define I_REINIT \
  49   STMT_START {                  \
  50     chopset     = " \n-";       \
  51     copline     = NOLINE;       \
  52     curcop      = &compiling;   \
  53     curcopdb    = NULL;         \
  54     cxstack_ix  = -1;           \
  55     cxstack_max = 128;          \
  56     dbargs      = 0;            \
  57     dlmax       = 128;          \
  58     laststatval = -1;           \
  59     laststype   = OP_STAT;      \
  60     maxscream   = -1;           \
  61     maxsysfd    = MAXSYSFD;     \
  62     statname    = Nullsv;       \
  63     tmps_floor  = -1;           \
  64     tmps_ix     = -1;           \
  65     op_mask     = NULL;         \
  66     dlmax       = 128;          \
  67     laststatval = -1;           \
  68     laststype   = OP_STAT;      \
  69     mess_sv     = Nullsv;       \
  70   } STMT_END
  71
  72 static void find_beginning _((void));
  73 static void forbid_setid _((char *));
  74 static void incpush _((char *, int));
  75 static void init_ids _((void));
  76 static void init_debugger _((void));
  77 static void init_lexer _((void));
  78 static void init_main_stash _((void));
  79 #ifdef USE_THREADS
  80 static struct perl_thread * init_main_thread _((void));
  81 #endif /* USE_THREADS */
  82 static void init_perllib _((void));
  83 static void init_postdump_symbols _((int, char **, char **));
  84 static void init_predump_symbols _((void));
  85 static void my_exit_jump _((void)) __attribute__((noreturn));
  86 static void nuke_stacks _((void));
  87 static void open_script _((char *, bool, SV *));
  88 static void usage _((char *));
  89 static void validate_suid _((char *, char*));
  90
  91 static int fdscript = -1;
  92
  93 PerlInterpreter *
  94 perl_alloc(void)
  95 {
  96     PerlInterpreter *sv_interp;
  97
  98     curinterp = 0;
  99     New(53, sv_interp, 1, PerlInterpreter);
 100     return sv_interp;
 101 }
 102
 103 void
 104 perl_construct(register PerlInterpreter *sv_interp)
 105 {
 106 #ifdef USE_THREADS
 107     int i;
 108 #ifndef FAKE_THREADS
 109     struct perl_thread *thr;
 110 #endif /* FAKE_THREADS */
 111 #endif /* USE_THREADS */
 112
 113     if (!(curinterp = sv_interp))
 114         return;
 115
 116 #ifdef MULTIPLICITY
 117     Zero(sv_interp, 1, PerlInterpreter);
 118 #endif
 119
 120    /* Init the real globals (and main thread)? */
 121     if (!linestr) {
 122 #ifdef USE_THREADS
 123
 124         INIT_THREADS;
 125 #ifdef ALLOC_THREAD_KEY
 126         ALLOC_THREAD_KEY;
 127 #else
 128         if (pthread_key_create(&thr_key, 0))
 129             croak("panic: pthread_key_create");
 130 #endif
 131         MUTEX_INIT(&sv_mutex);
 132         /*
 133          * Safe to use basic SV functions from now on (though
 134          * not things like mortals or tainting yet).
 135          */
 136         MUTEX_INIT(&eval_mutex);
 137         COND_INIT(&eval_cond);
 138         MUTEX_INIT(&threads_mutex);
 139         COND_INIT(&nthreads_cond);
 140 #ifdef EMULATE_ATOMIC_REFCOUNTS
 141         MUTEX_INIT(&svref_mutex);
 142 #endif /* EMULATE_ATOMIC_REFCOUNTS */
 143
 144         thr = init_main_thread();
 145 #endif /* USE_THREADS */
 146
 147         linestr = NEWSV(65,80);
 148         sv_upgrade(linestr,SVt_PVIV);
 149
 150         if (!SvREADONLY(&sv_undef)) {
 151             SvREADONLY_on(&sv_undef);
 152
 153             sv_setpv(&sv_no,No);
 154             SvNV(&sv_no);
 155             SvREADONLY_on(&sv_no);
 156
 157             sv_setpv(&sv_yes,Yes);
 158             SvNV(&sv_yes);
 159             SvREADONLY_on(&sv_yes);
 160         }
 161
 162         nrs = newSVpv("\n", 1);
 163         rs = SvREFCNT_inc(nrs);
 164
 165         sighandlerp = sighandler;
 166         pidstatus = newHV();
 167
 168 #ifdef MSDOS
 169         /*
 170          * There is no way we can refer to them from Perl so close them to save
 171          * space.  The other alternative would be to provide STDAUX and STDPRN
 172          * filehandles.
 173          */
 174         (void)fclose(stdaux);
 175         (void)fclose(stdprn);
 176 #endif
 177     }
 178
 179 #ifdef MULTIPLICITY
 180     I_REINIT;
 181     perl_destruct_level = 1;
 182 #else
 183    if(perl_destruct_level > 0)
 184        I_REINIT;
 185 #endif
 186
 187     init_ids();
 188     lex_state = LEX_NOTPARSING;
 189
 190     start_env.je_prev = NULL;
 191     start_env.je_ret = -1;
 192     start_env.je_mustcatch = TRUE;
 193     top_env     = &start_env;
 194     STATUS_ALL_SUCCESS;
 195
 196     SET_NUMERIC_STANDARD();
 197 #if defined(SUBVERSION) && SUBVERSION > 0
 198     sprintf(patchlevel, "%7.5f",   (double) 5
 199                                 + ((double) PATCHLEVEL / (double) 1000)
 200                                 + ((double) SUBVERSION / (double) 100000));
 201 #else
 202     sprintf(patchlevel, "%5.3f", (double) 5 +
 203                                 ((double) PATCHLEVEL / (double) 1000));
 204 #endif
 205
 206 #if defined(LOCAL_PATCH_COUNT)
 207     localpatches = local_patches;       /* For possible -v */
 208 #endif
 209
 210     PerlIO_init();      /* Hook to IO system */
 211
 212     fdpid = newAV();    /* for remembering popen pids by fd */
 213
 214     init_stacks(ARGS);
 215     DEBUG( {
 216         New(51,debname,128,char);
 217         New(52,debdelim,128,char);
 218     } )
 219
 220     ENTER;
 221 }
 222
 223 void
 224 perl_destruct(register PerlInterpreter *sv_interp)
 225 {
 226     dTHR;
 227     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 228     I32 last_sv_count;
 229     HV *hv;
 230 #ifdef USE_THREADS
 231     Thread t;
 232 #endif /* USE_THREADS */
 233
 234     if (!(curinterp = sv_interp))
 235         return;
 236
 237 #ifdef USE_THREADS
 238 #ifndef FAKE_THREADS
 239     /* Pass 1 on any remaining threads: detach joinables, join zombies */
 240   retry_cleanup:
 241     MUTEX_LOCK(&threads_mutex);
 242     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
 243                           "perl_destruct: waiting for %d threads...\n",
 244                           nthreads - 1));
 245     for (t = thr->next; t != thr; t = t->next) {
 246         MUTEX_LOCK(&t->mutex);
 247         switch (ThrSTATE(t)) {
 248             AV *av;
 249         case THRf_ZOMBIE:
 250             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
 251                                   "perl_destruct: joining zombie %p\n", t));
 252             ThrSETSTATE(t, THRf_DEAD);
 253             MUTEX_UNLOCK(&t->mutex);
 254             nthreads--;
 255             /*
 256              * The SvREFCNT_dec below may take a long time (e.g. av
 257              * may contain an object scalar whose destructor gets
 258              * called) so we have to unlock threads_mutex and start
 259              * all over again.
 260              */
 261             MUTEX_UNLOCK(&threads_mutex);
 262             JOIN(t, &av);
 263             SvREFCNT_dec((SV*)av);
 264             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
 265                                   "perl_destruct: joined zombie %p OK\n", t));
 266             goto retry_cleanup;
 267         case THRf_R_JOINABLE:
 268             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
 269                                   "perl_destruct: detaching thread %p\n", t));
 270             ThrSETSTATE(t, THRf_R_DETACHED);
 271             /*
 272              * We unlock threads_mutex and t->mutex in the opposite order
 273              * from which we locked them just so that DETACH won't
 274              * deadlock if it panics. It's only a breach of good style
 275              * not a bug since they are unlocks not locks.
 276              */
 277             MUTEX_UNLOCK(&threads_mutex);
 278             DETACH(t);
 279             MUTEX_UNLOCK(&t->mutex);
 280             goto retry_cleanup;
 281         default:
 282             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
 283                                   "perl_destruct: ignoring %p (state %u)\n",
 284                                   t, ThrSTATE(t)));
 285             MUTEX_UNLOCK(&t->mutex);
 286             /* fall through and out */
 287         }
 288     }
 289     /* We leave the above "Pass 1" loop with threads_mutex still locked */
 290
 291     /* Pass 2 on remaining threads: wait for the thread count to drop to one */
 292     while (nthreads > 1)
 293     {
 294         DEBUG_L(PerlIO_printf(PerlIO_stderr(),
 295                               "perl_destruct: final wait for %d threads\n",
 296                               nthreads - 1));
 297         COND_WAIT(&nthreads_cond, &threads_mutex);
 298     }
 299     /* At this point, we're the last thread */
 300     MUTEX_UNLOCK(&threads_mutex);
 301     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
 302     MUTEX_DESTROY(&threads_mutex);
 303     COND_DESTROY(&nthreads_cond);
 304 #endif /* !defined(FAKE_THREADS) */
 305 #endif /* USE_THREADS */
 306
 307     destruct_level = perl_destruct_level;
 308 #ifdef DEBUGGING
 309     {
 310         char *s;
 311         if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
 312             int i = atoi(s);
 313             if (destruct_level < i)
 314                 destruct_level = i;
 315         }
 316     }
 317 #endif
 318
 319     LEAVE;
 320     FREETMPS;
 321
 322     /* We must account for everything.  */
 323
 324     /* Destroy the main CV and syntax tree */
 325     if (main_root) {
 326         curpad = AvARRAY(comppad);
 327         op_free(main_root);
 328         main_root = Nullop;
 329     }
 330     main_start = Nullop;
 331     SvREFCNT_dec(main_cv);
 332     main_cv = Nullcv;
 333
 334     if (sv_objcount) {
 335         /*
 336          * Try to destruct global references.  We do this first so that the
 337          * destructors and destructees still exist.  Some sv's might remain.
 338          * Non-referenced objects are on their own.
 339          */
 340
 341         dirty = TRUE;
 342         sv_clean_objs();
 343     }
 344
 345     /* unhook hooks which will soon be, or use, destroyed data */
 346     SvREFCNT_dec(warnhook);
 347     warnhook = Nullsv;
 348     SvREFCNT_dec(diehook);
 349     diehook = Nullsv;
 350     SvREFCNT_dec(parsehook);
 351     parsehook = Nullsv;
 352
 353     if (destruct_level == 0){
 354
 355         DEBUG_P(debprofdump());
 356
 357         /* The exit() function will do everything that needs doing. */
 358         return;
 359     }
 360
 361     /* loosen bonds of global variables */
 362
 363     if(rsfp) {
 364         (void)PerlIO_close(rsfp);
 365         rsfp = Nullfp;
 366     }
 367
 368     /* Filters for program text */
 369     SvREFCNT_dec(rsfp_filters);
 370     rsfp_filters = Nullav;
 371
 372     /* switches */
 373     preprocess   = FALSE;
 374     minus_n      = FALSE;
 375     minus_p      = FALSE;
 376     minus_l      = FALSE;
 377     minus_a      = FALSE;
 378     minus_F      = FALSE;
 379     doswitches   = FALSE;
 380     dowarn       = FALSE;
 381     doextract    = FALSE;
 382     sawampersand = FALSE;       /* must save all match strings */
 383     sawstudy     = FALSE;       /* do fbm_instr on all strings */
 384     sawvec       = FALSE;
 385     unsafe       = FALSE;
 386
 387     Safefree(inplace);
 388     inplace = Nullch;
 389
 390     Safefree(e_tmpname);
 391     e_tmpname = Nullch;
 392
 393     if (e_fp) {
 394         PerlIO_close(e_fp);
 395         e_fp = Nullfp;
 396     }
 397
 398     /* magical thingies */
 399
 400     Safefree(ofs);      /* $, */
 401     ofs = Nullch;
 402
 403     Safefree(ors);      /* $\ */
 404     ors = Nullch;
 405
 406     SvREFCNT_dec(nrs);  /* $\ helper */
 407     nrs = Nullsv;
 408
 409     multiline = 0;      /* $* */
 410
 411     SvREFCNT_dec(statname);
 412     statname = Nullsv;
 413     statgv = Nullgv;
 414
 415     /* defgv, aka *_ should be taken care of elsewhere */
 416
 417     /* clean up after study() */
 418     SvREFCNT_dec(lastscream);
 419     lastscream = Nullsv;
 420     Safefree(screamfirst);
 421     screamfirst = 0;
 422     Safefree(screamnext);
 423     screamnext  = 0;
 424
 425     /* startup and shutdown function lists */
 426     SvREFCNT_dec(beginav);
 427     SvREFCNT_dec(endav);
 428     SvREFCNT_dec(initav);
 429     beginav = Nullav;
 430     endav = Nullav;
 431     initav = Nullav;
 432
 433     /* temp stack during pp_sort() */
 434     SvREFCNT_dec(sortstack);
 435     sortstack = Nullav;
 436
 437     /* shortcuts just get cleared */
 438     envgv = Nullgv;
 439     siggv = Nullgv;
 440     incgv = Nullgv;
 441     errgv = Nullgv;
 442     argvgv = Nullgv;
 443     argvoutgv = Nullgv;
 444     stdingv = Nullgv;
 445     last_in_gv = Nullgv;
 446
 447     /* reset so print() ends up where we expect */
 448     setdefout(Nullgv);
 449
 450     /* Prepare to destruct main symbol table.  */
 451
 452     hv = defstash;
 453     defstash = 0;
 454     SvREFCNT_dec(hv);
 455
 456     FREETMPS;
 457     if (destruct_level >= 2) {
 458         if (scopestack_ix != 0)
 459             warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 460                  (long)scopestack_ix);
 461         if (savestack_ix != 0)
 462             warn("Unbalanced saves: %ld more saves than restores\n",
 463                  (long)savestack_ix);
 464         if (tmps_floor != -1)
 465             warn("Unbalanced tmps: %ld more allocs than frees\n",
 466                  (long)tmps_floor + 1);
 467         if (cxstack_ix != -1)
 468             warn("Unbalanced context: %ld more PUSHes than POPs\n",
 469                  (long)cxstack_ix + 1);
 470     }
 471
 472     /* Now absolutely destruct everything, somehow or other, loops or no. */
 473     last_sv_count = 0;
 474     SvFLAGS(strtab) |= SVTYPEMASK;              /* don't clean out strtab now */
 475     while (sv_count != 0 && sv_count != last_sv_count) {
 476         last_sv_count = sv_count;
 477         sv_clean_all();
 478     }
 479     SvFLAGS(strtab) &= ~SVTYPEMASK;
 480     SvFLAGS(strtab) |= SVt_PVHV;
 481
 482     /* Destruct the global string table. */
 483     {
 484         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 485          * so that sv_free() won't fail on them.
 486          */
 487         I32 riter;
 488         I32 max;
 489         HE *hent;
 490         HE **array;
 491
 492         riter = 0;
 493         max = HvMAX(strtab);
 494         array = HvARRAY(strtab);
 495         hent = array[0];
 496         for (;;) {
 497             if (hent) {
 498                 warn("Unbalanced string table refcount: (%d) for \"%s\"",
 499                      HeVAL(hent) - Nullsv, HeKEY(hent));
 500                 HeVAL(hent) = Nullsv;
 501                 hent = HeNEXT(hent);
 502             }
 503             if (!hent) {
 504                 if (++riter > max)
 505                     break;
 506                 hent = array[riter];
 507             }
 508         }
 509     }
 510     SvREFCNT_dec(strtab);
 511
 512     if (sv_count != 0)
 513         warn("Scalars leaked: %ld\n", (long)sv_count);
 514
 515     sv_free_arenas();
 516
 517     /* No SVs have survived, need to clean out */
 518     linestr = NULL;
 519     pidstatus = Nullhv;
 520     if (origfilename)
 521         Safefree(origfilename);
 522     nuke_stacks();
 523     hints = 0;          /* Reset hints. Should hints be per-interpreter ? */
 524
 525     DEBUG_P(debprofdump());
 526 #ifdef USE_THREADS
 527     MUTEX_DESTROY(&sv_mutex);
 528     MUTEX_DESTROY(&eval_mutex);
 529     COND_DESTROY(&eval_cond);
 530
 531     /* As the penultimate thing, free the non-arena SV for thrsv */
 532     Safefree(SvPVX(thrsv));
 533     Safefree(SvANY(thrsv));
 534     Safefree(thrsv);
 535     thrsv = Nullsv;
 536 #endif /* USE_THREADS */
 537
 538     /* As the absolutely last thing, free the non-arena SV for mess() */
 539
 540     if (mess_sv) {
 541         /* we know that type >= SVt_PV */
 542         SvOOK_off(mess_sv);
 543         Safefree(SvPVX(mess_sv));
 544         Safefree(SvANY(mess_sv));
 545         Safefree(mess_sv);
 546         mess_sv = Nullsv;
 547     }
 548 }
 549
 550 void
 551 perl_free(PerlInterpreter *sv_interp)
 552 {
 553     if (!(curinterp = sv_interp))
 554         return;
 555     Safefree(sv_interp);
 556 }
 557
 558 int
 559 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
 560 {
 561     dTHR;
 562     register SV *sv;
 563     register char *s;
 564     char *scriptname = NULL;
 565     VOL bool dosearch = FALSE;
 566     char *validarg = "";
 567     I32 oldscope;
 568     AV* comppadlist;
 569     int e_tmpfd = -1;
 570     dJMPENV;
 571     int ret;
 572
 573 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 574 #ifdef IAMSUID
 575 #undef IAMSUID
 576     croak("suidperl is no longer needed since the kernel can now execute\n\
 577 setuid perl scripts securely.\n");
 578 #endif
 579 #endif
 580
 581     if (!(curinterp = sv_interp))
 582         return 255;
 583
 584 #if defined(NeXT) && defined(__DYNAMIC__)
 585     _dyld_lookup_and_bind
 586         ("__environ", (unsigned long *) &environ_pointer, NULL);
 587 #endif /* environ */
 588
 589     origargv = argv;
 590     origargc = argc;
 591 #ifndef VMS  /* VMS doesn't have environ array */
 592     origenviron = environ;
 593 #endif
 594     e_tmpname = Nullch;
 595
 596     if (do_undump) {
 597
 598         /* Come here if running an undumped a.out. */
 599
 600         origfilename = savepv(argv[0]);
 601         do_undump = FALSE;
 602         cxstack_ix = -1;                /* start label stack again */
 603         init_ids();
 604         init_postdump_symbols(argc,argv,env);
 605         return 0;
 606     }
 607
 608     if (main_root) {
 609         curpad = AvARRAY(comppad);
 610         op_free(main_root);
 611         main_root = Nullop;
 612     }
 613     main_start = Nullop;
 614     SvREFCNT_dec(main_cv);
 615     main_cv = Nullcv;
 616
 617     time(&basetime);
 618     oldscope = scopestack_ix;
 619
 620     JMPENV_PUSH(ret);
 621     switch (ret) {
 622     case 1:
 623         STATUS_ALL_FAILURE;
 624         /* FALL THROUGH */
 625     case 2:
 626         /* my_exit() was called */
 627         while (scopestack_ix > oldscope)
 628             LEAVE;
 629         FREETMPS;
 630         curstash = defstash;
 631         if (endav)
 632             call_list(oldscope, endav);
 633         JMPENV_POP;
 634         return STATUS_NATIVE_EXPORT;
 635     case 3:
 636         JMPENV_POP;
 637         PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
 638         return 1;
 639     }
 640
 641     sv_setpvn(linestr,"",0);
 642     sv = newSVpv("",0);         /* first used for -I flags */
 643     SAVEFREESV(sv);
 644     init_main_stash();
 645
 646     for (argc--,argv++; argc > 0; argc--,argv++) {
 647         if (argv[0][0] != '-' || !argv[0][1])
 648             break;
 649 #ifdef DOSUID
 650     if (*validarg)
 651         validarg = " PHOOEY ";
 652     else
 653         validarg = argv[0];
 654 #endif
 655         s = argv[0]+1;
 656       reswitch:
 657         switch (*s) {
 658         case '0':
 659         case 'F':
 660         case 'a':
 661         case 'c':
 662         case 'd':
 663         case 'D':
 664         case 'h':
 665         case 'i':
 666         case 'l':
 667         case 'M':
 668         case 'm':
 669         case 'n':
 670         case 'p':
 671         case 's':
 672         case 'u':
 673         case 'U':
 674         case 'v':
 675         case 'w':
 676             if (s = moreswitches(s))
 677                 goto reswitch;
 678             break;
 679
 680         case 'T':
 681             tainting = TRUE;
 682             s++;
 683             goto reswitch;
 684
 685         case 'e':
 686             if (euid != uid || egid != gid)
 687                 croak("No -e allowed in setuid scripts");
 688             if (!e_fp) {
 689 #ifdef HAS_UMASK
 690                 int oldumask = PerlLIO_umask(0177);
 691 #endif
 692                 e_tmpname = savepv(TMPPATH);
 693 #ifdef HAS_MKSTEMP
 694                 e_tmpfd = PerlLIO_mkstemp(e_tmpname);
 695 #else /* use mktemp() */
 696                 (void)PerlLIO_mktemp(e_tmpname);
 697                 if (!*e_tmpname)
 698                     croak("Cannot generate temporary filename");
 699 # if defined(HAS_OPEN3) && defined(O_EXCL)
 700                 e_tmpfd = open(e_tmpname,
 701                                O_WRONLY | O_CREAT | O_EXCL,
 702                                0600);
 703 # else
 704                 (void)UNLINK(e_tmpname);
 705                 /* Yes, potential race.  But at least we can say we tried. */
 706                 e_fp = PerlIO_open(e_tmpname,"w");
 707 # endif
 708 #endif /* ifdef HAS_MKSTEMP */
 709 #if defined(HAS_MKSTEMP) || (defined(HAS_OPEN3) && defined(O_EXCL))
 710                 if (e_tmpfd < 0)
 711                     croak("Cannot create temporary file \"%s\"", e_tmpname);
 712                 e_fp = PerlIO_fdopen(e_tmpfd,"w");
 713 #endif
 714                 if (!e_fp)
 715                     croak("Cannot create temporary file \"%s\"", e_tmpname);
 716 #ifdef HAS_UMASK
 717                 (void)PerlLIO_umask(oldumask);
 718 #endif
 719             }
 720             if (*++s)
 721                 PerlIO_puts(e_fp,s);
 722             else if (argv[1]) {
 723                 PerlIO_puts(e_fp,argv[1]);
 724                 argc--,argv++;
 725             }
 726             else
 727                 croak("No code specified for -e");
 728             (void)PerlIO_putc(e_fp,'\n');
 729             break;
 730         case 'I':       /* -I handled both here and in moreswitches() */
 731             forbid_setid("-I");
 732             if (!*++s && (s=argv[1]) != Nullch) {
 733                 argc--,argv++;
 734             }
 735             while (s && isSPACE(*s))
 736                 ++s;
 737             if (s && *s) {
 738                 char *e, *p;
 739                 for (e = s; *e && !isSPACE(*e); e++) ;
 740                 p = savepvn(s, e-s);
 741                 incpush(p, TRUE);
 742                 sv_catpv(sv,"-I");
 743                 sv_catpv(sv,p);
 744                 sv_catpv(sv," ");
 745                 Safefree(p);
 746             }   /* XXX else croak? */
 747             break;
 748         case 'P':
 749             forbid_setid("-P");
 750             preprocess = TRUE;
 751             s++;
 752             goto reswitch;
 753         case 'S':
 754             forbid_setid("-S");
 755             dosearch = TRUE;
 756             s++;
 757             goto reswitch;
 758         case 'V':
 759             if (!preambleav)
 760                 preambleav = newAV();
 761             av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
 762             if (*++s != ':')  {
 763                 Sv = newSVpv("print myconfig();",0);
 764 #ifdef VMS
 765                 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
 766 #else
 767                 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 768 #endif
 769 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
 770                 sv_catpv(Sv,"\"  Compile-time options:");
 771 #  ifdef DEBUGGING
 772                 sv_catpv(Sv," DEBUGGING");
 773 #  endif
 774 #  ifdef NO_EMBED
 775                 sv_catpv(Sv," NO_EMBED");
 776 #  endif
 777 #  ifdef MULTIPLICITY
 778                 sv_catpv(Sv," MULTIPLICITY");
 779 #  endif
 780                 sv_catpv(Sv,"\\n\",");
 781 #endif
 782 #if defined(LOCAL_PATCH_COUNT)
 783                 if (LOCAL_PATCH_COUNT > 0) {
 784                     int i;
 785                     sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
 786                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
 787                         if (localpatches[i])
 788                             sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
 789                     }
 790                 }
 791 #endif
 792                 sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
 793 #ifdef __DATE__
 794 #  ifdef __TIME__
 795                 sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 796 #  else
 797                 sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
 798 #  endif
 799 #endif
 800                 sv_catpv(Sv, "; \
 801 $\"=\"\\n    \"; \
 802 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
 803 print \"  \\%ENV:\\n    @env\\n\" if @env; \
 804 print \"  \\@INC:\\n    @INC\\n\";");
 805             }
 806             else {
 807                 Sv = newSVpv("config_vars(qw(",0);
 808                 sv_catpv(Sv, ++s);
 809                 sv_catpv(Sv, "))");
 810                 s += strlen(s);
 811             }
 812             av_push(preambleav, Sv);
 813             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
 814             goto reswitch;
 815         case 'x':
 816             doextract = TRUE;
 817             s++;
 818             if (*s)
 819                 cddir = savepv(s);
 820             break;
 821         case 0:
 822             break;
 823         case '-':
 824             if (!*++s || isSPACE(*s)) {
 825                 argc--,argv++;
 826                 goto switch_end;
 827             }
 828             /* catch use of gnu style long options */
 829             if (strEQ(s, "version")) {
 830                 s = "v";
 831                 goto reswitch;
 832             }
 833             if (strEQ(s, "help")) {
 834                 s = "h";
 835                 goto reswitch;
 836             }
 837             s--;
 838             /* FALL THROUGH */
 839         default:
 840             croak("Unrecognized switch: -%s  (-h will show valid options)",s);
 841         }
 842     }
 843   switch_end:
 844
 845     if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
 846         while (s && *s) {
 847             while (isSPACE(*s))
 848                 s++;
 849             if (*s == '-') {
 850                 s++;
 851                 if (isSPACE(*s))
 852                     continue;
 853             }
 854             if (!*s)
 855                 break;
 856             if (!strchr("DIMUdmw", *s))
 857                 croak("Illegal switch in PERL5OPT: -%c", *s);
 858             s = moreswitches(s);
 859         }
 860     }
 861
 862     if (!scriptname)
 863         scriptname = argv[0];
 864     if (e_fp) {
 865         if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
 866 #ifndef MULTIPLICITY
 867             warn("Did you forget to compile with -DMULTIPLICITY?");
 868 #endif
 869             croak("Can't write to temp file for -e: %s", Strerror(errno));
 870         }
 871         e_fp = Nullfp;
 872         argc++,argv--;
 873         scriptname = e_tmpname;
 874     }
 875     else if (scriptname == Nullch) {
 876 #ifdef MSDOS
 877         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
 878             moreswitches("h");
 879 #endif
 880         scriptname = "-";
 881     }
 882
 883     init_perllib();
 884
 885     open_script(scriptname,dosearch,sv);
 886
 887     validate_suid(validarg, scriptname);
 888
 889     if (doextract)
 890         find_beginning();
 891
 892     main_cv = compcv = (CV*)NEWSV(1104,0);
 893     sv_upgrade((SV *)compcv, SVt_PVCV);
 894     CvUNIQUE_on(compcv);
 895
 896     comppad = newAV();
 897     av_push(comppad, Nullsv);
 898     curpad = AvARRAY(comppad);
 899     comppad_name = newAV();
 900     comppad_name_fill = 0;
 901     min_intro_pending = 0;
 902     padix = 0;
 903 #ifdef USE_THREADS
 904     av_store(comppad_name, 0, newSVpv("@_", 2));
 905     curpad[0] = (SV*)newAV();
 906     SvPADMY_on(curpad[0]);      /* XXX Needed? */
 907     CvOWNER(compcv) = 0;
 908     New(666, CvMUTEXP(compcv), 1, perl_mutex);
 909     MUTEX_INIT(CvMUTEXP(compcv));
 910 #endif /* USE_THREADS */
 911
 912     comppadlist = newAV();
 913     AvREAL_off(comppadlist);
 914     av_store(comppadlist, 0, (SV*)comppad_name);
 915     av_store(comppadlist, 1, (SV*)comppad);
 916     CvPADLIST(compcv) = comppadlist;
 917
 918     boot_core_UNIVERSAL();
 919     if (xsinit)
 920         (*xsinit)();    /* in case linked C routines want magical variables */
 921 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
 922     init_os_extras();
 923 #endif
 924
 925     init_predump_symbols();
 926     if (!do_undump)
 927         init_postdump_symbols(argc,argv,env);
 928
 929     init_lexer();
 930
 931     /* now parse the script */
 932
 933     SETERRNO(0,SS$_NORMAL);
 934     error_count = 0;
 935     if (yyparse() || error_count) {
 936         if (minus_c)
 937             croak("%s had compilation errors.\n", origfilename);
 938         else {
 939             croak("Execution of %s aborted due to compilation errors.\n",
 940                 origfilename);
 941         }
 942     }
 943     curcop->cop_line = 0;
 944     curstash = defstash;
 945     preprocess = FALSE;
 946     if (e_tmpname) {
 947         (void)UNLINK(e_tmpname);
 948         Safefree(e_tmpname);
 949         e_tmpname = Nullch;
 950         e_tmpfd = -1;
 951     }
 952
 953     /* now that script is parsed, we can modify record separator */
 954     SvREFCNT_dec(rs);
 955     rs = SvREFCNT_inc(nrs);
 956     sv_setsv(perl_get_sv("/", TRUE), rs);
 957     if (do_undump)
 958         my_unexec();
 959
 960     if (dowarn)
 961         gv_check(defstash);
 962
 963     LEAVE;
 964     FREETMPS;
 965
 966 #ifdef MYMALLOC
 967     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
 968         dump_mstats("after compilation:");
 969 #endif
 970
 971     ENTER;
 972     restartop = 0;
 973     JMPENV_POP;
 974     return 0;
 975 }
 976
 977 int
 978 perl_run(PerlInterpreter *sv_interp)
 979 {
 980     dTHR;
 981     I32 oldscope;
 982     dJMPENV;
 983     int ret;
 984
 985     if (!(curinterp = sv_interp))
 986         return 255;
 987
 988     oldscope = scopestack_ix;
 989
 990     JMPENV_PUSH(ret);
 991     switch (ret) {
 992     case 1:
 993         cxstack_ix = -1;                /* start context stack again */
 994         break;
 995     case 2:
 996         /* my_exit() was called */
 997         while (scopestack_ix > oldscope)
 998             LEAVE;
 999         FREETMPS;
1000         curstash = defstash;
1001         if (endav)
1002             call_list(oldscope, endav);
1003 #ifdef MYMALLOC
1004         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1005             dump_mstats("after execution:  ");
1006 #endif
1007         JMPENV_POP;
1008         return STATUS_NATIVE_EXPORT;
1009     case 3:
1010         if (!restartop) {
1011             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1012             FREETMPS;
1013             JMPENV_POP;
1014             return 1;
1015         }
1016         if (curstack != mainstack) {
1017             dSP;
1018             SWITCHSTACK(curstack, mainstack);
1019         }
1020         break;
1021     }
1022
1023     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1024                     sawampersand ? "Enabling" : "Omitting"));
1025
1026     if (!restartop) {
1027         DEBUG_x(dump_all());
1028         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1029 #ifdef USE_THREADS
1030         DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1031                               (unsigned long) thr));
1032 #endif /* USE_THREADS */
1033
1034         if (minus_c) {
1035             PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1036             my_exit(0);
1037         }
1038         if (PERLDB_SINGLE && DBsingle)
1039            sv_setiv(DBsingle, 1);
1040         if (initav)
1041             call_list(oldscope, initav);
1042     }
1043
1044     /* do it */
1045
1046     if (restartop) {
1047         op = restartop;
1048         restartop = 0;
1049         runops();
1050     }
1051     else if (main_start) {
1052         CvDEPTH(main_cv) = 1;
1053         op = main_start;
1054         runops();
1055     }
1056
1057     my_exit(0);
1058     /* NOTREACHED */
1059     return 0;
1060 }
1061
1062 SV*
1063 perl_get_sv(char *name, I32 create)
1064 {
1065     GV *gv;
1066 #ifdef USE_THREADS
1067     if (name[1] == '\0' && !isALPHA(name[0])) {
1068         PADOFFSET tmp = find_threadsv(name);
1069         if (tmp != NOT_IN_PAD) {
1070             dTHR;
1071             return THREADSV(tmp);
1072         }
1073     }
1074 #endif /* USE_THREADS */
1075     gv = gv_fetchpv(name, create, SVt_PV);
1076     if (gv)
1077         return GvSV(gv);
1078     return Nullsv;
1079 }
1080
1081 AV*
1082 perl_get_av(char *name, I32 create)
1083 {
1084     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1085     if (create)
1086         return GvAVn(gv);
1087     if (gv)
1088         return GvAV(gv);
1089     return Nullav;
1090 }
1091
1092 HV*
1093 perl_get_hv(char *name, I32 create)
1094 {
1095     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1096     if (create)
1097         return GvHVn(gv);
1098     if (gv)
1099         return GvHV(gv);
1100     return Nullhv;
1101 }
1102
1103 CV*
1104 perl_get_cv(char *name, I32 create)
1105 {
1106     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1107     if (create && !GvCVu(gv))
1108         return newSUB(start_subparse(FALSE, 0),
1109                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1110                       Nullop,
1111                       Nullop);
1112     if (gv)
1113         return GvCVu(gv);
1114     return Nullcv;
1115 }
1116
1117 /* Be sure to refetch the stack pointer after calling these routines. */
1118
1119 I32
1120 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1121
1122                         /* See G_* flags in cop.h */
1123                         /* null terminated arg list */
1124 {
1125     dSP;
1126
1127     PUSHMARK(SP);
1128     if (argv) {
1129         while (*argv) {
1130             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1131             argv++;
1132         }
1133         PUTBACK;
1134     }
1135     return perl_call_pv(sub_name, flags);
1136 }
1137
1138 I32
1139 perl_call_pv(char *sub_name, I32 flags)
1140                         /* name of the subroutine */
1141                         /* See G_* flags in cop.h */
1142 {
1143     return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1144 }
1145
1146 I32
1147 perl_call_method(char *methname, I32 flags)
1148                         /* name of the subroutine */
1149                         /* See G_* flags in cop.h */
1150 {
1151     dSP;
1152     OP myop;
1153     if (!op)
1154         op = &myop;
1155     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1156     PUTBACK;
1157     pp_method(ARGS);
1158     return perl_call_sv(*stack_sp--, flags);
1159 }
1160
1161 /* May be called with any of a CV, a GV, or an SV containing the name. */
1162 I32
1163 perl_call_sv(SV *sv, I32 flags)
1164
1165                         /* See G_* flags in cop.h */
1166 {
1167     dSP;
1168     LOGOP myop;         /* fake syntax tree node */
1169     I32 oldmark;
1170     I32 retval;
1171     I32 oldscope;
1172     static CV *DBcv;
1173     bool oldcatch = CATCH_GET;
1174     dJMPENV;
1175     int ret;
1176     OP* oldop = op;
1177
1178     if (flags & G_DISCARD) {
1179         ENTER;
1180         SAVETMPS;
1181     }
1182
1183     Zero(&myop, 1, LOGOP);
1184     myop.op_next = Nullop;
1185     if (!(flags & G_NOARGS))
1186         myop.op_flags |= OPf_STACKED;
1187     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1188                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1189                       OPf_WANT_SCALAR);
1190     SAVEOP();
1191     op = (OP*)&myop;
1192
1193     EXTEND(stack_sp, 1);
1194     *++stack_sp = sv;
1195     oldmark = TOPMARK;
1196     oldscope = scopestack_ix;
1197
1198     if (PERLDB_SUB && curstash != debstash
1199            /* Handle first BEGIN of -d. */
1200           && (DBcv || (DBcv = GvCV(DBsub)))
1201            /* Try harder, since this may have been a sighandler, thus
1202             * curstash may be meaningless. */
1203           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1204         op->op_private |= OPpENTERSUB_DB;
1205
1206     if (flags & G_EVAL) {
1207         cLOGOP->op_other = op;
1208         markstack_ptr--;
1209         /* we're trying to emulate pp_entertry() here */
1210         {
1211             register PERL_CONTEXT *cx;
1212             I32 gimme = GIMME_V;
1213
1214             ENTER;
1215             SAVETMPS;
1216
1217             push_return(op->op_next);
1218             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1219             PUSHEVAL(cx, 0, 0);
1220             eval_root = op;             /* Only needed so that goto works right. */
1221
1222             in_eval = 1;
1223             if (flags & G_KEEPERR)
1224                 in_eval |= 4;
1225             else
1226                 sv_setpv(ERRSV,"");
1227         }
1228         markstack_ptr++;
1229
1230         JMPENV_PUSH(ret);
1231         switch (ret) {
1232         case 0:
1233             break;
1234         case 1:
1235             STATUS_ALL_FAILURE;
1236             /* FALL THROUGH */
1237         case 2:
1238             /* my_exit() was called */
1239             curstash = defstash;
1240             FREETMPS;
1241             JMPENV_POP;
1242             if (statusvalue)
1243                 croak("Callback called exit");
1244             my_exit_jump();
1245             /* NOTREACHED */
1246         case 3:
1247             if (restartop) {
1248                 op = restartop;
1249                 restartop = 0;
1250                 break;
1251             }
1252             stack_sp = stack_base + oldmark;
1253             if (flags & G_ARRAY)
1254                 retval = 0;
1255             else {
1256                 retval = 1;
1257                 *++stack_sp = &sv_undef;
1258             }
1259             goto cleanup;
1260         }
1261     }
1262     else
1263         CATCH_SET(TRUE);
1264
1265     if (op == (OP*)&myop)
1266         op = pp_entersub(ARGS);
1267     if (op)
1268         runops();
1269     retval = stack_sp - (stack_base + oldmark);
1270     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1271         sv_setpv(ERRSV,"");
1272
1273   cleanup:
1274     if (flags & G_EVAL) {
1275         if (scopestack_ix > oldscope) {
1276             SV **newsp;
1277             PMOP *newpm;
1278             I32 gimme;
1279             register PERL_CONTEXT *cx;
1280             I32 optype;
1281
1282             POPBLOCK(cx,newpm);
1283             POPEVAL(cx);
1284             pop_return();
1285             curpm = newpm;
1286             LEAVE;
1287         }
1288         JMPENV_POP;
1289     }
1290     else
1291         CATCH_SET(oldcatch);
1292
1293     if (flags & G_DISCARD) {
1294         stack_sp = stack_base + oldmark;
1295         retval = 0;
1296         FREETMPS;
1297         LEAVE;
1298     }
1299     op = oldop;
1300     return retval;
1301 }
1302
1303 /* Eval a string. The G_EVAL flag is always assumed. */
1304
1305 I32
1306 perl_eval_sv(SV *sv, I32 flags)
1307
1308                         /* See G_* flags in cop.h */
1309 {
1310     dSP;
1311     UNOP myop;          /* fake syntax tree node */
1312     I32 oldmark = SP - stack_base;
1313     I32 retval;
1314     I32 oldscope;
1315     dJMPENV;
1316     int ret;
1317     OP* oldop = op;
1318
1319     if (flags & G_DISCARD) {
1320         ENTER;
1321         SAVETMPS;
1322     }
1323
1324     SAVEOP();
1325     op = (OP*)&myop;
1326     Zero(op, 1, UNOP);
1327     EXTEND(stack_sp, 1);
1328     *++stack_sp = sv;
1329     oldscope = scopestack_ix;
1330
1331     if (!(flags & G_NOARGS))
1332         myop.op_flags = OPf_STACKED;
1333     myop.op_next = Nullop;
1334     myop.op_type = OP_ENTEREVAL;
1335     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1336                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1337                       OPf_WANT_SCALAR);
1338     if (flags & G_KEEPERR)
1339         myop.op_flags |= OPf_SPECIAL;
1340
1341     JMPENV_PUSH(ret);
1342     switch (ret) {
1343     case 0:
1344         break;
1345     case 1:
1346         STATUS_ALL_FAILURE;
1347         /* FALL THROUGH */
1348     case 2:
1349         /* my_exit() was called */
1350         curstash = defstash;
1351         FREETMPS;
1352         JMPENV_POP;
1353         if (statusvalue)
1354             croak("Callback called exit");
1355         my_exit_jump();
1356         /* NOTREACHED */
1357     case 3:
1358         if (restartop) {
1359             op = restartop;
1360             restartop = 0;
1361             break;
1362         }
1363         stack_sp = stack_base + oldmark;
1364         if (flags & G_ARRAY)
1365             retval = 0;
1366         else {
1367             retval = 1;
1368             *++stack_sp = &sv_undef;
1369         }
1370         goto cleanup;
1371     }
1372
1373     if (op == (OP*)&myop)
1374         op = pp_entereval(ARGS);
1375     if (op)
1376         runops();
1377     retval = stack_sp - (stack_base + oldmark);
1378     if (!(flags & G_KEEPERR))
1379         sv_setpv(ERRSV,"");
1380
1381   cleanup:
1382     JMPENV_POP;
1383     if (flags & G_DISCARD) {
1384         stack_sp = stack_base + oldmark;
1385         retval = 0;
1386         FREETMPS;
1387         LEAVE;
1388     }
1389     op = oldop;
1390     return retval;
1391 }
1392
1393 SV*
1394 perl_eval_pv(char *p, I32 croak_on_error)
1395 {
1396     dSP;
1397     SV* sv = newSVpv(p, 0);
1398
1399     PUSHMARK(SP);
1400     perl_eval_sv(sv, G_SCALAR);
1401     SvREFCNT_dec(sv);
1402
1403     SPAGAIN;
1404     sv = POPs;
1405     PUTBACK;
1406
1407     if (croak_on_error && SvTRUE(ERRSV))
1408         croak(SvPVx(ERRSV, na));
1409
1410     return sv;
1411 }
1412
1413 /* Require a module. */
1414
1415 void
1416 perl_require_pv(char *pv)
1417 {
1418     SV* sv = sv_newmortal();
1419     sv_setpv(sv, "require '");
1420     sv_catpv(sv, pv);
1421     sv_catpv(sv, "'");
1422     perl_eval_sv(sv, G_DISCARD);
1423 }
1424
1425 void
1426 magicname(char *sym, char *name, I32 namlen)
1427 {
1428     register GV *gv;
1429
1430     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1431         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1432 }
1433
1434 static void
1435 usage(char *name)               /* XXX move this out into a module ? */
1436
1437 {
1438     /* This message really ought to be max 23 lines.
1439      * Removed -h because the user already knows that opton. Others? */
1440
1441     static char *usage[] = {
1442 "-0[octal]       specify record separator (\\0, if no argument)",
1443 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1444 "-c              check syntax only (runs BEGIN and END blocks)",
1445 "-d[:debugger]   run scripts under debugger",
1446 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1447 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1448 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1449 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1450 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1451 "-l[octal]       enable line ending processing, specifies line terminator",
1452 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1453 "-n              assume 'while (<>) { ... }' loop around your script",
1454 "-p              assume loop like -n but print line also like sed",
1455 "-P              run script through C preprocessor before compilation",
1456 "-s              enable some switch parsing for switches after script name",
1457 "-S              look for the script using PATH environment variable",
1458 "-T              turn on tainting checks",
1459 "-u              dump core after parsing script",
1460 "-U              allow unsafe operations",
1461 "-v              print version number and patchlevel of perl",
1462 "-V[:variable]   print perl configuration information",
1463 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1464 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1465 "\n",
1466 NULL
1467 };
1468     char **p = usage;
1469
1470     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1471     while (*p)
1472         printf("\n  %s", *p++);
1473 }
1474
1475 /* This routine handles any switches that can be given during run */
1476
1477 char *
1478 moreswitches(char *s)
1479 {
1480     I32 numlen;
1481     U32 rschar;
1482
1483     switch (*s) {
1484     case '0':
1485     {
1486         dTHR;
1487         rschar = scan_oct(s, 4, &numlen);
1488         SvREFCNT_dec(nrs);
1489         if (rschar & ~((U8)~0))
1490             nrs = &sv_undef;
1491         else if (!rschar && numlen >= 2)
1492             nrs = newSVpv("", 0);
1493         else {
1494             char ch = rschar;
1495             nrs = newSVpv(&ch, 1);
1496         }
1497         return s + numlen;
1498     }
1499     case 'F':
1500         minus_F = TRUE;
1501         splitstr = savepv(s + 1);
1502         s += strlen(s);
1503         return s;
1504     case 'a':
1505         minus_a = TRUE;
1506         s++;
1507         return s;
1508     case 'c':
1509         minus_c = TRUE;
1510         s++;
1511         return s;
1512     case 'd':
1513         forbid_setid("-d");
1514         s++;
1515         if (*s == ':' || *s == '=')  {
1516             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1517             s += strlen(s);
1518         }
1519         if (!perldb) {
1520             perldb = PERLDB_ALL;
1521             init_debugger();
1522         }
1523         return s;
1524     case 'D':
1525 #ifdef DEBUGGING
1526         forbid_setid("-D");
1527         if (isALPHA(s[1])) {
1528             static char debopts[] = "psltocPmfrxuLHXD";
1529             char *d;
1530
1531             for (s++; *s && (d = strchr(debopts,*s)); s++)
1532                 debug |= 1 << (d - debopts);
1533         }
1534         else {
1535             debug = atoi(s+1);
1536             for (s++; isDIGIT(*s); s++) ;
1537         }
1538         debug |= 0x80000000;
1539 #else
1540         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1541         for (s++; isALNUM(*s); s++) ;
1542 #endif
1543         /*SUPPRESS 530*/
1544         return s;
1545     case 'h':
1546         usage(origargv[0]);
1547         PerlProc_exit(0);
1548     case 'i':
1549         if (inplace)
1550             Safefree(inplace);
1551         inplace = savepv(s+1);
1552         /*SUPPRESS 530*/
1553         for (s = inplace; *s && !isSPACE(*s); s++) ;
1554         if (*s)
1555             *s++ = '\0';
1556         return s;
1557     case 'I':   /* -I handled both here and in parse_perl() */
1558         forbid_setid("-I");
1559         ++s;
1560         while (*s && isSPACE(*s))
1561             ++s;
1562         if (*s) {
1563             char *e, *p;
1564             for (e = s; *e && !isSPACE(*e); e++) ;
1565             p = savepvn(s, e-s);
1566             incpush(p, TRUE);
1567             Safefree(p);
1568             s = e;
1569         }
1570         else
1571             croak("No space allowed after -I");
1572         return s;
1573     case 'l':
1574         minus_l = TRUE;
1575         s++;
1576         if (ors)
1577             Safefree(ors);
1578         if (isDIGIT(*s)) {
1579             ors = savepv("\n");
1580             orslen = 1;
1581             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1582             s += numlen;
1583         }
1584         else {
1585             dTHR;
1586             if (RsPARA(nrs)) {
1587                 ors = "\n\n";
1588                 orslen = 2;
1589             }
1590             else
1591                 ors = SvPV(nrs, orslen);
1592             ors = savepvn(ors, orslen);
1593         }
1594         return s;
1595     case 'M':
1596         forbid_setid("-M");     /* XXX ? */
1597         /* FALL THROUGH */
1598     case 'm':
1599         forbid_setid("-m");     /* XXX ? */
1600         if (*++s) {
1601             char *start;
1602             SV *sv;
1603             char *use = "use ";
1604             /* -M-foo == 'no foo'       */
1605             if (*s == '-') { use = "no "; ++s; }
1606             sv = newSVpv(use,0);
1607             start = s;
1608             /* We allow -M'Module qw(Foo Bar)'  */
1609             while(isALNUM(*s) || *s==':') ++s;
1610             if (*s != '=') {
1611                 sv_catpv(sv, start);
1612                 if (*(start-1) == 'm') {
1613                     if (*s != '\0')
1614                         croak("Can't use '%c' after -mname", *s);
1615                     sv_catpv( sv, " ()");
1616                 }
1617             } else {
1618                 sv_catpvn(sv, start, s-start);
1619                 sv_catpv(sv, " split(/,/,q{");
1620                 sv_catpv(sv, ++s);
1621                 sv_catpv(sv,    "})");
1622             }
1623             s += strlen(s);
1624             if (preambleav == NULL)
1625                 preambleav = newAV();
1626             av_push(preambleav, sv);
1627         }
1628         else
1629             croak("No space allowed after -%c", *(s-1));
1630         return s;
1631     case 'n':
1632         minus_n = TRUE;
1633         s++;
1634         return s;
1635     case 'p':
1636         minus_p = TRUE;
1637         s++;
1638         return s;
1639     case 's':
1640         forbid_setid("-s");
1641         doswitches = TRUE;
1642         s++;
1643         return s;
1644     case 'T':
1645         if (!tainting)
1646             croak("Too late for \"-T\" option");
1647         s++;
1648         return s;
1649     case 'u':
1650         do_undump = TRUE;
1651         s++;
1652         return s;
1653     case 'U':
1654         unsafe = TRUE;
1655         s++;
1656         return s;
1657     case 'v':
1658 #if defined(SUBVERSION) && SUBVERSION > 0
1659         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1660             PATCHLEVEL, SUBVERSION, ARCHNAME);
1661 #else
1662         printf("\nThis is perl, version %s built for %s",
1663                 patchlevel, ARCHNAME);
1664 #endif
1665 #if defined(LOCAL_PATCH_COUNT)
1666         if (LOCAL_PATCH_COUNT > 0)
1667             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1668                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1669 #endif
1670
1671         printf("\n\nCopyright 1987-1998, Larry Wall\n");
1672 #ifdef MSDOS
1673         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1674 #endif
1675 #ifdef DJGPP
1676         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1677         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1678 #endif
1679 #ifdef OS2
1680         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1681             "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1682 #endif
1683 #ifdef atarist
1684         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1685 #endif
1686         printf("\n\
1687 Perl may be copied only under the terms of either the Artistic License or the\n\
1688 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1689         PerlProc_exit(0);
1690     case 'w':
1691         dowarn = TRUE;
1692         s++;
1693         return s;
1694     case '*':
1695     case ' ':
1696         if (s[1] == '-')        /* Additional switches on #! line. */
1697             return s+2;
1698         break;
1699     case '-':
1700     case 0:
1701 #ifdef WIN32
1702     case '\r':
1703 #endif
1704     case '\n':
1705     case '\t':
1706         break;
1707 #ifdef ALTERNATE_SHEBANG
1708     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1709         break;
1710 #endif
1711     case 'P':
1712         if (preprocess)
1713             return s+1;
1714         /* FALL THROUGH */
1715     default:
1716         croak("Can't emulate -%.1s on #! line",s);
1717     }
1718     return Nullch;
1719 }
1720
1721 /* compliments of Tom Christiansen */
1722
1723 /* unexec() can be found in the Gnu emacs distribution */
1724
1725 void
1726 my_unexec(void)
1727 {
1728 #ifdef UNEXEC
1729     SV*    prog;
1730     SV*    file;
1731     int    status;
1732     extern int etext;
1733
1734     prog = newSVpv(BIN_EXP);
1735     sv_catpv(prog, "/perl");
1736     file = newSVpv(origfilename);
1737     sv_catpv(file, ".perldump");
1738
1739     status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1740     if (status)
1741         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1742                       SvPVX(prog), SvPVX(file));
1743     PerlProc_exit(status);
1744 #else
1745 #  ifdef VMS
1746 #    include <lib$routines.h>
1747      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1748 #  else
1749     ABORT();            /* for use with undump */
1750 #  endif
1751 #endif
1752 }
1753
1754 static void
1755 init_main_stash(void)
1756 {
1757     dTHR;
1758     GV *gv;
1759
1760     /* Note that strtab is a rather special HV.  Assumptions are made
1761        about not iterating on it, and not adding tie magic to it.
1762        It is properly deallocated in perl_destruct() */
1763     strtab = newHV();
1764     HvSHAREKEYS_off(strtab);                    /* mandatory */
1765     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1766          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1767
1768     curstash = defstash = newHV();
1769     curstname = newSVpv("main",4);
1770     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1771     SvREFCNT_dec(GvHV(gv));
1772     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1773     SvREADONLY_on(gv);
1774     HvNAME(defstash) = savepv("main");
1775     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1776     GvMULTI_on(incgv);
1777     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1778     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1779     GvMULTI_on(errgv);
1780     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1781     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1782     sv_setpvn(ERRSV, "", 0);
1783     curstash = defstash;
1784     compiling.cop_stash = defstash;
1785     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1786     globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1787     /* We must init $/ before switches are processed. */
1788     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1789 }
1790
1791 static void
1792 open_script(char *scriptname, bool dosearch, SV *sv)
1793 {
1794     dTHR;
1795     char *xfound = Nullch;
1796     char *xfailed = Nullch;
1797     register char *s;
1798     I32 len;
1799     int retval;
1800 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1801 #  define SEARCH_EXTS ".bat", ".cmd", NULL
1802 #  define MAX_EXT_LEN 4
1803 #endif
1804 #ifdef OS2
1805 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1806 #  define MAX_EXT_LEN 4
1807 #endif
1808 #ifdef VMS
1809 #  define SEARCH_EXTS ".pl", ".com", NULL
1810 #  define MAX_EXT_LEN 4
1811 #endif
1812     /* additional extensions to try in each dir if scriptname not found */
1813 #ifdef SEARCH_EXTS
1814     char *ext[] = { SEARCH_EXTS };
1815     int extidx = 0, i = 0;
1816     char *curext = Nullch;
1817 #else
1818 #  define MAX_EXT_LEN 0
1819 #endif
1820
1821     /*
1822      * If dosearch is true and if scriptname does not contain path
1823      * delimiters, search the PATH for scriptname.
1824      *
1825      * If SEARCH_EXTS is also defined, will look for each
1826      * scriptname{SEARCH_EXTS} whenever scriptname is not found
1827      * while searching the PATH.
1828      *
1829      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1830      * proceeds as follows:
1831      *   If DOSISH or VMSISH:
1832      *     + look for ./scriptname{,.foo,.bar}
1833      *     + search the PATH for scriptname{,.foo,.bar}
1834      *
1835      *   If !DOSISH:
1836      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
1837      *       this will not look in '.' if it's not in the PATH)
1838      */
1839
1840 #ifdef VMS
1841 #  ifdef ALWAYS_DEFTYPES
1842     len = strlen(scriptname);
1843     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1844         int hasdir, idx = 0, deftypes = 1;
1845         bool seen_dot = 1;
1846
1847         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1848 #  else
1849     if (dosearch) {
1850         int hasdir, idx = 0, deftypes = 1;
1851         bool seen_dot = 1;
1852
1853         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1854 #  endif
1855         /* The first time through, just add SEARCH_EXTS to whatever we
1856          * already have, so we can check for default file types. */
1857         while (deftypes ||
1858                (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1859         {
1860             if (deftypes) {
1861                 deftypes = 0;
1862                 *tokenbuf = '\0';
1863             }
1864             if ((strlen(tokenbuf) + strlen(scriptname)
1865                  + MAX_EXT_LEN) >= sizeof tokenbuf)
1866                 continue;       /* don't search dir with too-long name */
1867             strcat(tokenbuf, scriptname);
1868 #else  /* !VMS */
1869
1870 #ifdef DOSISH
1871     if (strEQ(scriptname, "-"))
1872         dosearch = 0;
1873     if (dosearch) {             /* Look in '.' first. */
1874         char *cur = scriptname;
1875 #ifdef SEARCH_EXTS
1876         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1877             while (ext[i])
1878                 if (strEQ(ext[i++],curext)) {
1879                     extidx = -1;                /* already has an ext */
1880                     break;
1881                 }
1882         do {
1883 #endif
1884             DEBUG_p(PerlIO_printf(Perl_debug_log,
1885                                   "Looking for %s\n",cur));
1886             if (PerlLIO_stat(cur,&statbuf) >= 0) {
1887                 dosearch = 0;
1888                 scriptname = cur;
1889 #ifdef SEARCH_EXTS
1890                 break;
1891 #endif
1892             }
1893 #ifdef SEARCH_EXTS
1894             if (cur == scriptname) {
1895                 len = strlen(scriptname);
1896                 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1897                     break;
1898                 cur = strcpy(tokenbuf, scriptname);
1899             }
1900         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
1901                  && strcpy(tokenbuf+len, ext[extidx++]));
1902 #endif
1903     }
1904 #endif
1905
1906     if (dosearch && !strchr(scriptname, '/')
1907 #ifdef DOSISH
1908                  && !strchr(scriptname, '\\')
1909 #endif
1910                  && (s = PerlEnv_getenv("PATH"))) {
1911         bool seen_dot = 0;
1912
1913         bufend = s + strlen(s);
1914         while (s < bufend) {
1915 #if defined(atarist) || defined(DOSISH)
1916             for (len = 0; *s
1917 #  ifdef atarist
1918                     && *s != ','
1919 #  endif
1920                     && *s != ';'; len++, s++) {
1921                 if (len < sizeof tokenbuf)
1922                     tokenbuf[len] = *s;
1923             }
1924             if (len < sizeof tokenbuf)
1925                 tokenbuf[len] = '\0';
1926 #else  /* ! (atarist || DOSISH) */
1927             s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1928                         ':',
1929                         &len);
1930 #endif /* ! (atarist || DOSISH) */
1931             if (s < bufend)
1932                 s++;
1933             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1934                 continue;       /* don't search dir with too-long name */
1935             if (len
1936 #if defined(atarist) || defined(DOSISH)
1937                 && tokenbuf[len - 1] != '/'
1938                 && tokenbuf[len - 1] != '\\'
1939 #endif
1940                )
1941                 tokenbuf[len++] = '/';
1942             if (len == 2 && tokenbuf[0] == '.')
1943                 seen_dot = 1;
1944             (void)strcpy(tokenbuf + len, scriptname);
1945 #endif  /* !VMS */
1946
1947 #ifdef SEARCH_EXTS
1948             len = strlen(tokenbuf);
1949             if (extidx > 0)     /* reset after previous loop */
1950                 extidx = 0;
1951             do {
1952 #endif
1953                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1954                 retval = PerlLIO_stat(tokenbuf,&statbuf);
1955 #ifdef SEARCH_EXTS
1956             } while (  retval < 0               /* not there */
1957                     && extidx>=0 && ext[extidx] /* try an extension? */
1958                     && strcpy(tokenbuf+len, ext[extidx++])
1959                 );
1960 #endif
1961             if (retval < 0)
1962                 continue;
1963             if (S_ISREG(statbuf.st_mode)
1964                 && cando(S_IRUSR,TRUE,&statbuf)
1965 #ifndef DOSISH
1966                 && cando(S_IXUSR,TRUE,&statbuf)
1967 #endif
1968                 )
1969             {
1970                 xfound = tokenbuf;              /* bingo! */
1971                 break;
1972             }
1973             if (!xfailed)
1974                 xfailed = savepv(tokenbuf);
1975         }
1976 #ifndef DOSISH
1977         if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
1978 #endif
1979             seen_dot = 1;                       /* Disable message. */
1980         if (!xfound)
1981             croak("Can't %s %s%s%s",
1982                   (xfailed ? "execute" : "find"),
1983                   (xfailed ? xfailed : scriptname),
1984                   (xfailed ? "" : " on PATH"),
1985                   (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1986         if (xfailed)
1987             Safefree(xfailed);
1988         scriptname = xfound;
1989     }
1990
1991     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1992         char *s = scriptname + 8;
1993         fdscript = atoi(s);
1994         while (isDIGIT(*s))
1995             s++;
1996         if (*s)
1997             scriptname = s + 1;
1998     }
1999     else
2000         fdscript = -1;
2001     origfilename = savepv(e_tmpname ? "-e" : scriptname);
2002     curcop->cop_filegv = gv_fetchfile(origfilename);
2003     if (strEQ(origfilename,"-"))
2004         scriptname = "";
2005     if (fdscript >= 0) {
2006         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
2007 #if defined(HAS_FCNTL) && defined(F_SETFD)
2008         if (rsfp)
2009             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2010 #endif
2011     }
2012     else if (preprocess) {
2013         char *cpp_cfg = CPPSTDIN;
2014         SV *cpp = NEWSV(0,0);
2015         SV *cmd = NEWSV(0,0);
2016
2017         if (strEQ(cpp_cfg, "cppstdin"))
2018             sv_catpvf(cpp, "%s/", BIN_EXP);
2019         sv_catpv(cpp, cpp_cfg);
2020
2021         sv_catpv(sv,"-I");
2022         sv_catpv(sv,PRIVLIB_EXP);
2023
2024 #ifdef MSDOS
2025         sv_setpvf(cmd, "\
2026 sed %s -e \"/^[^#]/b\" \
2027  -e \"/^#[      ]*include[      ]/b\" \
2028  -e \"/^#[      ]*define[       ]/b\" \
2029  -e \"/^#[      ]*if[   ]/b\" \
2030  -e \"/^#[      ]*ifdef[        ]/b\" \
2031  -e \"/^#[      ]*ifndef[       ]/b\" \
2032  -e \"/^#[      ]*else/b\" \
2033  -e \"/^#[      ]*elif[         ]/b\" \
2034  -e \"/^#[      ]*undef[        ]/b\" \
2035  -e \"/^#[      ]*endif/b\" \
2036  -e \"s/^#.*//\" \
2037  %s | %_ -C %_ %s",
2038           (doextract ? "-e \"1,/^#/d\n\"" : ""),
2039 #else
2040         sv_setpvf(cmd, "\
2041 %s %s -e '/^[^#]/b' \
2042  -e '/^#[       ]*include[      ]/b' \
2043  -e '/^#[       ]*define[       ]/b' \
2044  -e '/^#[       ]*if[   ]/b' \
2045  -e '/^#[       ]*ifdef[        ]/b' \
2046  -e '/^#[       ]*ifndef[       ]/b' \
2047  -e '/^#[       ]*else/b' \
2048  -e '/^#[       ]*elif[         ]/b' \
2049  -e '/^#[       ]*undef[        ]/b' \
2050  -e '/^#[       ]*endif/b' \
2051  -e 's/^[       ]*#.*//' \
2052  %s | %_ -C %_ %s",
2053 #ifdef LOC_SED
2054           LOC_SED,
2055 #else
2056           "sed",
2057 #endif
2058           (doextract ? "-e '1,/^#/d\n'" : ""),
2059 #endif
2060           scriptname, cpp, sv, CPPMINUS);
2061         doextract = FALSE;
2062 #ifdef IAMSUID                          /* actually, this is caught earlier */
2063         if (euid != uid && !euid) {     /* if running suidperl */
2064 #ifdef HAS_SETEUID
2065             (void)seteuid(uid);         /* musn't stay setuid root */
2066 #else
2067 #ifdef HAS_SETREUID
2068             (void)setreuid((Uid_t)-1, uid);
2069 #else
2070 #ifdef HAS_SETRESUID
2071             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2072 #else
2073             setuid(uid);
2074 #endif
2075 #endif
2076 #endif
2077             if (geteuid() != uid)
2078                 croak("Can't do seteuid!\n");
2079         }
2080 #endif /* IAMSUID */
2081         rsfp = PerlProc_popen(SvPVX(cmd), "r");
2082         SvREFCNT_dec(cmd);
2083         SvREFCNT_dec(cpp);
2084     }
2085     else if (!*scriptname) {
2086         forbid_setid("program input from stdin");
2087         rsfp = PerlIO_stdin();
2088     }
2089     else {
2090         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2091 #if defined(HAS_FCNTL) && defined(F_SETFD)
2092         if (rsfp)
2093             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2094 #endif
2095     }
2096     if (e_tmpname) {
2097         e_fp = rsfp;
2098     }
2099     if (!rsfp) {
2100 #ifdef DOSUID
2101 #ifndef IAMSUID         /* in case script is not readable before setuid */
2102         if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2103           statbuf.st_mode & (S_ISUID|S_ISGID)) {
2104             /* try again */
2105             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2106             croak("Can't do setuid\n");
2107         }
2108 #endif
2109 #endif
2110         croak("Can't open perl script \"%s\": %s\n",
2111           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2112     }
2113 }
2114
2115 static void
2116 validate_suid(char *validarg, char *scriptname)
2117 {
2118     int which;
2119
2120     /* do we need to emulate setuid on scripts? */
2121
2122     /* This code is for those BSD systems that have setuid #! scripts disabled
2123      * in the kernel because of a security problem.  Merely defining DOSUID
2124      * in perl will not fix that problem, but if you have disabled setuid
2125      * scripts in the kernel, this will attempt to emulate setuid and setgid
2126      * on scripts that have those now-otherwise-useless bits set.  The setuid
2127      * root version must be called suidperl or sperlN.NNN.  If regular perl
2128      * discovers that it has opened a setuid script, it calls suidperl with
2129      * the same argv that it had.  If suidperl finds that the script it has
2130      * just opened is NOT setuid root, it sets the effective uid back to the
2131      * uid.  We don't just make perl setuid root because that loses the
2132      * effective uid we had before invoking perl, if it was different from the
2133      * uid.
2134      *
2135      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2136      * be defined in suidperl only.  suidperl must be setuid root.  The
2137      * Configure script will set this up for you if you want it.
2138      */
2139
2140 #ifdef DOSUID
2141     dTHR;
2142     char *s, *s2;
2143
2144     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2145         croak("Can't stat script \"%s\"",origfilename);
2146     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2147         I32 len;
2148
2149 #ifdef IAMSUID
2150 #ifndef HAS_SETREUID
2151         /* On this access check to make sure the directories are readable,
2152          * there is actually a small window that the user could use to make
2153          * filename point to an accessible directory.  So there is a faint
2154          * chance that someone could execute a setuid script down in a
2155          * non-accessible directory.  I don't know what to do about that.
2156          * But I don't think it's too important.  The manual lies when
2157          * it says access() is useful in setuid programs.
2158          */
2159         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2160             croak("Permission denied");
2161 #else
2162         /* If we can swap euid and uid, then we can determine access rights
2163          * with a simple stat of the file, and then compare device and
2164          * inode to make sure we did stat() on the same file we opened.
2165          * Then we just have to make sure he or she can execute it.
2166          */
2167         {
2168             struct stat tmpstatbuf;
2169
2170             if (
2171 #ifdef HAS_SETREUID
2172                 setreuid(euid,uid) < 0
2173 #else
2174 # if HAS_SETRESUID
2175                 setresuid(euid,uid,(Uid_t)-1) < 0
2176 # endif
2177 #endif
2178                 || getuid() != euid || geteuid() != uid)
2179                 croak("Can't swap uid and euid");       /* really paranoid */
2180             if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2181                 croak("Permission denied");     /* testing full pathname here */
2182             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2183                 tmpstatbuf.st_ino != statbuf.st_ino) {
2184                 (void)PerlIO_close(rsfp);
2185                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2186                     PerlIO_printf(rsfp,
2187 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2188 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2189                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2190                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2191                         SvPVX(GvSV(curcop->cop_filegv)),
2192                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2193                     (void)PerlProc_pclose(rsfp);
2194                 }
2195                 croak("Permission denied\n");
2196             }
2197             if (
2198 #ifdef HAS_SETREUID
2199               setreuid(uid,euid) < 0
2200 #else
2201 # if defined(HAS_SETRESUID)
2202               setresuid(uid,euid,(Uid_t)-1) < 0
2203 # endif
2204 #endif
2205               || getuid() != uid || geteuid() != euid)
2206                 croak("Can't reswap uid and euid");
2207             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2208                 croak("Permission denied\n");
2209         }
2210 #endif /* HAS_SETREUID */
2211 #endif /* IAMSUID */
2212
2213         if (!S_ISREG(statbuf.st_mode))
2214             croak("Permission denied");
2215         if (statbuf.st_mode & S_IWOTH)
2216             croak("Setuid/gid script is writable by world");
2217         doswitches = FALSE;             /* -s is insecure in suid */
2218         curcop->cop_line++;
2219         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2220           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2221             croak("No #! line");
2222         s = SvPV(linestr,na)+2;
2223         if (*s == ' ') s++;
2224         while (!isSPACE(*s)) s++;
2225         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2226                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2227         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2228             croak("Not a perl script");
2229         while (*s == ' ' || *s == '\t') s++;
2230         /*
2231          * #! arg must be what we saw above.  They can invoke it by
2232          * mentioning suidperl explicitly, but they may not add any strange
2233          * arguments beyond what #! says if they do invoke suidperl that way.
2234          */
2235         len = strlen(validarg);
2236         if (strEQ(validarg," PHOOEY ") ||
2237             strnNE(s,validarg,len) || !isSPACE(s[len]))
2238             croak("Args must match #! line");
2239
2240 #ifndef IAMSUID
2241         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2242             euid == statbuf.st_uid)
2243             if (!do_undump)
2244                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2245 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2246 #endif /* IAMSUID */
2247
2248         if (euid) {     /* oops, we're not the setuid root perl */
2249             (void)PerlIO_close(rsfp);
2250 #ifndef IAMSUID
2251             /* try again */
2252             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2253 #endif
2254             croak("Can't do setuid\n");
2255         }
2256
2257         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2258 #ifdef HAS_SETEGID
2259             (void)setegid(statbuf.st_gid);
2260 #else
2261 #ifdef HAS_SETREGID
2262            (void)setregid((Gid_t)-1,statbuf.st_gid);
2263 #else
2264 #ifdef HAS_SETRESGID
2265            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2266 #else
2267             setgid(statbuf.st_gid);
2268 #endif
2269 #endif
2270 #endif
2271             if (getegid() != statbuf.st_gid)
2272                 croak("Can't do setegid!\n");
2273         }
2274         if (statbuf.st_mode & S_ISUID) {
2275             if (statbuf.st_uid != euid)
2276 #ifdef HAS_SETEUID
2277                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2278 #else
2279 #ifdef HAS_SETREUID
2280                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2281 #else
2282 #ifdef HAS_SETRESUID
2283                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2284 #else
2285                 setuid(statbuf.st_uid);
2286 #endif
2287 #endif
2288 #endif
2289             if (geteuid() != statbuf.st_uid)
2290                 croak("Can't do seteuid!\n");
2291         }
2292         else if (uid) {                 /* oops, mustn't run as root */
2293 #ifdef HAS_SETEUID
2294           (void)seteuid((Uid_t)uid);
2295 #else
2296 #ifdef HAS_SETREUID
2297           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2298 #else
2299 #ifdef HAS_SETRESUID
2300           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2301 #else
2302           setuid((Uid_t)uid);
2303 #endif
2304 #endif
2305 #endif
2306             if (geteuid() != uid)
2307                 croak("Can't do seteuid!\n");
2308         }
2309         init_ids();
2310         if (!cando(S_IXUSR,TRUE,&statbuf))
2311             croak("Permission denied\n");       /* they can't do this */
2312     }
2313 #ifdef IAMSUID
2314     else if (preprocess)
2315         croak("-P not allowed for setuid/setgid script\n");
2316     else if (fdscript >= 0)
2317         croak("fd script not allowed in suidperl\n");
2318     else
2319         croak("Script is not setuid/setgid in suidperl\n");
2320
2321     /* We absolutely must clear out any saved ids here, so we */
2322     /* exec the real perl, substituting fd script for scriptname. */
2323     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2324     PerlIO_rewind(rsfp);
2325     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2326     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2327     if (!origargv[which])
2328         croak("Permission denied");
2329     origargv[which] = savepv(form("/dev/fd/%d/%s",
2330                                   PerlIO_fileno(rsfp), origargv[which]));
2331 #if defined(HAS_FCNTL) && defined(F_SETFD)
2332     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2333 #endif
2334     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2335     croak("Can't do setuid\n");
2336 #endif /* IAMSUID */
2337 #else /* !DOSUID */
2338     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2339 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2340         dTHR;
2341         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2342         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2343             ||
2344             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2345            )
2346             if (!do_undump)
2347                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2348 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2349 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2350         /* not set-id, must be wrapped */
2351     }
2352 #endif /* DOSUID */
2353 }
2354
2355 static void
2356 find_beginning(void)
2357 {
2358     register char *s, *s2;
2359
2360     /* skip forward in input to the real script? */
2361
2362     forbid_setid("-x");
2363     while (doextract) {
2364         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2365             croak("No Perl script found in input\n");
2366         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2367             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2368             doextract = FALSE;
2369             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2370             s2 = s;
2371             while (*s == ' ' || *s == '\t') s++;
2372             if (*s++ == '-') {
2373                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2374                 if (strnEQ(s2-4,"perl",4))
2375                     /*SUPPRESS 530*/
2376                     while (s = moreswitches(s)) ;
2377             }
2378             if (cddir && PerlDir_chdir(cddir) < 0)
2379                 croak("Can't chdir to %s",cddir);
2380         }
2381     }
2382 }
2383
2384 static void
2385 init_ids(void)
2386 {
2387     uid = (int)getuid();
2388     euid = (int)geteuid();
2389     gid = (int)getgid();
2390     egid = (int)getegid();
2391 #ifdef VMS
2392     uid |= gid << 16;
2393     euid |= egid << 16;
2394 #endif
2395     tainting |= (uid && (euid != uid || egid != gid));
2396 }
2397
2398 static void
2399 forbid_setid(char *s)
2400 {
2401     if (euid != uid)
2402         croak("No %s allowed while running setuid", s);
2403     if (egid != gid)
2404         croak("No %s allowed while running setgid", s);
2405 }
2406
2407 static void
2408 init_debugger(void)
2409 {
2410     dTHR;
2411     curstash = debstash;
2412     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2413     AvREAL_off(dbargs);
2414     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2415     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2416     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2417     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2418     sv_setiv(DBsingle, 0);
2419     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2420     sv_setiv(DBtrace, 0);
2421     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2422     sv_setiv(DBsignal, 0);
2423     curstash = defstash;
2424 }
2425
2426 #ifndef STRESS_REALLOC
2427 #define REASONABLE(size) (size)
2428 #else
2429 #define REASONABLE(size) (1) /* unreasonable */
2430 #endif
2431
2432 void
2433 init_stacks(ARGSproto)
2434 {
2435     curstack = newAV();
2436     mainstack = curstack;               /* remember in case we switch stacks */
2437     AvREAL_off(curstack);               /* not a real array */
2438     av_extend(curstack,REASONABLE(127));
2439
2440     stack_base = AvARRAY(curstack);
2441     stack_sp = stack_base;
2442     stack_max = stack_base + REASONABLE(127);
2443
2444     /* Use most of 8K. */
2445     cxstack_max = REASONABLE(8192 / sizeof(PERL_CONTEXT) - 2);
2446     New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2447     cxstack_ix  = -1;
2448
2449     New(50,tmps_stack,REASONABLE(128),SV*);
2450     tmps_floor = -1;
2451     tmps_ix = -1;
2452     tmps_max = REASONABLE(128);
2453
2454     /*
2455      * The following stacks almost certainly should be per-interpreter,
2456      * but for now they're not.  XXX
2457      */
2458
2459     if (markstack) {
2460         markstack_ptr = markstack;
2461     } else {
2462         New(54,markstack,REASONABLE(32),I32);
2463         markstack_ptr = markstack;
2464         markstack_max = markstack + REASONABLE(32);
2465     }
2466
2467     if (scopestack) {
2468         scopestack_ix = 0;
2469     } else {
2470         New(54,scopestack,REASONABLE(32),I32);
2471         scopestack_ix = 0;
2472         scopestack_max = REASONABLE(32);
2473     }
2474
2475     if (savestack) {
2476         savestack_ix = 0;
2477     } else {
2478         New(54,savestack,REASONABLE(128),ANY);
2479         savestack_ix = 0;
2480         savestack_max = REASONABLE(128);
2481     }
2482
2483     if (retstack) {
2484         retstack_ix = 0;
2485     } else {
2486         New(54,retstack,REASONABLE(16),OP*);
2487         retstack_ix = 0;
2488         retstack_max = REASONABLE(16);
2489     }
2490 }
2491
2492 #undef REASONABLE
2493
2494 static void
2495 nuke_stacks(void)
2496 {
2497     dTHR;
2498     Safefree(cxstack);
2499     Safefree(tmps_stack);
2500     DEBUG( {
2501         Safefree(debname);
2502         Safefree(debdelim);
2503     } )
2504 }
2505
2506 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2507
2508 static void
2509 init_lexer(void)
2510 {
2511     tmpfp = rsfp;
2512     rsfp = Nullfp;
2513     lex_start(linestr);
2514     rsfp = tmpfp;
2515     subname = newSVpv("main",4);
2516 }
2517
2518 static void
2519 init_predump_symbols(void)
2520 {
2521     dTHR;
2522     GV *tmpgv;
2523     GV *othergv;
2524
2525     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2526     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2527     GvMULTI_on(stdingv);
2528     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2529     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2530     GvMULTI_on(tmpgv);
2531     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2532
2533     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2534     GvMULTI_on(tmpgv);
2535     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2536     setdefout(tmpgv);
2537     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2538     GvMULTI_on(tmpgv);
2539     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2540
2541     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2542     GvMULTI_on(othergv);
2543     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2544     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2545     GvMULTI_on(tmpgv);
2546     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2547
2548     statname = NEWSV(66,0);             /* last filename we did stat on */
2549
2550     if (!osname)
2551         osname = savepv(OSNAME);
2552 }
2553
2554 static void
2555 init_postdump_symbols(register int argc, register char **argv, register char **env)
2556 {
2557     dTHR;
2558     char *s;
2559     SV *sv;
2560     GV* tmpgv;
2561
2562     argc--,argv++;      /* skip name of script */
2563     if (doswitches) {
2564         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2565             if (!argv[0][1])
2566                 break;
2567             if (argv[0][1] == '-') {
2568                 argc--,argv++;
2569                 break;
2570             }
2571             if (s = strchr(argv[0], '=')) {
2572                 *s++ = '\0';
2573                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2574             }
2575             else
2576                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2577         }
2578     }
2579     toptarget = NEWSV(0,0);
2580     sv_upgrade(toptarget, SVt_PVFM);
2581     sv_setpvn(toptarget, "", 0);
2582     bodytarget = NEWSV(0,0);
2583     sv_upgrade(bodytarget, SVt_PVFM);
2584     sv_setpvn(bodytarget, "", 0);
2585     formtarget = bodytarget;
2586
2587     TAINT;
2588     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2589         sv_setpv(GvSV(tmpgv),origfilename);
2590         magicname("0", "0", 1);
2591     }
2592     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2593         sv_setpv(GvSV(tmpgv),origargv[0]);
2594     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2595         GvMULTI_on(argvgv);
2596         (void)gv_AVadd(argvgv);
2597         av_clear(GvAVn(argvgv));
2598         for (; argc > 0; argc--,argv++) {
2599             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2600         }
2601     }
2602     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2603         HV *hv;
2604         GvMULTI_on(envgv);
2605         hv = GvHVn(envgv);
2606         hv_magic(hv, envgv, 'E');
2607 #ifndef VMS  /* VMS doesn't have environ array */
2608         /* Note that if the supplied env parameter is actually a copy
2609            of the global environ then it may now point to free'd memory
2610            if the environment has been modified since. To avoid this
2611            problem we treat env==NULL as meaning 'use the default'
2612         */
2613         if (!env)
2614             env = environ;
2615         if (env != environ)
2616             environ[0] = Nullch;
2617         for (; *env; env++) {
2618             if (!(s = strchr(*env,'=')))
2619                 continue;
2620             *s++ = '\0';
2621 #if defined(WIN32) || defined(MSDOS)
2622             (void)strupr(*env);
2623 #endif
2624             sv = newSVpv(s--,0);
2625             (void)hv_store(hv, *env, s - *env, sv, 0);
2626             *s = '=';
2627 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2628             /* Sins of the RTL. See note in my_setenv(). */
2629             (void)PerlEnv_putenv(savepv(*env));
2630 #endif
2631         }
2632 #endif
2633 #ifdef DYNAMIC_ENV_FETCH
2634         HvNAME(hv) = savepv(ENV_HV_NAME);
2635 #endif
2636     }
2637     TAINT_NOT;
2638     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2639         sv_setiv(GvSV(tmpgv), (IV)getpid());
2640 }
2641
2642 static void
2643 init_perllib(void)
2644 {
2645     char *s;
2646     if (!tainting) {
2647 #ifndef VMS
2648         s = PerlEnv_getenv("PERL5LIB");
2649         if (s)
2650             incpush(s, TRUE);
2651         else
2652             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2653 #else /* VMS */
2654         /* Treat PERL5?LIB as a possible search list logical name -- the
2655          * "natural" VMS idiom for a Unix path string.  We allow each
2656          * element to be a set of |-separated directories for compatibility.
2657          */
2658         char buf[256];
2659         int idx = 0;
2660         if (my_trnlnm("PERL5LIB",buf,0))
2661             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2662         else
2663             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2664 #endif /* VMS */
2665     }
2666
2667 /* Use the ~-expanded versions of APPLLIB (undocumented),
2668     ARCHLIB PRIVLIB SITEARCH and SITELIB
2669 */
2670 #ifdef APPLLIB_EXP
2671     incpush(APPLLIB_EXP, FALSE);
2672 #endif
2673
2674 #ifdef ARCHLIB_EXP
2675     incpush(ARCHLIB_EXP, FALSE);
2676 #endif
2677 #ifndef PRIVLIB_EXP
2678 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2679 #endif
2680     incpush(PRIVLIB_EXP, FALSE);
2681
2682 #ifdef SITEARCH_EXP
2683     incpush(SITEARCH_EXP, FALSE);
2684 #endif
2685 #ifdef SITELIB_EXP
2686     incpush(SITELIB_EXP, FALSE);
2687 #endif
2688     if (!tainting)
2689         incpush(".", FALSE);
2690 }
2691
2692 #if defined(DOSISH)
2693 #    define PERLLIB_SEP ';'
2694 #else
2695 #  if defined(VMS)
2696 #    define PERLLIB_SEP '|'
2697 #  else
2698 #    define PERLLIB_SEP ':'
2699 #  endif
2700 #endif
2701 #ifndef PERLLIB_MANGLE
2702 #  define PERLLIB_MANGLE(s,n) (s)
2703 #endif
2704
2705 static void
2706 incpush(char *p, int addsubdirs)
2707 {
2708     SV *subdir = Nullsv;
2709     static char *archpat_auto;
2710
2711     if (!p)
2712         return;
2713
2714     if (addsubdirs) {
2715         subdir = NEWSV(55,0);
2716         if (!archpat_auto) {
2717             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2718                           + sizeof("//auto"));
2719             New(55, archpat_auto, len, char);
2720             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2721 #ifdef VMS
2722         for (len = sizeof(ARCHNAME) + 2;
2723              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2724                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2725 #endif
2726         }
2727     }
2728
2729     /* Break at all separators */
2730     while (p && *p) {
2731         SV *libdir = NEWSV(55,0);
2732         char *s;
2733
2734         /* skip any consecutive separators */
2735         while ( *p == PERLLIB_SEP ) {
2736             /* Uncomment the next line for PATH semantics */
2737             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2738             p++;
2739         }
2740
2741         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2742             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2743                       (STRLEN)(s - p));
2744             p = s + 1;
2745         }
2746         else {
2747             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2748             p = Nullch; /* break out */
2749         }
2750
2751         /*
2752          * BEFORE pushing libdir onto @INC we may first push version- and
2753          * archname-specific sub-directories.
2754          */
2755         if (addsubdirs) {
2756             struct stat tmpstatbuf;
2757 #ifdef VMS
2758             char *unix;
2759             STRLEN len;
2760
2761             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2762                 len = strlen(unix);
2763                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2764                 sv_usepvn(libdir,unix,len);
2765             }
2766             else
2767                 PerlIO_printf(PerlIO_stderr(),
2768                               "Failed to unixify @INC element \"%s\"\n",
2769                               SvPV(libdir,na));
2770 #endif
2771             /* .../archname/version if -d .../archname/version/auto */
2772             sv_setsv(subdir, libdir);
2773             sv_catpv(subdir, archpat_auto);
2774             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2775                   S_ISDIR(tmpstatbuf.st_mode))
2776                 av_push(GvAVn(incgv),
2777                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2778
2779             /* .../archname if -d .../archname/auto */
2780             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2781                       strlen(patchlevel) + 1, "", 0);
2782             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2783                   S_ISDIR(tmpstatbuf.st_mode))
2784                 av_push(GvAVn(incgv),
2785                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2786         }
2787
2788         /* finally push this lib directory on the end of @INC */
2789         av_push(GvAVn(incgv), libdir);
2790     }
2791
2792     SvREFCNT_dec(subdir);
2793 }
2794
2795 #ifdef USE_THREADS
2796 static struct perl_thread *
2797 init_main_thread()
2798 {
2799     struct perl_thread *thr;
2800     XPV *xpv;
2801
2802     Newz(53, thr, 1, struct perl_thread);
2803     curcop = &compiling;
2804     thr->cvcache = newHV();
2805     thr->threadsv = newAV();
2806     /* thr->threadsvp is set when find_threadsv is called */
2807     thr->specific = newAV();
2808     thr->errhv = newHV();
2809     thr->flags = THRf_R_JOINABLE;
2810     MUTEX_INIT(&thr->mutex);
2811     /* Handcraft thrsv similarly to mess_sv */
2812     New(53, thrsv, 1, SV);
2813     Newz(53, xpv, 1, XPV);
2814     SvFLAGS(thrsv) = SVt_PV;
2815     SvANY(thrsv) = (void*)xpv;
2816     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2817     SvPVX(thrsv) = (char*)thr;
2818     SvCUR_set(thrsv, sizeof(thr));
2819     SvLEN_set(thrsv, sizeof(thr));
2820     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2821     thr->oursv = thrsv;
2822     curcop = &compiling;
2823     chopset = " \n-";
2824
2825     MUTEX_LOCK(&threads_mutex);
2826     nthreads++;
2827     thr->tid = 0;
2828     thr->next = thr;
2829     thr->prev = thr;
2830     MUTEX_UNLOCK(&threads_mutex);
2831
2832 #ifdef HAVE_THREAD_INTERN
2833     init_thread_intern(thr);
2834 #endif
2835
2836 #ifdef SET_THREAD_SELF
2837     SET_THREAD_SELF(thr);
2838 #else
2839     thr->self = pthread_self();
2840 #endif /* SET_THREAD_SELF */
2841     SET_THR(thr);
2842
2843     /*
2844      * These must come after the SET_THR because sv_setpvn does
2845      * SvTAINT and the taint fields require dTHR.
2846      */
2847     toptarget = NEWSV(0,0);
2848     sv_upgrade(toptarget, SVt_PVFM);
2849     sv_setpvn(toptarget, "", 0);
2850     bodytarget = NEWSV(0,0);
2851     sv_upgrade(bodytarget, SVt_PVFM);
2852     sv_setpvn(bodytarget, "", 0);
2853     formtarget = bodytarget;
2854     thr->errsv = newSVpv("", 0);
2855     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2856     return thr;
2857 }
2858 #endif /* USE_THREADS */
2859
2860 void
2861 call_list(I32 oldscope, AV *list)
2862 {
2863     dTHR;
2864     line_t oldline = curcop->cop_line;
2865     STRLEN len;
2866     dJMPENV;
2867     int ret;
2868
2869     while (AvFILL(list) >= 0) {
2870         CV *cv = (CV*)av_shift(list);
2871
2872         SAVEFREESV(cv);
2873
2874         JMPENV_PUSH(ret);
2875         switch (ret) {
2876         case 0: {
2877                 SV* atsv = ERRSV;
2878                 PUSHMARK(stack_sp);
2879                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2880                 (void)SvPV(atsv, len);
2881                 if (len) {
2882                     JMPENV_POP;
2883                     curcop = &compiling;
2884                     curcop->cop_line = oldline;
2885                     if (list == beginav)
2886                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2887                     else
2888                         sv_catpv(atsv, "END failed--cleanup aborted");
2889                     while (scopestack_ix > oldscope)
2890                         LEAVE;
2891                     croak("%s", SvPVX(atsv));
2892                 }
2893             }
2894             break;
2895         case 1:
2896             STATUS_ALL_FAILURE;
2897             /* FALL THROUGH */
2898         case 2:
2899             /* my_exit() was called */
2900             while (scopestack_ix > oldscope)
2901                 LEAVE;
2902             FREETMPS;
2903             curstash = defstash;
2904             if (endav)
2905                 call_list(oldscope, endav);
2906             JMPENV_POP;
2907             curcop = &compiling;
2908             curcop->cop_line = oldline;
2909             if (statusvalue) {
2910                 if (list == beginav)
2911                     croak("BEGIN failed--compilation aborted");
2912                 else
2913                     croak("END failed--cleanup aborted");
2914             }
2915             my_exit_jump();
2916             /* NOTREACHED */
2917         case 3:
2918             if (!restartop) {
2919                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2920                 FREETMPS;
2921                 break;
2922             }
2923             JMPENV_POP;
2924             curcop = &compiling;
2925             curcop->cop_line = oldline;
2926             JMPENV_JUMP(3);
2927         }
2928         JMPENV_POP;
2929     }
2930 }
2931
2932 void
2933 my_exit(U32 status)
2934 {
2935     dTHR;
2936
2937 #ifdef USE_THREADS
2938     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2939                           thr, (unsigned long) status));
2940 #endif /* USE_THREADS */
2941     switch (status) {
2942     case 0:
2943         STATUS_ALL_SUCCESS;
2944         break;
2945     case 1:
2946         STATUS_ALL_FAILURE;
2947         break;
2948     default:
2949         STATUS_NATIVE_SET(status);
2950         break;
2951     }
2952     my_exit_jump();
2953 }
2954
2955 void
2956 my_failure_exit(void)
2957 {
2958 #ifdef VMS
2959     if (vaxc$errno & 1) {
2960         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2961             STATUS_NATIVE_SET(44);
2962     }
2963     else {
2964         if (!vaxc$errno && errno)       /* unlikely */
2965             STATUS_NATIVE_SET(44);
2966         else
2967             STATUS_NATIVE_SET(vaxc$errno);
2968     }
2969 #else
2970     if (errno & 255)
2971         STATUS_POSIX_SET(errno);
2972     else if (STATUS_POSIX == 0)
2973         STATUS_POSIX_SET(255);
2974 #endif
2975     my_exit_jump();
2976 }
2977
2978 static void
2979 my_exit_jump(void)
2980 {
2981     dTHR;
2982     register PERL_CONTEXT *cx;
2983     I32 gimme;
2984     SV **newsp;
2985
2986     if (e_tmpname) {
2987         if (e_fp) {
2988             PerlIO_close(e_fp);
2989             e_fp = Nullfp;
2990         }
2991         (void)UNLINK(e_tmpname);
2992         Safefree(e_tmpname);
2993         e_tmpname = Nullch;
2994     }
2995
2996     if (cxstack_ix >= 0) {
2997         if (cxstack_ix > 0)
2998             dounwind(0);
2999         POPBLOCK(cx,curpm);
3000         LEAVE;
3001     }
3002
3003     JMPENV_JUMP(2);
3004 }
3005
3006
3007