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