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