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