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