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