perl.c

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