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