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