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