perl.c

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