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