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 #if 0
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 #endif
1816
1817 #define PERLVAR(var,type)
1818 #define PERLVARI(var,type,init)         curinterp->var = init;
1819 #define PERLVARIC(var,type,init)        curinterp->var = init;
1820 #include "intrpvar.h"
1821 #ifndef USE_THREADS
1822 #  include "thrdvar.h"
1823 #endif
1824 #undef PERLVAR
1825 #undef PERLVARI
1826 #undef PERLVARIC
1827
1828 }
1829
1830 STATIC void
1831 init_main_stash(void)
1832 {
1833     dTHR;
1834     GV *gv;
1835
1836     /* Note that strtab is a rather special HV.  Assumptions are made
1837        about not iterating on it, and not adding tie magic to it.
1838        It is properly deallocated in perl_destruct() */
1839     strtab = newHV();
1840     HvSHAREKEYS_off(strtab);                    /* mandatory */
1841     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1842          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1843
1844     curstash = defstash = newHV();
1845     curstname = newSVpv("main",4);
1846     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1847     SvREFCNT_dec(GvHV(gv));
1848     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1849     SvREADONLY_on(gv);
1850     HvNAME(defstash) = savepv("main");
1851     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1852     GvMULTI_on(incgv);
1853     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1854     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1855     GvMULTI_on(errgv);
1856     replgv = gv_HVadd(gv_fetchpv("\022", TRUE, SVt_PV)); /* ^R */
1857     GvMULTI_on(replgv);
1858     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1859     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1860     sv_setpvn(ERRSV, "", 0);
1861     curstash = defstash;
1862     compiling.cop_stash = defstash;
1863     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1864     globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1865     /* We must init $/ before switches are processed. */
1866     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1867 }
1868
1869 STATIC void
1870 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
1871 {
1872     dTHR;
1873     register char *s;
1874
1875     scriptname = find_script(scriptname, dosearch, NULL, 0);
1876
1877     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1878         char *s = scriptname + 8;
1879         *fdscript = atoi(s);
1880         while (isDIGIT(*s))
1881             s++;
1882         if (*s)
1883             scriptname = s + 1;
1884     }
1885     else
1886         *fdscript = -1;
1887     origfilename = savepv(e_script ? "-e" : scriptname);
1888     curcop->cop_filegv = gv_fetchfile(origfilename);
1889     if (strEQ(origfilename,"-"))
1890         scriptname = "";
1891     if (*fdscript >= 0) {
1892         rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1893 #if defined(HAS_FCNTL) && defined(F_SETFD)
1894         if (rsfp)
1895             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1896 #endif
1897     }
1898     else if (preprocess) {
1899         char *cpp_cfg = CPPSTDIN;
1900         SV *cpp = NEWSV(0,0);
1901         SV *cmd = NEWSV(0,0);
1902
1903         if (strEQ(cpp_cfg, "cppstdin"))
1904             sv_catpvf(cpp, "%s/", BIN_EXP);
1905         sv_catpv(cpp, cpp_cfg);
1906
1907         sv_catpv(sv,"-I");
1908         sv_catpv(sv,PRIVLIB_EXP);
1909
1910 #ifdef MSDOS
1911         sv_setpvf(cmd, "\
1912 sed %s -e \"/^[^#]/b\" \
1913  -e \"/^#[      ]*include[      ]/b\" \
1914  -e \"/^#[      ]*define[       ]/b\" \
1915  -e \"/^#[      ]*if[   ]/b\" \
1916  -e \"/^#[      ]*ifdef[        ]/b\" \
1917  -e \"/^#[      ]*ifndef[       ]/b\" \
1918  -e \"/^#[      ]*else/b\" \
1919  -e \"/^#[      ]*elif[         ]/b\" \
1920  -e \"/^#[      ]*undef[        ]/b\" \
1921  -e \"/^#[      ]*endif/b\" \
1922  -e \"s/^#.*//\" \
1923  %s | %_ -C %_ %s",
1924           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1925 #else
1926         sv_setpvf(cmd, "\
1927 %s %s -e '/^[^#]/b' \
1928  -e '/^#[       ]*include[      ]/b' \
1929  -e '/^#[       ]*define[       ]/b' \
1930  -e '/^#[       ]*if[   ]/b' \
1931  -e '/^#[       ]*ifdef[        ]/b' \
1932  -e '/^#[       ]*ifndef[       ]/b' \
1933  -e '/^#[       ]*else/b' \
1934  -e '/^#[       ]*elif[         ]/b' \
1935  -e '/^#[       ]*undef[        ]/b' \
1936  -e '/^#[       ]*endif/b' \
1937  -e 's/^[       ]*#.*//' \
1938  %s | %_ -C %_ %s",
1939 #ifdef LOC_SED
1940           LOC_SED,
1941 #else
1942           "sed",
1943 #endif
1944           (doextract ? "-e '1,/^#/d\n'" : ""),
1945 #endif
1946           scriptname, cpp, sv, CPPMINUS);
1947         doextract = FALSE;
1948 #ifdef IAMSUID                          /* actually, this is caught earlier */
1949         if (euid != uid && !euid) {     /* if running suidperl */
1950 #ifdef HAS_SETEUID
1951             (void)seteuid(uid);         /* musn't stay setuid root */
1952 #else
1953 #ifdef HAS_SETREUID
1954             (void)setreuid((Uid_t)-1, uid);
1955 #else
1956 #ifdef HAS_SETRESUID
1957             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1958 #else
1959             PerlProc_setuid(uid);
1960 #endif
1961 #endif
1962 #endif
1963             if (PerlProc_geteuid() != uid)
1964                 croak("Can't do seteuid!\n");
1965         }
1966 #endif /* IAMSUID */
1967         rsfp = PerlProc_popen(SvPVX(cmd), "r");
1968         SvREFCNT_dec(cmd);
1969         SvREFCNT_dec(cpp);
1970     }
1971     else if (!*scriptname) {
1972         forbid_setid("program input from stdin");
1973         rsfp = PerlIO_stdin();
1974     }
1975     else {
1976         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1977 #if defined(HAS_FCNTL) && defined(F_SETFD)
1978         if (rsfp)
1979             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1980 #endif
1981     }
1982     if (!rsfp) {
1983 #ifdef DOSUID
1984 #ifndef IAMSUID         /* in case script is not readable before setuid */
1985         if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1986           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1987             /* try again */
1988             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1989             croak("Can't do setuid\n");
1990         }
1991 #endif
1992 #endif
1993         croak("Can't open perl script \"%s\": %s\n",
1994           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1995     }
1996 }
1997
1998 STATIC void
1999 validate_suid(char *validarg, char *scriptname, int fdscript)
2000 {
2001     int which;
2002
2003     /* do we need to emulate setuid on scripts? */
2004
2005     /* This code is for those BSD systems that have setuid #! scripts disabled
2006      * in the kernel because of a security problem.  Merely defining DOSUID
2007      * in perl will not fix that problem, but if you have disabled setuid
2008      * scripts in the kernel, this will attempt to emulate setuid and setgid
2009      * on scripts that have those now-otherwise-useless bits set.  The setuid
2010      * root version must be called suidperl or sperlN.NNN.  If regular perl
2011      * discovers that it has opened a setuid script, it calls suidperl with
2012      * the same argv that it had.  If suidperl finds that the script it has
2013      * just opened is NOT setuid root, it sets the effective uid back to the
2014      * uid.  We don't just make perl setuid root because that loses the
2015      * effective uid we had before invoking perl, if it was different from the
2016      * uid.
2017      *
2018      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2019      * be defined in suidperl only.  suidperl must be setuid root.  The
2020      * Configure script will set this up for you if you want it.
2021      */
2022
2023 #ifdef DOSUID
2024     dTHR;
2025     char *s, *s2;
2026
2027     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2028         croak("Can't stat script \"%s\"",origfilename);
2029     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2030         I32 len;
2031
2032 #ifdef IAMSUID
2033 #ifndef HAS_SETREUID
2034         /* On this access check to make sure the directories are readable,
2035          * there is actually a small window that the user could use to make
2036          * filename point to an accessible directory.  So there is a faint
2037          * chance that someone could execute a setuid script down in a
2038          * non-accessible directory.  I don't know what to do about that.
2039          * But I don't think it's too important.  The manual lies when
2040          * it says access() is useful in setuid programs.
2041          */
2042         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2043             croak("Permission denied");
2044 #else
2045         /* If we can swap euid and uid, then we can determine access rights
2046          * with a simple stat of the file, and then compare device and
2047          * inode to make sure we did stat() on the same file we opened.
2048          * Then we just have to make sure he or she can execute it.
2049          */
2050         {
2051             struct stat tmpstatbuf;
2052
2053             if (
2054 #ifdef HAS_SETREUID
2055                 setreuid(euid,uid) < 0
2056 #else
2057 # if HAS_SETRESUID
2058                 setresuid(euid,uid,(Uid_t)-1) < 0
2059 # endif
2060 #endif
2061                 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
2062                 croak("Can't swap uid and euid");       /* really paranoid */
2063             if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2064                 croak("Permission denied");     /* testing full pathname here */
2065             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2066                 tmpstatbuf.st_ino != statbuf.st_ino) {
2067                 (void)PerlIO_close(rsfp);
2068                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2069                     PerlIO_printf(rsfp,
2070 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2071 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2072                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2073                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2074                         SvPVX(GvSV(curcop->cop_filegv)),
2075                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2076                     (void)PerlProc_pclose(rsfp);
2077                 }
2078                 croak("Permission denied\n");
2079             }
2080             if (
2081 #ifdef HAS_SETREUID
2082               setreuid(uid,euid) < 0
2083 #else
2084 # if defined(HAS_SETRESUID)
2085               setresuid(uid,euid,(Uid_t)-1) < 0
2086 # endif
2087 #endif
2088               || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
2089                 croak("Can't reswap uid and euid");
2090             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2091                 croak("Permission denied\n");
2092         }
2093 #endif /* HAS_SETREUID */
2094 #endif /* IAMSUID */
2095
2096         if (!S_ISREG(statbuf.st_mode))
2097             croak("Permission denied");
2098         if (statbuf.st_mode & S_IWOTH)
2099             croak("Setuid/gid script is writable by world");
2100         doswitches = FALSE;             /* -s is insecure in suid */
2101         curcop->cop_line++;
2102         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2103           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2104             croak("No #! line");
2105         s = SvPV(linestr,na)+2;
2106         if (*s == ' ') s++;
2107         while (!isSPACE(*s)) s++;
2108         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2109                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2110         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2111             croak("Not a perl script");
2112         while (*s == ' ' || *s == '\t') s++;
2113         /*
2114          * #! arg must be what we saw above.  They can invoke it by
2115          * mentioning suidperl explicitly, but they may not add any strange
2116          * arguments beyond what #! says if they do invoke suidperl that way.
2117          */
2118         len = strlen(validarg);
2119         if (strEQ(validarg," PHOOEY ") ||
2120             strnNE(s,validarg,len) || !isSPACE(s[len]))
2121             croak("Args must match #! line");
2122
2123 #ifndef IAMSUID
2124         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2125             euid == statbuf.st_uid)
2126             if (!do_undump)
2127                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2128 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2129 #endif /* IAMSUID */
2130
2131         if (euid) {     /* oops, we're not the setuid root perl */
2132             (void)PerlIO_close(rsfp);
2133 #ifndef IAMSUID
2134             /* try again */
2135             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2136 #endif
2137             croak("Can't do setuid\n");
2138         }
2139
2140         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2141 #ifdef HAS_SETEGID
2142             (void)setegid(statbuf.st_gid);
2143 #else
2144 #ifdef HAS_SETREGID
2145            (void)setregid((Gid_t)-1,statbuf.st_gid);
2146 #else
2147 #ifdef HAS_SETRESGID
2148            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2149 #else
2150             PerlProc_setgid(statbuf.st_gid);
2151 #endif
2152 #endif
2153 #endif
2154             if (PerlProc_getegid() != statbuf.st_gid)
2155                 croak("Can't do setegid!\n");
2156         }
2157         if (statbuf.st_mode & S_ISUID) {
2158             if (statbuf.st_uid != euid)
2159 #ifdef HAS_SETEUID
2160                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2161 #else
2162 #ifdef HAS_SETREUID
2163                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2164 #else
2165 #ifdef HAS_SETRESUID
2166                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2167 #else
2168                 PerlProc_setuid(statbuf.st_uid);
2169 #endif
2170 #endif
2171 #endif
2172             if (PerlProc_geteuid() != statbuf.st_uid)
2173                 croak("Can't do seteuid!\n");
2174         }
2175         else if (uid) {                 /* oops, mustn't run as root */
2176 #ifdef HAS_SETEUID
2177           (void)seteuid((Uid_t)uid);
2178 #else
2179 #ifdef HAS_SETREUID
2180           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2181 #else
2182 #ifdef HAS_SETRESUID
2183           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2184 #else
2185           PerlProc_setuid((Uid_t)uid);
2186 #endif
2187 #endif
2188 #endif
2189             if (PerlProc_geteuid() != uid)
2190                 croak("Can't do seteuid!\n");
2191         }
2192         init_ids();
2193         if (!cando(S_IXUSR,TRUE,&statbuf))
2194             croak("Permission denied\n");       /* they can't do this */
2195     }
2196 #ifdef IAMSUID
2197     else if (preprocess)
2198         croak("-P not allowed for setuid/setgid script\n");
2199     else if (fdscript >= 0)
2200         croak("fd script not allowed in suidperl\n");
2201     else
2202         croak("Script is not setuid/setgid in suidperl\n");
2203
2204     /* We absolutely must clear out any saved ids here, so we */
2205     /* exec the real perl, substituting fd script for scriptname. */
2206     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2207     PerlIO_rewind(rsfp);
2208     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2209     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2210     if (!origargv[which])
2211         croak("Permission denied");
2212     origargv[which] = savepv(form("/dev/fd/%d/%s",
2213                                   PerlIO_fileno(rsfp), origargv[which]));
2214 #if defined(HAS_FCNTL) && defined(F_SETFD)
2215     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2216 #endif
2217     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2218     croak("Can't do setuid\n");
2219 #endif /* IAMSUID */
2220 #else /* !DOSUID */
2221     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2222 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2223         dTHR;
2224         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2225         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2226             ||
2227             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2228            )
2229             if (!do_undump)
2230                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2231 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2232 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2233         /* not set-id, must be wrapped */
2234     }
2235 #endif /* DOSUID */
2236 }
2237
2238 STATIC void
2239 find_beginning(void)
2240 {
2241     register char *s, *s2;
2242
2243     /* skip forward in input to the real script? */
2244
2245     forbid_setid("-x");
2246     while (doextract) {
2247         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2248             croak("No Perl script found in input\n");
2249         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2250             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2251             doextract = FALSE;
2252             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2253             s2 = s;
2254             while (*s == ' ' || *s == '\t') s++;
2255             if (*s++ == '-') {
2256                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2257                 if (strnEQ(s2-4,"perl",4))
2258                     /*SUPPRESS 530*/
2259                     while (s = moreswitches(s)) ;
2260             }
2261             if (cddir && PerlDir_chdir(cddir) < 0)
2262                 croak("Can't chdir to %s",cddir);
2263         }
2264     }
2265 }
2266
2267
2268 STATIC void
2269 init_ids(void)
2270 {
2271     uid = (int)PerlProc_getuid();
2272     euid = (int)PerlProc_geteuid();
2273     gid = (int)PerlProc_getgid();
2274     egid = (int)PerlProc_getegid();
2275 #ifdef VMS
2276     uid |= gid << 16;
2277     euid |= egid << 16;
2278 #endif
2279     tainting |= (uid && (euid != uid || egid != gid));
2280 }
2281
2282 STATIC void
2283 forbid_setid(char *s)
2284 {
2285     if (euid != uid)
2286         croak("No %s allowed while running setuid", s);
2287     if (egid != gid)
2288         croak("No %s allowed while running setgid", s);
2289 }
2290
2291 STATIC void
2292 init_debugger(void)
2293 {
2294     dTHR;
2295     curstash = debstash;
2296     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2297     AvREAL_off(dbargs);
2298     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2299     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2300     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2301     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2302     sv_setiv(DBsingle, 0);
2303     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2304     sv_setiv(DBtrace, 0);
2305     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2306     sv_setiv(DBsignal, 0);
2307     curstash = defstash;
2308 }
2309
2310 #ifndef STRESS_REALLOC
2311 #define REASONABLE(size) (size)
2312 #else
2313 #define REASONABLE(size) (1) /* unreasonable */
2314 #endif
2315
2316 void
2317 init_stacks(ARGSproto)
2318 {
2319     /* start with 128-item stack and 8K cxstack */
2320     curstackinfo = new_stackinfo(REASONABLE(128),
2321                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2322     curstackinfo->si_type = SI_MAIN;
2323     curstack = curstackinfo->si_stack;
2324     mainstack = curstack;               /* remember in case we switch stacks */
2325
2326     stack_base = AvARRAY(curstack);
2327     stack_sp = stack_base;
2328     stack_max = stack_base + AvMAX(curstack);
2329
2330     New(50,tmps_stack,REASONABLE(128),SV*);
2331     tmps_floor = -1;
2332     tmps_ix = -1;
2333     tmps_max = REASONABLE(128);
2334
2335     New(54,markstack,REASONABLE(32),I32);
2336     markstack_ptr = markstack;
2337     markstack_max = markstack + REASONABLE(32);
2338
2339     SET_MARKBASE;
2340
2341     New(54,scopestack,REASONABLE(32),I32);
2342     scopestack_ix = 0;
2343     scopestack_max = REASONABLE(32);
2344
2345     New(54,savestack,REASONABLE(128),ANY);
2346     savestack_ix = 0;
2347     savestack_max = REASONABLE(128);
2348
2349     New(54,retstack,REASONABLE(16),OP*);
2350     retstack_ix = 0;
2351     retstack_max = REASONABLE(16);
2352 }
2353
2354 #undef REASONABLE
2355
2356 STATIC void
2357 nuke_stacks(void)
2358 {
2359     dTHR;
2360     while (curstackinfo->si_next)
2361         curstackinfo = curstackinfo->si_next;
2362     while (curstackinfo) {
2363         PERL_SI *p = curstackinfo->si_prev;
2364         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2365         Safefree(curstackinfo->si_cxstack);
2366         Safefree(curstackinfo);
2367         curstackinfo = p;
2368     }
2369     Safefree(tmps_stack);
2370     Safefree(markstack);
2371     Safefree(scopestack);
2372     Safefree(savestack);
2373     Safefree(retstack);
2374     DEBUG( {
2375         Safefree(debname);
2376         Safefree(debdelim);
2377     } )
2378 }
2379
2380 #ifndef PERL_OBJECT
2381 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2382 #endif
2383
2384 STATIC void
2385 init_lexer(void)
2386 {
2387 #ifdef PERL_OBJECT
2388         PerlIO *tmpfp;
2389 #endif
2390     tmpfp = rsfp;
2391     rsfp = Nullfp;
2392     lex_start(linestr);
2393     rsfp = tmpfp;
2394     subname = newSVpv("main",4);
2395 }
2396
2397 STATIC void
2398 init_predump_symbols(void)
2399 {
2400     dTHR;
2401     GV *tmpgv;
2402     GV *othergv;
2403
2404     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2405     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2406     GvMULTI_on(stdingv);
2407     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2408     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2409     GvMULTI_on(tmpgv);
2410     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2411
2412     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2413     GvMULTI_on(tmpgv);
2414     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2415     setdefout(tmpgv);
2416     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2417     GvMULTI_on(tmpgv);
2418     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2419
2420     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2421     GvMULTI_on(othergv);
2422     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2423     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2424     GvMULTI_on(tmpgv);
2425     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2426
2427     statname = NEWSV(66,0);             /* last filename we did stat on */
2428
2429     if (!osname)
2430         osname = savepv(OSNAME);
2431 }
2432
2433 STATIC void
2434 init_postdump_symbols(register int argc, register char **argv, register char **env)
2435 {
2436     dTHR;
2437     char *s;
2438     SV *sv;
2439     GV* tmpgv;
2440
2441     argc--,argv++;      /* skip name of script */
2442     if (doswitches) {
2443         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2444             if (!argv[0][1])
2445                 break;
2446             if (argv[0][1] == '-') {
2447                 argc--,argv++;
2448                 break;
2449             }
2450             if (s = strchr(argv[0], '=')) {
2451                 *s++ = '\0';
2452                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2453             }
2454             else
2455                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2456         }
2457     }
2458     toptarget = NEWSV(0,0);
2459     sv_upgrade(toptarget, SVt_PVFM);
2460     sv_setpvn(toptarget, "", 0);
2461     bodytarget = NEWSV(0,0);
2462     sv_upgrade(bodytarget, SVt_PVFM);
2463     sv_setpvn(bodytarget, "", 0);
2464     formtarget = bodytarget;
2465
2466     TAINT;
2467     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2468         sv_setpv(GvSV(tmpgv),origfilename);
2469         magicname("0", "0", 1);
2470     }
2471     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2472         sv_setpv(GvSV(tmpgv),origargv[0]);
2473     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2474         GvMULTI_on(argvgv);
2475         (void)gv_AVadd(argvgv);
2476         av_clear(GvAVn(argvgv));
2477         for (; argc > 0; argc--,argv++) {
2478             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2479         }
2480     }
2481     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2482         HV *hv;
2483         GvMULTI_on(envgv);
2484         hv = GvHVn(envgv);
2485         hv_magic(hv, envgv, 'E');
2486 #ifndef VMS  /* VMS doesn't have environ array */
2487         /* Note that if the supplied env parameter is actually a copy
2488            of the global environ then it may now point to free'd memory
2489            if the environment has been modified since. To avoid this
2490            problem we treat env==NULL as meaning 'use the default'
2491         */
2492         if (!env)
2493             env = environ;
2494         if (env != environ)
2495             environ[0] = Nullch;
2496         for (; *env; env++) {
2497             if (!(s = strchr(*env,'=')))
2498                 continue;
2499             *s++ = '\0';
2500 #if defined(MSDOS)
2501             (void)strupr(*env);
2502 #endif
2503             sv = newSVpv(s--,0);
2504             (void)hv_store(hv, *env, s - *env, sv, 0);
2505             *s = '=';
2506 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2507             /* Sins of the RTL. See note in my_setenv(). */
2508             (void)PerlEnv_putenv(savepv(*env));
2509 #endif
2510         }
2511 #endif
2512 #ifdef DYNAMIC_ENV_FETCH
2513         HvNAME(hv) = savepv(ENV_HV_NAME);
2514 #endif
2515     }
2516     TAINT_NOT;
2517     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2518         sv_setiv(GvSV(tmpgv), (IV)getpid());
2519 }
2520
2521 STATIC void
2522 init_perllib(void)
2523 {
2524     char *s;
2525     if (!tainting) {
2526 #ifndef VMS
2527         s = PerlEnv_getenv("PERL5LIB");
2528         if (s)
2529             incpush(s, TRUE);
2530         else
2531             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2532 #else /* VMS */
2533         /* Treat PERL5?LIB as a possible search list logical name -- the
2534          * "natural" VMS idiom for a Unix path string.  We allow each
2535          * element to be a set of |-separated directories for compatibility.
2536          */
2537         char buf[256];
2538         int idx = 0;
2539         if (my_trnlnm("PERL5LIB",buf,0))
2540             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2541         else
2542             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2543 #endif /* VMS */
2544     }
2545
2546 /* Use the ~-expanded versions of APPLLIB (undocumented),
2547     ARCHLIB PRIVLIB SITEARCH and SITELIB
2548 */
2549 #ifdef APPLLIB_EXP
2550     incpush(APPLLIB_EXP, TRUE);
2551 #endif
2552
2553 #ifdef ARCHLIB_EXP
2554     incpush(ARCHLIB_EXP, FALSE);
2555 #endif
2556 #ifndef PRIVLIB_EXP
2557 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2558 #endif
2559 #if defined(WIN32)
2560     incpush(PRIVLIB_EXP, TRUE);
2561 #else
2562     incpush(PRIVLIB_EXP, FALSE);
2563 #endif
2564
2565 #ifdef SITEARCH_EXP
2566     incpush(SITEARCH_EXP, FALSE);
2567 #endif
2568 #ifdef SITELIB_EXP
2569 #if defined(WIN32)
2570     incpush(SITELIB_EXP, TRUE);
2571 #else
2572     incpush(SITELIB_EXP, FALSE);
2573 #endif
2574 #endif
2575     if (!tainting)
2576         incpush(".", FALSE);
2577 }
2578
2579 #if defined(DOSISH)
2580 #    define PERLLIB_SEP ';'
2581 #else
2582 #  if defined(VMS)
2583 #    define PERLLIB_SEP '|'
2584 #  else
2585 #    define PERLLIB_SEP ':'
2586 #  endif
2587 #endif
2588 #ifndef PERLLIB_MANGLE
2589 #  define PERLLIB_MANGLE(s,n) (s)
2590 #endif
2591
2592 STATIC void
2593 incpush(char *p, int addsubdirs)
2594 {
2595     SV *subdir = Nullsv;
2596
2597     if (!p)
2598         return;
2599
2600     if (addsubdirs) {
2601         subdir = sv_newmortal();
2602         if (!archpat_auto) {
2603             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2604                           + sizeof("//auto"));
2605             New(55, archpat_auto, len, char);
2606             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2607 #ifdef VMS
2608         for (len = sizeof(ARCHNAME) + 2;
2609              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2610                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2611 #endif
2612         }
2613     }
2614
2615     /* Break at all separators */
2616     while (p && *p) {
2617         SV *libdir = NEWSV(55,0);
2618         char *s;
2619
2620         /* skip any consecutive separators */
2621         while ( *p == PERLLIB_SEP ) {
2622             /* Uncomment the next line for PATH semantics */
2623             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2624             p++;
2625         }
2626
2627         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2628             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2629                       (STRLEN)(s - p));
2630             p = s + 1;
2631         }
2632         else {
2633             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2634             p = Nullch; /* break out */
2635         }
2636
2637         /*
2638          * BEFORE pushing libdir onto @INC we may first push version- and
2639          * archname-specific sub-directories.
2640          */
2641         if (addsubdirs) {
2642             struct stat tmpstatbuf;
2643 #ifdef VMS
2644             char *unix;
2645             STRLEN len;
2646
2647             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2648                 len = strlen(unix);
2649                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2650                 sv_usepvn(libdir,unix,len);
2651             }
2652             else
2653                 PerlIO_printf(PerlIO_stderr(),
2654                               "Failed to unixify @INC element \"%s\"\n",
2655                               SvPV(libdir,na));
2656 #endif
2657             /* .../archname/version if -d .../archname/version/auto */
2658             sv_setsv(subdir, libdir);
2659             sv_catpv(subdir, archpat_auto);
2660             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2661                   S_ISDIR(tmpstatbuf.st_mode))
2662                 av_push(GvAVn(incgv),
2663                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2664
2665             /* .../archname if -d .../archname/auto */
2666             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2667                       strlen(patchlevel) + 1, "", 0);
2668             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2669                   S_ISDIR(tmpstatbuf.st_mode))
2670                 av_push(GvAVn(incgv),
2671                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2672         }
2673
2674         /* finally push this lib directory on the end of @INC */
2675         av_push(GvAVn(incgv), libdir);
2676     }
2677 }
2678
2679 #ifdef USE_THREADS
2680 STATIC struct perl_thread *
2681 init_main_thread()
2682 {
2683     struct perl_thread *thr;
2684     XPV *xpv;
2685
2686     Newz(53, thr, 1, struct perl_thread);
2687     curcop = &compiling;
2688     thr->cvcache = newHV();
2689     thr->threadsv = newAV();
2690     /* thr->threadsvp is set when find_threadsv is called */
2691     thr->specific = newAV();
2692     thr->errhv = newHV();
2693     thr->flags = THRf_R_JOINABLE;
2694     MUTEX_INIT(&thr->mutex);
2695     /* Handcraft thrsv similarly to mess_sv */
2696     New(53, thrsv, 1, SV);
2697     Newz(53, xpv, 1, XPV);
2698     SvFLAGS(thrsv) = SVt_PV;
2699     SvANY(thrsv) = (void*)xpv;
2700     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2701     SvPVX(thrsv) = (char*)thr;
2702     SvCUR_set(thrsv, sizeof(thr));
2703     SvLEN_set(thrsv, sizeof(thr));
2704     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2705     thr->oursv = thrsv;
2706     chopset = " \n-";
2707
2708     MUTEX_LOCK(&threads_mutex);
2709     nthreads++;
2710     thr->tid = 0;
2711     thr->next = thr;
2712     thr->prev = thr;
2713     MUTEX_UNLOCK(&threads_mutex);
2714
2715 #ifdef HAVE_THREAD_INTERN
2716     init_thread_intern(thr);
2717 #endif
2718
2719 #ifdef SET_THREAD_SELF
2720     SET_THREAD_SELF(thr);
2721 #else
2722     thr->self = pthread_self();
2723 #endif /* SET_THREAD_SELF */
2724     SET_THR(thr);
2725
2726     /*
2727      * These must come after the SET_THR because sv_setpvn does
2728      * SvTAINT and the taint fields require dTHR.
2729      */
2730     toptarget = NEWSV(0,0);
2731     sv_upgrade(toptarget, SVt_PVFM);
2732     sv_setpvn(toptarget, "", 0);
2733     bodytarget = NEWSV(0,0);
2734     sv_upgrade(bodytarget, SVt_PVFM);
2735     sv_setpvn(bodytarget, "", 0);
2736     formtarget = bodytarget;
2737     thr->errsv = newSVpv("", 0);
2738     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2739     return thr;
2740 }
2741 #endif /* USE_THREADS */
2742
2743 void
2744 call_list(I32 oldscope, AV *paramList)
2745 {
2746     dTHR;
2747     line_t oldline = curcop->cop_line;
2748     STRLEN len;
2749     dJMPENV;
2750     int ret;
2751
2752     while (AvFILL(paramList) >= 0) {
2753         CV *cv = (CV*)av_shift(paramList);
2754
2755         SAVEFREESV(cv);
2756
2757         JMPENV_PUSH(ret);
2758         switch (ret) {
2759         case 0: {
2760                 SV* atsv = ERRSV;
2761                 PUSHMARK(stack_sp);
2762                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2763                 (void)SvPV(atsv, len);
2764                 if (len) {
2765                     JMPENV_POP;
2766                     curcop = &compiling;
2767                     curcop->cop_line = oldline;
2768                     if (paramList == beginav)
2769                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2770                     else
2771                         sv_catpv(atsv, "END failed--cleanup aborted");
2772                     while (scopestack_ix > oldscope)
2773                         LEAVE;
2774                     croak("%s", SvPVX(atsv));
2775                 }
2776             }
2777             break;
2778         case 1:
2779             STATUS_ALL_FAILURE;
2780             /* FALL THROUGH */
2781         case 2:
2782             /* my_exit() was called */
2783             while (scopestack_ix > oldscope)
2784                 LEAVE;
2785             FREETMPS;
2786             curstash = defstash;
2787             if (endav)
2788                 call_list(oldscope, endav);
2789             JMPENV_POP;
2790             curcop = &compiling;
2791             curcop->cop_line = oldline;
2792             if (statusvalue) {
2793                 if (paramList == beginav)
2794                     croak("BEGIN failed--compilation aborted");
2795                 else
2796                     croak("END failed--cleanup aborted");
2797             }
2798             my_exit_jump();
2799             /* NOTREACHED */
2800         case 3:
2801             if (!restartop) {
2802                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2803                 FREETMPS;
2804                 break;
2805             }
2806             JMPENV_POP;
2807             curcop = &compiling;
2808             curcop->cop_line = oldline;
2809             JMPENV_JUMP(3);
2810         }
2811         JMPENV_POP;
2812     }
2813 }
2814
2815 void
2816 my_exit(U32 status)
2817 {
2818     dTHR;
2819
2820 #ifdef USE_THREADS
2821     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2822                           thr, (unsigned long) status));
2823 #endif /* USE_THREADS */
2824     switch (status) {
2825     case 0:
2826         STATUS_ALL_SUCCESS;
2827         break;
2828     case 1:
2829         STATUS_ALL_FAILURE;
2830         break;
2831     default:
2832         STATUS_NATIVE_SET(status);
2833         break;
2834     }
2835     my_exit_jump();
2836 }
2837
2838 void
2839 my_failure_exit(void)
2840 {
2841 #ifdef VMS
2842     if (vaxc$errno & 1) {
2843         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2844             STATUS_NATIVE_SET(44);
2845     }
2846     else {
2847         if (!vaxc$errno && errno)       /* unlikely */
2848             STATUS_NATIVE_SET(44);
2849         else
2850             STATUS_NATIVE_SET(vaxc$errno);
2851     }
2852 #else
2853     int exitstatus;
2854     if (errno & 255)
2855         STATUS_POSIX_SET(errno);
2856     else {
2857         exitstatus = STATUS_POSIX >> 8;
2858         if (exitstatus & 255)
2859             STATUS_POSIX_SET(exitstatus);
2860         else
2861             STATUS_POSIX_SET(255);
2862     }
2863 #endif
2864     my_exit_jump();
2865 }
2866
2867 STATIC void
2868 my_exit_jump(void)
2869 {
2870     dSP;
2871     register PERL_CONTEXT *cx;
2872     I32 gimme;
2873     SV **newsp;
2874
2875     if (e_script) {
2876         SvREFCNT_dec(e_script);
2877         e_script = Nullsv;
2878     }
2879
2880     POPSTACK_TO(mainstack);
2881     if (cxstack_ix >= 0) {
2882         if (cxstack_ix > 0)
2883             dounwind(0);
2884         POPBLOCK(cx,curpm);
2885         LEAVE;
2886     }
2887
2888     JMPENV_JUMP(2);
2889 }
2890
2891
2892 #include "XSUB.h"
2893
2894 static I32
2895 #ifdef PERL_OBJECT
2896 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
2897 #else
2898 read_e_script(int idx, SV *buf_sv, int maxlen)
2899 #endif
2900 {
2901     char *p, *nl;
2902     p  = SvPVX(e_script);
2903     nl = strchr(p, '\n');
2904     nl = (nl) ? nl+1 : SvEND(e_script);
2905     if (nl-p == 0)
2906         return 0;
2907     sv_catpvn(buf_sv, p, nl-p);
2908     sv_chop(e_script, nl);
2909     return 1;
2910 }
2911
2912