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