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