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