perl.c

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