perl.c

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