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