perl.c

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