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