perl.c

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