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