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;
1438     dSP;
1439     PUSHSTACKi(SI_REQUIRE);
1440     PUTBACK;
1441     sv = sv_newmortal();
1442     sv_setpv(sv, "require '");
1443     sv_catpv(sv, pv);
1444     sv_catpv(sv, "'");
1445     perl_eval_sv(sv, G_DISCARD);
1446     SPAGAIN;
1447     POPSTACK;
1448 }
1449
1450 void
1451 magicname(char *sym, char *name, I32 namlen)
1452 {
1453     register GV *gv;
1454
1455     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1456         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1457 }
1458
1459 STATIC void
1460 usage(char *name)               /* XXX move this out into a module ? */
1461
1462 {
1463     /* This message really ought to be max 23 lines.
1464      * Removed -h because the user already knows that opton. Others? */
1465
1466     static char *usage_msg[] = {
1467 "-0[octal]       specify record separator (\\0, if no argument)",
1468 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1469 "-c              check syntax only (runs BEGIN and END blocks)",
1470 "-d[:debugger]   run scripts under debugger",
1471 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1472 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1473 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1474 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1475 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1476 "-l[octal]       enable line ending processing, specifies line terminator",
1477 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1478 "-n              assume 'while (<>) { ... }' loop around your script",
1479 "-p              assume loop like -n but print line also like sed",
1480 "-P              run script through C preprocessor before compilation",
1481 "-s              enable some switch parsing for switches after script name",
1482 "-S              look for the script using PATH environment variable",
1483 "-T              turn on tainting checks",
1484 "-u              dump core after parsing script",
1485 "-U              allow unsafe operations",
1486 "-v              print version number, patchlevel plus VERY IMPORTANT perl info",
1487 "-V[:variable]   print perl configuration information",
1488 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1489 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1490 "\n",
1491 NULL
1492 };
1493     char **p = usage_msg;
1494
1495     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1496     while (*p)
1497         printf("\n  %s", *p++);
1498 }
1499
1500 /* This routine handles any switches that can be given during run */
1501
1502 char *
1503 moreswitches(char *s)
1504 {
1505     I32 numlen;
1506     U32 rschar;
1507
1508     switch (*s) {
1509     case '0':
1510     {
1511         dTHR;
1512         rschar = scan_oct(s, 4, &numlen);
1513         SvREFCNT_dec(nrs);
1514         if (rschar & ~((U8)~0))
1515             nrs = &sv_undef;
1516         else if (!rschar && numlen >= 2)
1517             nrs = newSVpv("", 0);
1518         else {
1519             char ch = rschar;
1520             nrs = newSVpv(&ch, 1);
1521         }
1522         return s + numlen;
1523     }
1524     case 'F':
1525         minus_F = TRUE;
1526         splitstr = savepv(s + 1);
1527         s += strlen(s);
1528         return s;
1529     case 'a':
1530         minus_a = TRUE;
1531         s++;
1532         return s;
1533     case 'c':
1534         minus_c = TRUE;
1535         s++;
1536         return s;
1537     case 'd':
1538         forbid_setid("-d");
1539         s++;
1540         if (*s == ':' || *s == '=')  {
1541             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1542             s += strlen(s);
1543         }
1544         if (!perldb) {
1545             perldb = PERLDB_ALL;
1546             init_debugger();
1547         }
1548         return s;
1549     case 'D':
1550 #ifdef DEBUGGING
1551         forbid_setid("-D");
1552         if (isALPHA(s[1])) {
1553             static char debopts[] = "psltocPmfrxuLHXD";
1554             char *d;
1555
1556             for (s++; *s && (d = strchr(debopts,*s)); s++)
1557                 debug |= 1 << (d - debopts);
1558         }
1559         else {
1560             debug = atoi(s+1);
1561             for (s++; isDIGIT(*s); s++) ;
1562         }
1563         debug |= 0x80000000;
1564 #else
1565         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1566         for (s++; isALNUM(*s); s++) ;
1567 #endif
1568         /*SUPPRESS 530*/
1569         return s;
1570     case 'h':
1571         usage(origargv[0]);
1572         PerlProc_exit(0);
1573     case 'i':
1574         if (inplace)
1575             Safefree(inplace);
1576         inplace = savepv(s+1);
1577         /*SUPPRESS 530*/
1578         for (s = inplace; *s && !isSPACE(*s); s++) ;
1579         if (*s) {
1580             *s++ = '\0';
1581             if (*s == '-')      /* Additional switches on #! line. */
1582                 s++;
1583         }
1584         return s;
1585     case 'I':   /* -I handled both here and in parse_perl() */
1586         forbid_setid("-I");
1587         ++s;
1588         while (*s && isSPACE(*s))
1589             ++s;
1590         if (*s) {
1591             char *e, *p;
1592             for (e = s; *e && !isSPACE(*e); e++) ;
1593             p = savepvn(s, e-s);
1594             incpush(p, TRUE);
1595             Safefree(p);
1596             s = e;
1597         }
1598         else
1599             croak("No space allowed after -I");
1600         return s;
1601     case 'l':
1602         minus_l = TRUE;
1603         s++;
1604         if (ors)
1605             Safefree(ors);
1606         if (isDIGIT(*s)) {
1607             ors = savepv("\n");
1608             orslen = 1;
1609             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1610             s += numlen;
1611         }
1612         else {
1613             dTHR;
1614             if (RsPARA(nrs)) {
1615                 ors = "\n\n";
1616                 orslen = 2;
1617             }
1618             else
1619                 ors = SvPV(nrs, orslen);
1620             ors = savepvn(ors, orslen);
1621         }
1622         return s;
1623     case 'M':
1624         forbid_setid("-M");     /* XXX ? */
1625         /* FALL THROUGH */
1626     case 'm':
1627         forbid_setid("-m");     /* XXX ? */
1628         if (*++s) {
1629             char *start;
1630             SV *sv;
1631             char *use = "use ";
1632             /* -M-foo == 'no foo'       */
1633             if (*s == '-') { use = "no "; ++s; }
1634             sv = newSVpv(use,0);
1635             start = s;
1636             /* We allow -M'Module qw(Foo Bar)'  */
1637             while(isALNUM(*s) || *s==':') ++s;
1638             if (*s != '=') {
1639                 sv_catpv(sv, start);
1640                 if (*(start-1) == 'm') {
1641                     if (*s != '\0')
1642                         croak("Can't use '%c' after -mname", *s);
1643                     sv_catpv( sv, " ()");
1644                 }
1645             } else {
1646                 sv_catpvn(sv, start, s-start);
1647                 sv_catpv(sv, " split(/,/,q{");
1648                 sv_catpv(sv, ++s);
1649                 sv_catpv(sv,    "})");
1650             }
1651             s += strlen(s);
1652             if (preambleav == NULL)
1653                 preambleav = newAV();
1654             av_push(preambleav, sv);
1655         }
1656         else
1657             croak("No space allowed after -%c", *(s-1));
1658         return s;
1659     case 'n':
1660         minus_n = TRUE;
1661         s++;
1662         return s;
1663     case 'p':
1664         minus_p = TRUE;
1665         s++;
1666         return s;
1667     case 's':
1668         forbid_setid("-s");
1669         doswitches = TRUE;
1670         s++;
1671         return s;
1672     case 'T':
1673         if (!tainting)
1674             croak("Too late for \"-T\" option");
1675         s++;
1676         return s;
1677     case 'u':
1678         do_undump = TRUE;
1679         s++;
1680         return s;
1681     case 'U':
1682         unsafe = TRUE;
1683         s++;
1684         return s;
1685     case 'v':
1686 #if defined(SUBVERSION) && SUBVERSION > 0
1687         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1688             PATCHLEVEL, SUBVERSION, ARCHNAME);
1689 #else
1690         printf("\nThis is perl, version %s built for %s",
1691                 patchlevel, ARCHNAME);
1692 #endif
1693 #if defined(LOCAL_PATCH_COUNT)
1694         if (LOCAL_PATCH_COUNT > 0)
1695             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1696                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1697 #endif
1698
1699         printf("\n\nCopyright 1987-1998, Larry Wall\n");
1700 #ifdef MSDOS
1701         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1702 #endif
1703 #ifdef DJGPP
1704         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1705         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1706 #endif
1707 #ifdef OS2
1708         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1709             "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1710 #endif
1711 #ifdef atarist
1712         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1713 #endif
1714         printf("\n\
1715 Perl may be copied only under the terms of either the Artistic License or the\n\
1716 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1717 Complete documentation for Perl, including FAQ lists, should be found on\n\
1718 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
1719 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1720         PerlProc_exit(0);
1721     case 'w':
1722         dowarn = TRUE;
1723         s++;
1724         return s;
1725     case '*':
1726     case ' ':
1727         if (s[1] == '-')        /* Additional switches on #! line. */
1728             return s+2;
1729         break;
1730     case '-':
1731     case 0:
1732 #ifdef WIN32
1733     case '\r':
1734 #endif
1735     case '\n':
1736     case '\t':
1737         break;
1738 #ifdef ALTERNATE_SHEBANG
1739     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1740         break;
1741 #endif
1742     case 'P':
1743         if (preprocess)
1744             return s+1;
1745         /* FALL THROUGH */
1746     default:
1747         croak("Can't emulate -%.1s on #! line",s);
1748     }
1749     return Nullch;
1750 }
1751
1752 /* compliments of Tom Christiansen */
1753
1754 /* unexec() can be found in the Gnu emacs distribution */
1755 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1756
1757 void
1758 my_unexec(void)
1759 {
1760 #ifdef UNEXEC
1761     SV*    prog;
1762     SV*    file;
1763     int    status = 1;
1764     extern int etext;
1765
1766     prog = newSVpv(BIN_EXP, 0);
1767     sv_catpv(prog, "/perl");
1768     file = newSVpv(origfilename, 0);
1769     sv_catpv(file, ".perldump");
1770
1771     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1772     /* unexec prints msg to stderr in case of failure */
1773     PerlProc_exit(status);
1774 #else
1775 #  ifdef VMS
1776 #    include <lib$routines.h>
1777      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1778 #  else
1779     ABORT();            /* for use with undump */
1780 #  endif
1781 #endif
1782 }
1783
1784 /* initialize curinterp */
1785 STATIC void
1786 init_interp(void)
1787 {
1788
1789 #ifdef PERL_OBJECT              /* XXX kludge */
1790 #define I_REINIT \
1791   STMT_START {                  \
1792     chopset     = " \n-";       \
1793     copline     = NOLINE;       \
1794     curcop      = &compiling;   \
1795     curcopdb    = NULL;         \
1796     dbargs      = 0;            \
1797     dlmax       = 128;          \
1798     laststatval = -1;           \
1799     laststype   = OP_STAT;      \
1800     maxscream   = -1;           \
1801     maxsysfd    = MAXSYSFD;     \
1802     statname    = Nullsv;       \
1803     tmps_floor  = -1;           \
1804     tmps_ix     = -1;           \
1805     op_mask     = NULL;         \
1806     dlmax       = 128;          \
1807     laststatval = -1;           \
1808     laststype   = OP_STAT;      \
1809     mess_sv     = Nullsv;       \
1810     splitstr    = " ";          \
1811     generation  = 100;          \
1812     exitlist    = NULL;         \
1813     exitlistlen = 0;            \
1814     regindent   = 0;            \
1815     in_clean_objs = FALSE;      \
1816     in_clean_all= FALSE;        \
1817     profiledata = NULL;         \
1818     rsfp        = Nullfp;       \
1819     rsfp_filters= Nullav;       \
1820   } STMT_END
1821     I_REINIT;
1822 #else
1823 #  ifdef MULTIPLICITY
1824 #    define PERLVAR(var,type)
1825 #    define PERLVARI(var,type,init)     curinterp->var = init;
1826 #    define PERLVARIC(var,type,init)    curinterp->var = init;
1827 #    include "intrpvar.h"
1828 #    ifndef USE_THREADS
1829 #      include "thrdvar.h"
1830 #    endif
1831 #    undef PERLVAR
1832 #    undef PERLVARI
1833 #    undef PERLVARIC
1834 #    else
1835 #    define PERLVAR(var,type)
1836 #    define PERLVARI(var,type,init)     var = init;
1837 #    define PERLVARIC(var,type,init)    var = init;
1838 #    include "intrpvar.h"
1839 #    ifndef USE_THREADS
1840 #      include "thrdvar.h"
1841 #    endif
1842 #    undef PERLVAR
1843 #    undef PERLVARI
1844 #    undef PERLVARIC
1845 #  endif
1846 #endif
1847
1848 }
1849
1850 STATIC void
1851 init_main_stash(void)
1852 {
1853     dTHR;
1854     GV *gv;
1855
1856     /* Note that strtab is a rather special HV.  Assumptions are made
1857        about not iterating on it, and not adding tie magic to it.
1858        It is properly deallocated in perl_destruct() */
1859     strtab = newHV();
1860     HvSHAREKEYS_off(strtab);                    /* mandatory */
1861     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1862          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1863
1864     curstash = defstash = newHV();
1865     curstname = newSVpv("main",4);
1866     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1867     SvREFCNT_dec(GvHV(gv));
1868     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1869     SvREADONLY_on(gv);
1870     HvNAME(defstash) = savepv("main");
1871     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1872     GvMULTI_on(incgv);
1873     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1874     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1875     GvMULTI_on(errgv);
1876     replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1877     GvMULTI_on(replgv);
1878     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1879     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1880     sv_setpvn(ERRSV, "", 0);
1881     curstash = defstash;
1882     compiling.cop_stash = defstash;
1883     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1884     globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1885     /* We must init $/ before switches are processed. */
1886     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1887 }
1888
1889 STATIC void
1890 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
1891 {
1892     dTHR;
1893     register char *s;
1894
1895     /* scriptname will be non-NULL if find_script() returns */
1896     scriptname = find_script(scriptname, dosearch, NULL, 1);
1897
1898     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1899         char *s = scriptname + 8;
1900         *fdscript = atoi(s);
1901         while (isDIGIT(*s))
1902             s++;
1903         if (*s)
1904             scriptname = s + 1;
1905     }
1906     else
1907         *fdscript = -1;
1908     origfilename = (e_script ? savepv("-e") : scriptname);
1909     curcop->cop_filegv = gv_fetchfile(origfilename);
1910     if (strEQ(origfilename,"-"))
1911         scriptname = "";
1912     if (*fdscript >= 0) {
1913         rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1914 #if defined(HAS_FCNTL) && defined(F_SETFD)
1915         if (rsfp)
1916             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1917 #endif
1918     }
1919     else if (preprocess) {
1920         char *cpp_cfg = CPPSTDIN;
1921         SV *cpp = newSVpv("",0);
1922         SV *cmd = NEWSV(0,0);
1923
1924         if (strEQ(cpp_cfg, "cppstdin"))
1925             sv_catpvf(cpp, "%s/", BIN_EXP);
1926         sv_catpv(cpp, cpp_cfg);
1927
1928         sv_catpv(sv,"-I");
1929         sv_catpv(sv,PRIVLIB_EXP);
1930
1931 #ifdef MSDOS
1932         sv_setpvf(cmd, "\
1933 sed %s -e \"/^[^#]/b\" \
1934  -e \"/^#[      ]*include[      ]/b\" \
1935  -e \"/^#[      ]*define[       ]/b\" \
1936  -e \"/^#[      ]*if[   ]/b\" \
1937  -e \"/^#[      ]*ifdef[        ]/b\" \
1938  -e \"/^#[      ]*ifndef[       ]/b\" \
1939  -e \"/^#[      ]*else/b\" \
1940  -e \"/^#[      ]*elif[         ]/b\" \
1941  -e \"/^#[      ]*undef[        ]/b\" \
1942  -e \"/^#[      ]*endif/b\" \
1943  -e \"s/^#.*//\" \
1944  %s | %_ -C %_ %s",
1945           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1946 #else
1947         sv_setpvf(cmd, "\
1948 %s %s -e '/^[^#]/b' \
1949  -e '/^#[       ]*include[      ]/b' \
1950  -e '/^#[       ]*define[       ]/b' \
1951  -e '/^#[       ]*if[   ]/b' \
1952  -e '/^#[       ]*ifdef[        ]/b' \
1953  -e '/^#[       ]*ifndef[       ]/b' \
1954  -e '/^#[       ]*else/b' \
1955  -e '/^#[       ]*elif[         ]/b' \
1956  -e '/^#[       ]*undef[        ]/b' \
1957  -e '/^#[       ]*endif/b' \
1958  -e 's/^[       ]*#.*//' \
1959  %s | %_ -C %_ %s",
1960 #ifdef LOC_SED
1961           LOC_SED,
1962 #else
1963           "sed",
1964 #endif
1965           (doextract ? "-e '1,/^#/d\n'" : ""),
1966 #endif
1967           scriptname, cpp, sv, CPPMINUS);
1968         doextract = FALSE;
1969 #ifdef IAMSUID                          /* actually, this is caught earlier */
1970         if (euid != uid && !euid) {     /* if running suidperl */
1971 #ifdef HAS_SETEUID
1972             (void)seteuid(uid);         /* musn't stay setuid root */
1973 #else
1974 #ifdef HAS_SETREUID
1975             (void)setreuid((Uid_t)-1, uid);
1976 #else
1977 #ifdef HAS_SETRESUID
1978             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1979 #else
1980             PerlProc_setuid(uid);
1981 #endif
1982 #endif
1983 #endif
1984             if (PerlProc_geteuid() != uid)
1985                 croak("Can't do seteuid!\n");
1986         }
1987 #endif /* IAMSUID */
1988         rsfp = PerlProc_popen(SvPVX(cmd), "r");
1989         SvREFCNT_dec(cmd);
1990         SvREFCNT_dec(cpp);
1991     }
1992     else if (!*scriptname) {
1993         forbid_setid("program input from stdin");
1994         rsfp = PerlIO_stdin();
1995     }
1996     else {
1997         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1998 #if defined(HAS_FCNTL) && defined(F_SETFD)
1999         if (rsfp)
2000             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2001 #endif
2002     }
2003     if (!rsfp) {
2004 #ifdef DOSUID
2005 #ifndef IAMSUID         /* in case script is not readable before setuid */
2006         if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2007           statbuf.st_mode & (S_ISUID|S_ISGID)) {
2008             /* try again */
2009             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2010             croak("Can't do setuid\n");
2011         }
2012 #endif
2013 #endif
2014         croak("Can't open perl script \"%s\": %s\n",
2015           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2016     }
2017 }
2018
2019 STATIC void
2020 validate_suid(char *validarg, char *scriptname, int fdscript)
2021 {
2022     int which;
2023
2024     /* do we need to emulate setuid on scripts? */
2025
2026     /* This code is for those BSD systems that have setuid #! scripts disabled
2027      * in the kernel because of a security problem.  Merely defining DOSUID
2028      * in perl will not fix that problem, but if you have disabled setuid
2029      * scripts in the kernel, this will attempt to emulate setuid and setgid
2030      * on scripts that have those now-otherwise-useless bits set.  The setuid
2031      * root version must be called suidperl or sperlN.NNN.  If regular perl
2032      * discovers that it has opened a setuid script, it calls suidperl with
2033      * the same argv that it had.  If suidperl finds that the script it has
2034      * just opened is NOT setuid root, it sets the effective uid back to the
2035      * uid.  We don't just make perl setuid root because that loses the
2036      * effective uid we had before invoking perl, if it was different from the
2037      * uid.
2038      *
2039      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2040      * be defined in suidperl only.  suidperl must be setuid root.  The
2041      * Configure script will set this up for you if you want it.
2042      */
2043
2044 #ifdef DOSUID
2045     dTHR;
2046     char *s, *s2;
2047
2048     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2049         croak("Can't stat script \"%s\"",origfilename);
2050     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2051         I32 len;
2052
2053 #ifdef IAMSUID
2054 #ifndef HAS_SETREUID
2055         /* On this access check to make sure the directories are readable,
2056          * there is actually a small window that the user could use to make
2057          * filename point to an accessible directory.  So there is a faint
2058          * chance that someone could execute a setuid script down in a
2059          * non-accessible directory.  I don't know what to do about that.
2060          * But I don't think it's too important.  The manual lies when
2061          * it says access() is useful in setuid programs.
2062          */
2063         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2064             croak("Permission denied");
2065 #else
2066         /* If we can swap euid and uid, then we can determine access rights
2067          * with a simple stat of the file, and then compare device and
2068          * inode to make sure we did stat() on the same file we opened.
2069          * Then we just have to make sure he or she can execute it.
2070          */
2071         {
2072             struct stat tmpstatbuf;
2073
2074             if (
2075 #ifdef HAS_SETREUID
2076                 setreuid(euid,uid) < 0
2077 #else
2078 # if HAS_SETRESUID
2079                 setresuid(euid,uid,(Uid_t)-1) < 0
2080 # endif
2081 #endif
2082                 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
2083                 croak("Can't swap uid and euid");       /* really paranoid */
2084             if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2085                 croak("Permission denied");     /* testing full pathname here */
2086             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2087                 tmpstatbuf.st_ino != statbuf.st_ino) {
2088                 (void)PerlIO_close(rsfp);
2089                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2090                     PerlIO_printf(rsfp,
2091 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2092 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2093                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2094                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2095                         SvPVX(GvSV(curcop->cop_filegv)),
2096                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2097                     (void)PerlProc_pclose(rsfp);
2098                 }
2099                 croak("Permission denied\n");
2100             }
2101             if (
2102 #ifdef HAS_SETREUID
2103               setreuid(uid,euid) < 0
2104 #else
2105 # if defined(HAS_SETRESUID)
2106               setresuid(uid,euid,(Uid_t)-1) < 0
2107 # endif
2108 #endif
2109               || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
2110                 croak("Can't reswap uid and euid");
2111             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2112                 croak("Permission denied\n");
2113         }
2114 #endif /* HAS_SETREUID */
2115 #endif /* IAMSUID */
2116
2117         if (!S_ISREG(statbuf.st_mode))
2118             croak("Permission denied");
2119         if (statbuf.st_mode & S_IWOTH)
2120             croak("Setuid/gid script is writable by world");
2121         doswitches = FALSE;             /* -s is insecure in suid */
2122         curcop->cop_line++;
2123         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2124           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2125             croak("No #! line");
2126         s = SvPV(linestr,na)+2;
2127         if (*s == ' ') s++;
2128         while (!isSPACE(*s)) s++;
2129         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2130                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2131         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2132             croak("Not a perl script");
2133         while (*s == ' ' || *s == '\t') s++;
2134         /*
2135          * #! arg must be what we saw above.  They can invoke it by
2136          * mentioning suidperl explicitly, but they may not add any strange
2137          * arguments beyond what #! says if they do invoke suidperl that way.
2138          */
2139         len = strlen(validarg);
2140         if (strEQ(validarg," PHOOEY ") ||
2141             strnNE(s,validarg,len) || !isSPACE(s[len]))
2142             croak("Args must match #! line");
2143
2144 #ifndef IAMSUID
2145         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2146             euid == statbuf.st_uid)
2147             if (!do_undump)
2148                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2149 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2150 #endif /* IAMSUID */
2151
2152         if (euid) {     /* oops, we're not the setuid root perl */
2153             (void)PerlIO_close(rsfp);
2154 #ifndef IAMSUID
2155             /* try again */
2156             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2157 #endif
2158             croak("Can't do setuid\n");
2159         }
2160
2161         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2162 #ifdef HAS_SETEGID
2163             (void)setegid(statbuf.st_gid);
2164 #else
2165 #ifdef HAS_SETREGID
2166            (void)setregid((Gid_t)-1,statbuf.st_gid);
2167 #else
2168 #ifdef HAS_SETRESGID
2169            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2170 #else
2171             PerlProc_setgid(statbuf.st_gid);
2172 #endif
2173 #endif
2174 #endif
2175             if (PerlProc_getegid() != statbuf.st_gid)
2176                 croak("Can't do setegid!\n");
2177         }
2178         if (statbuf.st_mode & S_ISUID) {
2179             if (statbuf.st_uid != euid)
2180 #ifdef HAS_SETEUID
2181                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2182 #else
2183 #ifdef HAS_SETREUID
2184                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2185 #else
2186 #ifdef HAS_SETRESUID
2187                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2188 #else
2189                 PerlProc_setuid(statbuf.st_uid);
2190 #endif
2191 #endif
2192 #endif
2193             if (PerlProc_geteuid() != statbuf.st_uid)
2194                 croak("Can't do seteuid!\n");
2195         }
2196         else if (uid) {                 /* oops, mustn't run as root */
2197 #ifdef HAS_SETEUID
2198           (void)seteuid((Uid_t)uid);
2199 #else
2200 #ifdef HAS_SETREUID
2201           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2202 #else
2203 #ifdef HAS_SETRESUID
2204           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2205 #else
2206           PerlProc_setuid((Uid_t)uid);
2207 #endif
2208 #endif
2209 #endif
2210             if (PerlProc_geteuid() != uid)
2211                 croak("Can't do seteuid!\n");
2212         }
2213         init_ids();
2214         if (!cando(S_IXUSR,TRUE,&statbuf))
2215             croak("Permission denied\n");       /* they can't do this */
2216     }
2217 #ifdef IAMSUID
2218     else if (preprocess)
2219         croak("-P not allowed for setuid/setgid script\n");
2220     else if (fdscript >= 0)
2221         croak("fd script not allowed in suidperl\n");
2222     else
2223         croak("Script is not setuid/setgid in suidperl\n");
2224
2225     /* We absolutely must clear out any saved ids here, so we */
2226     /* exec the real perl, substituting fd script for scriptname. */
2227     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2228     PerlIO_rewind(rsfp);
2229     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2230     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2231     if (!origargv[which])
2232         croak("Permission denied");
2233     origargv[which] = savepv(form("/dev/fd/%d/%s",
2234                                   PerlIO_fileno(rsfp), origargv[which]));
2235 #if defined(HAS_FCNTL) && defined(F_SETFD)
2236     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2237 #endif
2238     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2239     croak("Can't do setuid\n");
2240 #endif /* IAMSUID */
2241 #else /* !DOSUID */
2242     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2243 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2244         dTHR;
2245         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2246         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2247             ||
2248             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2249            )
2250             if (!do_undump)
2251                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2252 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2253 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2254         /* not set-id, must be wrapped */
2255     }
2256 #endif /* DOSUID */
2257 }
2258
2259 STATIC void
2260 find_beginning(void)
2261 {
2262     register char *s, *s2;
2263
2264     /* skip forward in input to the real script? */
2265
2266     forbid_setid("-x");
2267     while (doextract) {
2268         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2269             croak("No Perl script found in input\n");
2270         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2271             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2272             doextract = FALSE;
2273             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2274             s2 = s;
2275             while (*s == ' ' || *s == '\t') s++;
2276             if (*s++ == '-') {
2277                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2278                 if (strnEQ(s2-4,"perl",4))
2279                     /*SUPPRESS 530*/
2280                     while (s = moreswitches(s)) ;
2281             }
2282             if (cddir && PerlDir_chdir(cddir) < 0)
2283                 croak("Can't chdir to %s",cddir);
2284         }
2285     }
2286 }
2287
2288
2289 STATIC void
2290 init_ids(void)
2291 {
2292     uid = (int)PerlProc_getuid();
2293     euid = (int)PerlProc_geteuid();
2294     gid = (int)PerlProc_getgid();
2295     egid = (int)PerlProc_getegid();
2296 #ifdef VMS
2297     uid |= gid << 16;
2298     euid |= egid << 16;
2299 #endif
2300     tainting |= (uid && (euid != uid || egid != gid));
2301 }
2302
2303 STATIC void
2304 forbid_setid(char *s)
2305 {
2306     if (euid != uid)
2307         croak("No %s allowed while running setuid", s);
2308     if (egid != gid)
2309         croak("No %s allowed while running setgid", s);
2310 }
2311
2312 STATIC void
2313 init_debugger(void)
2314 {
2315     dTHR;
2316     curstash = debstash;
2317     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2318     AvREAL_off(dbargs);
2319     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2320     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2321     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2322     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2323     sv_setiv(DBsingle, 0);
2324     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2325     sv_setiv(DBtrace, 0);
2326     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2327     sv_setiv(DBsignal, 0);
2328     curstash = defstash;
2329 }
2330
2331 #ifndef STRESS_REALLOC
2332 #define REASONABLE(size) (size)
2333 #else
2334 #define REASONABLE(size) (1) /* unreasonable */
2335 #endif
2336
2337 void
2338 init_stacks(ARGSproto)
2339 {
2340     /* start with 128-item stack and 8K cxstack */
2341     curstackinfo = new_stackinfo(REASONABLE(128),
2342                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2343     curstackinfo->si_type = SI_MAIN;
2344     curstack = curstackinfo->si_stack;
2345     mainstack = curstack;               /* remember in case we switch stacks */
2346
2347     stack_base = AvARRAY(curstack);
2348     stack_sp = stack_base;
2349     stack_max = stack_base + AvMAX(curstack);
2350
2351     New(50,tmps_stack,REASONABLE(128),SV*);
2352     tmps_floor = -1;
2353     tmps_ix = -1;
2354     tmps_max = REASONABLE(128);
2355
2356     New(54,markstack,REASONABLE(32),I32);
2357     markstack_ptr = markstack;
2358     markstack_max = markstack + REASONABLE(32);
2359
2360     SET_MARKBASE;
2361
2362     New(54,scopestack,REASONABLE(32),I32);
2363     scopestack_ix = 0;
2364     scopestack_max = REASONABLE(32);
2365
2366     New(54,savestack,REASONABLE(128),ANY);
2367     savestack_ix = 0;
2368     savestack_max = REASONABLE(128);
2369
2370     New(54,retstack,REASONABLE(16),OP*);
2371     retstack_ix = 0;
2372     retstack_max = REASONABLE(16);
2373 }
2374
2375 #undef REASONABLE
2376
2377 STATIC void
2378 nuke_stacks(void)
2379 {
2380     dTHR;
2381     while (curstackinfo->si_next)
2382         curstackinfo = curstackinfo->si_next;
2383     while (curstackinfo) {
2384         PERL_SI *p = curstackinfo->si_prev;
2385         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2386         Safefree(curstackinfo->si_cxstack);
2387         Safefree(curstackinfo);
2388         curstackinfo = p;
2389     }
2390     Safefree(tmps_stack);
2391     Safefree(markstack);
2392     Safefree(scopestack);
2393     Safefree(savestack);
2394     Safefree(retstack);
2395     DEBUG( {
2396         Safefree(debname);
2397         Safefree(debdelim);
2398     } )
2399 }
2400
2401 #ifndef PERL_OBJECT
2402 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2403 #endif
2404
2405 STATIC void
2406 init_lexer(void)
2407 {
2408 #ifdef PERL_OBJECT
2409         PerlIO *tmpfp;
2410 #endif
2411     tmpfp = rsfp;
2412     rsfp = Nullfp;
2413     lex_start(linestr);
2414     rsfp = tmpfp;
2415     subname = newSVpv("main",4);
2416 }
2417
2418 STATIC void
2419 init_predump_symbols(void)
2420 {
2421     dTHR;
2422     GV *tmpgv;
2423     GV *othergv;
2424
2425     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2426     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2427     GvMULTI_on(stdingv);
2428     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2429     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2430     GvMULTI_on(tmpgv);
2431     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2432
2433     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2434     GvMULTI_on(tmpgv);
2435     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2436     setdefout(tmpgv);
2437     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2438     GvMULTI_on(tmpgv);
2439     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2440
2441     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2442     GvMULTI_on(othergv);
2443     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2444     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2445     GvMULTI_on(tmpgv);
2446     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2447
2448     statname = NEWSV(66,0);             /* last filename we did stat on */
2449
2450     if (!osname)
2451         osname = savepv(OSNAME);
2452 }
2453
2454 STATIC void
2455 init_postdump_symbols(register int argc, register char **argv, register char **env)
2456 {
2457     dTHR;
2458     char *s;
2459     SV *sv;
2460     GV* tmpgv;
2461
2462     argc--,argv++;      /* skip name of script */
2463     if (doswitches) {
2464         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2465             if (!argv[0][1])
2466                 break;
2467             if (argv[0][1] == '-') {
2468                 argc--,argv++;
2469                 break;
2470             }
2471             if (s = strchr(argv[0], '=')) {
2472                 *s++ = '\0';
2473                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2474             }
2475             else
2476                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2477         }
2478     }
2479     toptarget = NEWSV(0,0);
2480     sv_upgrade(toptarget, SVt_PVFM);
2481     sv_setpvn(toptarget, "", 0);
2482     bodytarget = NEWSV(0,0);
2483     sv_upgrade(bodytarget, SVt_PVFM);
2484     sv_setpvn(bodytarget, "", 0);
2485     formtarget = bodytarget;
2486
2487     TAINT;
2488     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2489         sv_setpv(GvSV(tmpgv),origfilename);
2490         magicname("0", "0", 1);
2491     }
2492     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2493         sv_setpv(GvSV(tmpgv),origargv[0]);
2494     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2495         GvMULTI_on(argvgv);
2496         (void)gv_AVadd(argvgv);
2497         av_clear(GvAVn(argvgv));
2498         for (; argc > 0; argc--,argv++) {
2499             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2500         }
2501     }
2502     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2503         HV *hv;
2504         GvMULTI_on(envgv);
2505         hv = GvHVn(envgv);
2506         hv_magic(hv, envgv, 'E');
2507 #ifndef VMS  /* VMS doesn't have environ array */
2508         /* Note that if the supplied env parameter is actually a copy
2509            of the global environ then it may now point to free'd memory
2510            if the environment has been modified since. To avoid this
2511            problem we treat env==NULL as meaning 'use the default'
2512         */
2513         if (!env)
2514             env = environ;
2515         if (env != environ)
2516             environ[0] = Nullch;
2517         for (; *env; env++) {
2518             if (!(s = strchr(*env,'=')))
2519                 continue;
2520             *s++ = '\0';
2521 #if defined(MSDOS)
2522             (void)strupr(*env);
2523 #endif
2524             sv = newSVpv(s--,0);
2525             (void)hv_store(hv, *env, s - *env, sv, 0);
2526             *s = '=';
2527 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2528             /* Sins of the RTL. See note in my_setenv(). */
2529             (void)PerlEnv_putenv(savepv(*env));
2530 #endif
2531         }
2532 #endif
2533 #ifdef DYNAMIC_ENV_FETCH
2534         HvNAME(hv) = savepv(ENV_HV_NAME);
2535 #endif
2536     }
2537     TAINT_NOT;
2538     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2539         sv_setiv(GvSV(tmpgv), (IV)getpid());
2540 }
2541
2542 STATIC void
2543 init_perllib(void)
2544 {
2545     char *s;
2546     if (!tainting) {
2547 #ifndef VMS
2548         s = PerlEnv_getenv("PERL5LIB");
2549         if (s)
2550             incpush(s, TRUE);
2551         else
2552             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2553 #else /* VMS */
2554         /* Treat PERL5?LIB as a possible search list logical name -- the
2555          * "natural" VMS idiom for a Unix path string.  We allow each
2556          * element to be a set of |-separated directories for compatibility.
2557          */
2558         char buf[256];
2559         int idx = 0;
2560         if (my_trnlnm("PERL5LIB",buf,0))
2561             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2562         else
2563             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2564 #endif /* VMS */
2565     }
2566
2567 /* Use the ~-expanded versions of APPLLIB (undocumented),
2568     ARCHLIB PRIVLIB SITEARCH and SITELIB
2569 */
2570 #ifdef APPLLIB_EXP
2571     incpush(APPLLIB_EXP, TRUE);
2572 #endif
2573
2574 #ifdef ARCHLIB_EXP
2575     incpush(ARCHLIB_EXP, FALSE);
2576 #endif
2577 #ifndef PRIVLIB_EXP
2578 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2579 #endif
2580 #if defined(WIN32)
2581     incpush(PRIVLIB_EXP, TRUE);
2582 #else
2583     incpush(PRIVLIB_EXP, FALSE);
2584 #endif
2585
2586 #ifdef SITEARCH_EXP
2587     incpush(SITEARCH_EXP, FALSE);
2588 #endif
2589 #ifdef SITELIB_EXP
2590 #if defined(WIN32)
2591     incpush(SITELIB_EXP, TRUE);
2592 #else
2593     incpush(SITELIB_EXP, FALSE);
2594 #endif
2595 #endif
2596     if (!tainting)
2597         incpush(".", FALSE);
2598 }
2599
2600 #if defined(DOSISH)
2601 #    define PERLLIB_SEP ';'
2602 #else
2603 #  if defined(VMS)
2604 #    define PERLLIB_SEP '|'
2605 #  else
2606 #    define PERLLIB_SEP ':'
2607 #  endif
2608 #endif
2609 #ifndef PERLLIB_MANGLE
2610 #  define PERLLIB_MANGLE(s,n) (s)
2611 #endif
2612
2613 STATIC void
2614 incpush(char *p, int addsubdirs)
2615 {
2616     SV *subdir = Nullsv;
2617
2618     if (!p)
2619         return;
2620
2621     if (addsubdirs) {
2622         subdir = sv_newmortal();
2623         if (!archpat_auto) {
2624             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2625                           + sizeof("//auto"));
2626             New(55, archpat_auto, len, char);
2627             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2628 #ifdef VMS
2629         for (len = sizeof(ARCHNAME) + 2;
2630              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2631                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2632 #endif
2633         }
2634     }
2635
2636     /* Break at all separators */
2637     while (p && *p) {
2638         SV *libdir = NEWSV(55,0);
2639         char *s;
2640
2641         /* skip any consecutive separators */
2642         while ( *p == PERLLIB_SEP ) {
2643             /* Uncomment the next line for PATH semantics */
2644             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2645             p++;
2646         }
2647
2648         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2649             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2650                       (STRLEN)(s - p));
2651             p = s + 1;
2652         }
2653         else {
2654             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2655             p = Nullch; /* break out */
2656         }
2657
2658         /*
2659          * BEFORE pushing libdir onto @INC we may first push version- and
2660          * archname-specific sub-directories.
2661          */
2662         if (addsubdirs) {
2663             struct stat tmpstatbuf;
2664 #ifdef VMS
2665             char *unix;
2666             STRLEN len;
2667
2668             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2669                 len = strlen(unix);
2670                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2671                 sv_usepvn(libdir,unix,len);
2672             }
2673             else
2674                 PerlIO_printf(PerlIO_stderr(),
2675                               "Failed to unixify @INC element \"%s\"\n",
2676                               SvPV(libdir,na));
2677 #endif
2678             /* .../archname/version if -d .../archname/version/auto */
2679             sv_setsv(subdir, libdir);
2680             sv_catpv(subdir, archpat_auto);
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             /* .../archname if -d .../archname/auto */
2687             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2688                       strlen(patchlevel) + 1, "", 0);
2689             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2690                   S_ISDIR(tmpstatbuf.st_mode))
2691                 av_push(GvAVn(incgv),
2692                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2693         }
2694
2695         /* finally push this lib directory on the end of @INC */
2696         av_push(GvAVn(incgv), libdir);
2697     }
2698 }
2699
2700 #ifdef USE_THREADS
2701 STATIC struct perl_thread *
2702 init_main_thread()
2703 {
2704     struct perl_thread *thr;
2705     XPV *xpv;
2706
2707     Newz(53, thr, 1, struct perl_thread);
2708     curcop = &compiling;
2709     thr->cvcache = newHV();
2710     thr->threadsv = newAV();
2711     /* thr->threadsvp is set when find_threadsv is called */
2712     thr->specific = newAV();
2713     thr->errhv = newHV();
2714     thr->flags = THRf_R_JOINABLE;
2715     MUTEX_INIT(&thr->mutex);
2716     /* Handcraft thrsv similarly to mess_sv */
2717     New(53, thrsv, 1, SV);
2718     Newz(53, xpv, 1, XPV);
2719     SvFLAGS(thrsv) = SVt_PV;
2720     SvANY(thrsv) = (void*)xpv;
2721     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2722     SvPVX(thrsv) = (char*)thr;
2723     SvCUR_set(thrsv, sizeof(thr));
2724     SvLEN_set(thrsv, sizeof(thr));
2725     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2726     thr->oursv = thrsv;
2727     chopset = " \n-";
2728
2729     MUTEX_LOCK(&threads_mutex);
2730     nthreads++;
2731     thr->tid = 0;
2732     thr->next = thr;
2733     thr->prev = thr;
2734     MUTEX_UNLOCK(&threads_mutex);
2735
2736 #ifdef HAVE_THREAD_INTERN
2737     init_thread_intern(thr);
2738 #endif
2739
2740 #ifdef SET_THREAD_SELF
2741     SET_THREAD_SELF(thr);
2742 #else
2743     thr->self = pthread_self();
2744 #endif /* SET_THREAD_SELF */
2745     SET_THR(thr);
2746
2747     /*
2748      * These must come after the SET_THR because sv_setpvn does
2749      * SvTAINT and the taint fields require dTHR.
2750      */
2751     toptarget = NEWSV(0,0);
2752     sv_upgrade(toptarget, SVt_PVFM);
2753     sv_setpvn(toptarget, "", 0);
2754     bodytarget = NEWSV(0,0);
2755     sv_upgrade(bodytarget, SVt_PVFM);
2756     sv_setpvn(bodytarget, "", 0);
2757     formtarget = bodytarget;
2758     thr->errsv = newSVpv("", 0);
2759     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2760     return thr;
2761 }
2762 #endif /* USE_THREADS */
2763
2764 void
2765 call_list(I32 oldscope, AV *paramList)
2766 {
2767     dTHR;
2768     line_t oldline = curcop->cop_line;
2769     STRLEN len;
2770     dJMPENV;
2771     int ret;
2772
2773     while (AvFILL(paramList) >= 0) {
2774         CV *cv = (CV*)av_shift(paramList);
2775
2776         SAVEFREESV(cv);
2777
2778         JMPENV_PUSH(ret);
2779         switch (ret) {
2780         case 0: {
2781                 SV* atsv = ERRSV;
2782                 PUSHMARK(stack_sp);
2783                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2784                 (void)SvPV(atsv, len);
2785                 if (len) {
2786                     JMPENV_POP;
2787                     curcop = &compiling;
2788                     curcop->cop_line = oldline;
2789                     if (paramList == beginav)
2790                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2791                     else
2792                         sv_catpv(atsv, "END failed--cleanup aborted");
2793                     while (scopestack_ix > oldscope)
2794                         LEAVE;
2795                     croak("%s", SvPVX(atsv));
2796                 }
2797             }
2798             break;
2799         case 1:
2800             STATUS_ALL_FAILURE;
2801             /* FALL THROUGH */
2802         case 2:
2803             /* my_exit() was called */
2804             while (scopestack_ix > oldscope)
2805                 LEAVE;
2806             FREETMPS;
2807             curstash = defstash;
2808             if (endav)
2809                 call_list(oldscope, endav);
2810             JMPENV_POP;
2811             curcop = &compiling;
2812             curcop->cop_line = oldline;
2813             if (statusvalue) {
2814                 if (paramList == beginav)
2815                     croak("BEGIN failed--compilation aborted");
2816                 else
2817                     croak("END failed--cleanup aborted");
2818             }
2819             my_exit_jump();
2820             /* NOTREACHED */
2821         case 3:
2822             if (!restartop) {
2823                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2824                 FREETMPS;
2825                 break;
2826             }
2827             JMPENV_POP;
2828             curcop = &compiling;
2829             curcop->cop_line = oldline;
2830             JMPENV_JUMP(3);
2831         }
2832         JMPENV_POP;
2833     }
2834 }
2835
2836 void
2837 my_exit(U32 status)
2838 {
2839     dTHR;
2840
2841 #ifdef USE_THREADS
2842     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2843                           thr, (unsigned long) status));
2844 #endif /* USE_THREADS */
2845     switch (status) {
2846     case 0:
2847         STATUS_ALL_SUCCESS;
2848         break;
2849     case 1:
2850         STATUS_ALL_FAILURE;
2851         break;
2852     default:
2853         STATUS_NATIVE_SET(status);
2854         break;
2855     }
2856     my_exit_jump();
2857 }
2858
2859 void
2860 my_failure_exit(void)
2861 {
2862 #ifdef VMS
2863     if (vaxc$errno & 1) {
2864         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2865             STATUS_NATIVE_SET(44);
2866     }
2867     else {
2868         if (!vaxc$errno && errno)       /* unlikely */
2869             STATUS_NATIVE_SET(44);
2870         else
2871             STATUS_NATIVE_SET(vaxc$errno);
2872     }
2873 #else
2874     int exitstatus;
2875     if (errno & 255)
2876         STATUS_POSIX_SET(errno);
2877     else {
2878         exitstatus = STATUS_POSIX >> 8;
2879         if (exitstatus & 255)
2880             STATUS_POSIX_SET(exitstatus);
2881         else
2882             STATUS_POSIX_SET(255);
2883     }
2884 #endif
2885     my_exit_jump();
2886 }
2887
2888 STATIC void
2889 my_exit_jump(void)
2890 {
2891     dSP;
2892     register PERL_CONTEXT *cx;
2893     I32 gimme;
2894     SV **newsp;
2895
2896     if (e_script) {
2897         SvREFCNT_dec(e_script);
2898         e_script = Nullsv;
2899     }
2900
2901     POPSTACK_TO(mainstack);
2902     if (cxstack_ix >= 0) {
2903         if (cxstack_ix > 0)
2904             dounwind(0);
2905         POPBLOCK(cx,curpm);
2906         LEAVE;
2907     }
2908
2909     JMPENV_JUMP(2);
2910 }
2911
2912
2913 #include "XSUB.h"
2914
2915 static I32
2916 #ifdef PERL_OBJECT
2917 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
2918 #else
2919 read_e_script(int idx, SV *buf_sv, int maxlen)
2920 #endif
2921 {
2922     char *p, *nl;
2923     p  = SvPVX(e_script);
2924     nl = strchr(p, '\n');
2925     nl = (nl) ? nl+1 : SvEND(e_script);
2926     if (nl-p == 0)
2927         return 0;
2928     sv_catpvn(buf_sv, p, nl-p);
2929     sv_chop(e_script, nl);
2930     return 1;
2931 }
2932
2933