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