perl.c

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