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 #ifdef USE_THREADS
1090     PADOFFSET tmp;
1091     if (name[1] == '\0' && !isALPHA(name[0])
1092         && (tmp = find_thread_magical(name)) != NOT_IN_PAD) {
1093         return *av_fetch(thr->magicals, tmp, FALSE);
1094     }
1095 #endif /* USE_THREADS */
1096     GV* gv = gv_fetchpv(name, create, SVt_PV);
1097     if (gv)
1098         return GvSV(gv);
1099     return Nullsv;
1100 }
1101
1102 AV*
1103 perl_get_av(name, create)
1104 char* name;
1105 I32 create;
1106 {
1107     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1108     if (create)
1109         return GvAVn(gv);
1110     if (gv)
1111         return GvAV(gv);
1112     return Nullav;
1113 }
1114
1115 HV*
1116 perl_get_hv(name, create)
1117 char* name;
1118 I32 create;
1119 {
1120     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1121     if (create)
1122         return GvHVn(gv);
1123     if (gv)
1124         return GvHV(gv);
1125     return Nullhv;
1126 }
1127
1128 CV*
1129 perl_get_cv(name, create)
1130 char* name;
1131 I32 create;
1132 {
1133     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1134     if (create && !GvCVu(gv))
1135         return newSUB(start_subparse(FALSE, 0),
1136                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1137                       Nullop,
1138                       Nullop);
1139     if (gv)
1140         return GvCVu(gv);
1141     return Nullcv;
1142 }
1143
1144 /* Be sure to refetch the stack pointer after calling these routines. */
1145
1146 I32
1147 perl_call_argv(subname, flags, argv)
1148 char *subname;
1149 I32 flags;              /* See G_* flags in cop.h */
1150 register char **argv;   /* null terminated arg list */
1151 {
1152     dTHR;
1153     dSP;
1154
1155     PUSHMARK(sp);
1156     if (argv) {
1157         while (*argv) {
1158             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1159             argv++;
1160         }
1161         PUTBACK;
1162     }
1163     return perl_call_pv(subname, flags);
1164 }
1165
1166 I32
1167 perl_call_pv(subname, flags)
1168 char *subname;          /* name of the subroutine */
1169 I32 flags;              /* See G_* flags in cop.h */
1170 {
1171     return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1172 }
1173
1174 I32
1175 perl_call_method(methname, flags)
1176 char *methname;         /* name of the subroutine */
1177 I32 flags;              /* See G_* flags in cop.h */
1178 {
1179     dTHR;
1180     dSP;
1181     OP myop;
1182     if (!op)
1183         op = &myop;
1184     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1185     PUTBACK;
1186     pp_method(ARGS);
1187     return perl_call_sv(*stack_sp--, flags);
1188 }
1189
1190 /* May be called with any of a CV, a GV, or an SV containing the name. */
1191 I32
1192 perl_call_sv(sv, flags)
1193 SV* sv;
1194 I32 flags;              /* See G_* flags in cop.h */
1195 {
1196     dTHR;
1197     LOGOP myop;         /* fake syntax tree node */
1198     SV** sp = stack_sp;
1199     I32 oldmark;
1200     I32 retval;
1201     I32 oldscope;
1202     static CV *DBcv;
1203     bool oldcatch = CATCH_GET;
1204     dJMPENV;
1205     int ret;
1206     OP* oldop = op;
1207
1208     if (flags & G_DISCARD) {
1209         ENTER;
1210         SAVETMPS;
1211     }
1212
1213     Zero(&myop, 1, LOGOP);
1214     myop.op_next = Nullop;
1215     if (!(flags & G_NOARGS))
1216         myop.op_flags |= OPf_STACKED;
1217     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1218                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1219                       OPf_WANT_SCALAR);
1220     SAVEOP();
1221     op = (OP*)&myop;
1222
1223     EXTEND(stack_sp, 1);
1224     *++stack_sp = sv;
1225     oldmark = TOPMARK;
1226     oldscope = scopestack_ix;
1227
1228     if (PERLDB_SUB && curstash != debstash
1229            /* Handle first BEGIN of -d. */
1230           && (DBcv || (DBcv = GvCV(DBsub)))
1231            /* Try harder, since this may have been a sighandler, thus
1232             * curstash may be meaningless. */
1233           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1234         op->op_private |= OPpENTERSUB_DB;
1235
1236     if (flags & G_EVAL) {
1237         cLOGOP->op_other = op;
1238         markstack_ptr--;
1239         /* we're trying to emulate pp_entertry() here */
1240         {
1241             register CONTEXT *cx;
1242             I32 gimme = GIMME_V;
1243
1244             ENTER;
1245             SAVETMPS;
1246
1247             push_return(op->op_next);
1248             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1249             PUSHEVAL(cx, 0, 0);
1250             eval_root = op;             /* Only needed so that goto works right. */
1251
1252             in_eval = 1;
1253             if (flags & G_KEEPERR)
1254                 in_eval |= 4;
1255             else
1256                 sv_setpv(ERRSV,"");
1257         }
1258         markstack_ptr++;
1259
1260         JMPENV_PUSH(ret);
1261         switch (ret) {
1262         case 0:
1263             break;
1264         case 1:
1265             STATUS_ALL_FAILURE;
1266             /* FALL THROUGH */
1267         case 2:
1268             /* my_exit() was called */
1269             curstash = defstash;
1270             FREETMPS;
1271             JMPENV_POP;
1272             if (statusvalue)
1273                 croak("Callback called exit");
1274             my_exit_jump();
1275             /* NOTREACHED */
1276         case 3:
1277             if (restartop) {
1278                 op = restartop;
1279                 restartop = 0;
1280                 break;
1281             }
1282             stack_sp = stack_base + oldmark;
1283             if (flags & G_ARRAY)
1284                 retval = 0;
1285             else {
1286                 retval = 1;
1287                 *++stack_sp = &sv_undef;
1288             }
1289             goto cleanup;
1290         }
1291     }
1292     else
1293         CATCH_SET(TRUE);
1294
1295     if (op == (OP*)&myop)
1296         op = pp_entersub(ARGS);
1297     if (op)
1298         runops();
1299     retval = stack_sp - (stack_base + oldmark);
1300     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1301         sv_setpv(ERRSV,"");
1302
1303   cleanup:
1304     if (flags & G_EVAL) {
1305         if (scopestack_ix > oldscope) {
1306             SV **newsp;
1307             PMOP *newpm;
1308             I32 gimme;
1309             register CONTEXT *cx;
1310             I32 optype;
1311
1312             POPBLOCK(cx,newpm);
1313             POPEVAL(cx);
1314             pop_return();
1315             curpm = newpm;
1316             LEAVE;
1317         }
1318         JMPENV_POP;
1319     }
1320     else
1321         CATCH_SET(oldcatch);
1322
1323     if (flags & G_DISCARD) {
1324         stack_sp = stack_base + oldmark;
1325         retval = 0;
1326         FREETMPS;
1327         LEAVE;
1328     }
1329     op = oldop;
1330     return retval;
1331 }
1332
1333 /* Eval a string. The G_EVAL flag is always assumed. */
1334
1335 I32
1336 perl_eval_sv(sv, flags)
1337 SV* sv;
1338 I32 flags;              /* See G_* flags in cop.h */
1339 {
1340     dTHR;
1341     UNOP myop;          /* fake syntax tree node */
1342     SV** sp = stack_sp;
1343     I32 oldmark = sp - stack_base;
1344     I32 retval;
1345     I32 oldscope;
1346     dJMPENV;
1347     int ret;
1348     OP* oldop = op;
1349
1350     if (flags & G_DISCARD) {
1351         ENTER;
1352         SAVETMPS;
1353     }
1354
1355     SAVEOP();
1356     op = (OP*)&myop;
1357     Zero(op, 1, UNOP);
1358     EXTEND(stack_sp, 1);
1359     *++stack_sp = sv;
1360     oldscope = scopestack_ix;
1361
1362     if (!(flags & G_NOARGS))
1363         myop.op_flags = OPf_STACKED;
1364     myop.op_next = Nullop;
1365     myop.op_type = OP_ENTEREVAL;
1366     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1367                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1368                       OPf_WANT_SCALAR);
1369     if (flags & G_KEEPERR)
1370         myop.op_flags |= OPf_SPECIAL;
1371
1372     JMPENV_PUSH(ret);
1373     switch (ret) {
1374     case 0:
1375         break;
1376     case 1:
1377         STATUS_ALL_FAILURE;
1378         /* FALL THROUGH */
1379     case 2:
1380         /* my_exit() was called */
1381         curstash = defstash;
1382         FREETMPS;
1383         JMPENV_POP;
1384         if (statusvalue)
1385             croak("Callback called exit");
1386         my_exit_jump();
1387         /* NOTREACHED */
1388     case 3:
1389         if (restartop) {
1390             op = restartop;
1391             restartop = 0;
1392             break;
1393         }
1394         stack_sp = stack_base + oldmark;
1395         if (flags & G_ARRAY)
1396             retval = 0;
1397         else {
1398             retval = 1;
1399             *++stack_sp = &sv_undef;
1400         }
1401         goto cleanup;
1402     }
1403
1404     if (op == (OP*)&myop)
1405         op = pp_entereval(ARGS);
1406     if (op)
1407         runops();
1408     retval = stack_sp - (stack_base + oldmark);
1409     if (!(flags & G_KEEPERR))
1410         sv_setpv(ERRSV,"");
1411
1412   cleanup:
1413     JMPENV_POP;
1414     if (flags & G_DISCARD) {
1415         stack_sp = stack_base + oldmark;
1416         retval = 0;
1417         FREETMPS;
1418         LEAVE;
1419     }
1420     op = oldop;
1421     return retval;
1422 }
1423
1424 SV*
1425 perl_eval_pv(p, croak_on_error)
1426 char* p;
1427 I32 croak_on_error;
1428 {
1429     dTHR;
1430     dSP;
1431     SV* sv = newSVpv(p, 0);
1432
1433     PUSHMARK(sp);
1434     perl_eval_sv(sv, G_SCALAR);
1435     SvREFCNT_dec(sv);
1436
1437     SPAGAIN;
1438     sv = POPs;
1439     PUTBACK;
1440
1441     if (croak_on_error && SvTRUE(ERRSV))
1442         croak(SvPVx(ERRSV, na));
1443
1444     return sv;
1445 }
1446
1447 /* Require a module. */
1448
1449 void
1450 perl_require_pv(pv)
1451 char* pv;
1452 {
1453     SV* sv = sv_newmortal();
1454     sv_setpv(sv, "require '");
1455     sv_catpv(sv, pv);
1456     sv_catpv(sv, "'");
1457     perl_eval_sv(sv, G_DISCARD);
1458 }
1459
1460 void
1461 magicname(sym,name,namlen)
1462 char *sym;
1463 char *name;
1464 I32 namlen;
1465 {
1466     register GV *gv;
1467
1468     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1469         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1470 }
1471
1472 static void
1473 usage(name)             /* XXX move this out into a module ? */
1474 char *name;
1475 {
1476     /* This message really ought to be max 23 lines.
1477      * Removed -h because the user already knows that opton. Others? */
1478
1479     static char *usage[] = {
1480 "-0[octal]       specify record separator (\\0, if no argument)",
1481 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1482 "-c              check syntax only (runs BEGIN and END blocks)",
1483 "-d[:debugger]   run scripts under debugger",
1484 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1485 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1486 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1487 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1488 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1489 "-l[octal]       enable line ending processing, specifies line terminator",
1490 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1491 "-n              assume 'while (<>) { ... }' loop around your script",
1492 "-p              assume loop like -n but print line also like sed",
1493 "-P              run script through C preprocessor before compilation",
1494 "-s              enable some switch parsing for switches after script name",
1495 "-S              look for the script using PATH environment variable",
1496 "-T              turn on tainting checks",
1497 "-u              dump core after parsing script",
1498 "-U              allow unsafe operations",
1499 "-v              print version number and patchlevel of perl",
1500 "-V[:variable]   print perl configuration information",
1501 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1502 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1503 "\n",
1504 NULL
1505 };
1506     char **p = usage;
1507
1508     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1509     while (*p)
1510         printf("\n  %s", *p++);
1511 }
1512
1513 /* This routine handles any switches that can be given during run */
1514
1515 char *
1516 moreswitches(s)
1517 char *s;
1518 {
1519     I32 numlen;
1520     U32 rschar;
1521
1522     switch (*s) {
1523     case '0':
1524     {
1525         dTHR;
1526         rschar = scan_oct(s, 4, &numlen);
1527         SvREFCNT_dec(nrs);
1528         if (rschar & ~((U8)~0))
1529             nrs = &sv_undef;
1530         else if (!rschar && numlen >= 2)
1531             nrs = newSVpv("", 0);
1532         else {
1533             char ch = rschar;
1534             nrs = newSVpv(&ch, 1);
1535         }
1536         return s + numlen;
1537     }
1538     case 'F':
1539         minus_F = TRUE;
1540         splitstr = savepv(s + 1);
1541         s += strlen(s);
1542         return s;
1543     case 'a':
1544         minus_a = TRUE;
1545         s++;
1546         return s;
1547     case 'c':
1548         minus_c = TRUE;
1549         s++;
1550         return s;
1551     case 'd':
1552         forbid_setid("-d");
1553         s++;
1554         if (*s == ':' || *s == '=')  {
1555             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1556             s += strlen(s);
1557         }
1558         if (!perldb) {
1559             perldb = PERLDB_ALL;
1560             init_debugger();
1561         }
1562         return s;
1563     case 'D':
1564 #ifdef DEBUGGING
1565         forbid_setid("-D");
1566         if (isALPHA(s[1])) {
1567             static char debopts[] = "psltocPmfrxuLHXD";
1568             char *d;
1569
1570             for (s++; *s && (d = strchr(debopts,*s)); s++)
1571                 debug |= 1 << (d - debopts);
1572         }
1573         else {
1574             debug = atoi(s+1);
1575             for (s++; isDIGIT(*s); s++) ;
1576         }
1577         debug |= 0x80000000;
1578 #else
1579         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1580         for (s++; isALNUM(*s); s++) ;
1581 #endif
1582         /*SUPPRESS 530*/
1583         return s;
1584     case 'h':
1585         usage(origargv[0]);
1586         exit(0);
1587     case 'i':
1588         if (inplace)
1589             Safefree(inplace);
1590         inplace = savepv(s+1);
1591         /*SUPPRESS 530*/
1592         for (s = inplace; *s && !isSPACE(*s); s++) ;
1593         if (*s)
1594             *s++ = '\0';
1595         return s;
1596     case 'I':   /* -I handled both here and in parse_perl() */
1597         forbid_setid("-I");
1598         ++s;
1599         while (*s && isSPACE(*s))
1600             ++s;
1601         if (*s) {
1602             char *e, *p;
1603             for (e = s; *e && !isSPACE(*e); e++) ;
1604             p = savepvn(s, e-s);
1605             incpush(p, TRUE);
1606             Safefree(p);
1607             s = e;
1608         }
1609         else
1610             croak("No space allowed after -I");
1611         return s;
1612     case 'l':
1613         minus_l = TRUE;
1614         s++;
1615         if (ors)
1616             Safefree(ors);
1617         if (isDIGIT(*s)) {
1618             ors = savepv("\n");
1619             orslen = 1;
1620             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1621             s += numlen;
1622         }
1623         else {
1624             dTHR;
1625             if (RsPARA(nrs)) {
1626                 ors = "\n\n";
1627                 orslen = 2;
1628             }
1629             else
1630                 ors = SvPV(nrs, orslen);
1631             ors = savepvn(ors, orslen);
1632         }
1633         return s;
1634     case 'M':
1635         forbid_setid("-M");     /* XXX ? */
1636         /* FALL THROUGH */
1637     case 'm':
1638         forbid_setid("-m");     /* XXX ? */
1639         if (*++s) {
1640             char *start;
1641             SV *sv;
1642             char *use = "use ";
1643             /* -M-foo == 'no foo'       */
1644             if (*s == '-') { use = "no "; ++s; }
1645             sv = newSVpv(use,0);
1646             start = s;
1647             /* We allow -M'Module qw(Foo Bar)'  */
1648             while(isALNUM(*s) || *s==':') ++s;
1649             if (*s != '=') {
1650                 sv_catpv(sv, start);
1651                 if (*(start-1) == 'm') {
1652                     if (*s != '\0')
1653                         croak("Can't use '%c' after -mname", *s);
1654                     sv_catpv( sv, " ()");
1655                 }
1656             } else {
1657                 sv_catpvn(sv, start, s-start);
1658                 sv_catpv(sv, " split(/,/,q{");
1659                 sv_catpv(sv, ++s);
1660                 sv_catpv(sv,    "})");
1661             }
1662             s += strlen(s);
1663             if (preambleav == NULL)
1664                 preambleav = newAV();
1665             av_push(preambleav, sv);
1666         }
1667         else
1668             croak("No space allowed after -%c", *(s-1));
1669         return s;
1670     case 'n':
1671         minus_n = TRUE;
1672         s++;
1673         return s;
1674     case 'p':
1675         minus_p = TRUE;
1676         s++;
1677         return s;
1678     case 's':
1679         forbid_setid("-s");
1680         doswitches = TRUE;
1681         s++;
1682         return s;
1683     case 'T':
1684         if (!tainting)
1685             croak("Too late for \"-T\" option");
1686         s++;
1687         return s;
1688     case 'u':
1689         do_undump = TRUE;
1690         s++;
1691         return s;
1692     case 'U':
1693         unsafe = TRUE;
1694         s++;
1695         return s;
1696     case 'v':
1697 #if defined(SUBVERSION) && SUBVERSION > 0
1698         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1699             PATCHLEVEL, SUBVERSION, ARCHNAME);
1700 #else
1701         printf("\nThis is perl, version %s built for %s",
1702                 patchlevel, ARCHNAME);
1703 #endif
1704 #if defined(LOCAL_PATCH_COUNT)
1705         if (LOCAL_PATCH_COUNT > 0)
1706             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1707                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1708 #endif
1709
1710         printf("\n\nCopyright 1987-1997, Larry Wall\n");
1711 #ifdef MSDOS
1712         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1713 #endif
1714 #ifdef DJGPP
1715         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1716 #endif
1717 #ifdef OS2
1718         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1719             "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1720 #endif
1721 #ifdef atarist
1722         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1723 #endif
1724         printf("\n\
1725 Perl may be copied only under the terms of either the Artistic License or the\n\
1726 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1727         exit(0);
1728     case 'w':
1729         dowarn = TRUE;
1730         s++;
1731         return s;
1732     case '*':
1733     case ' ':
1734         if (s[1] == '-')        /* Additional switches on #! line. */
1735             return s+2;
1736         break;
1737     case '-':
1738     case 0:
1739     case '\n':
1740     case '\t':
1741         break;
1742 #ifdef ALTERNATE_SHEBANG
1743     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1744         break;
1745 #endif
1746     case 'P':
1747         if (preprocess)
1748             return s+1;
1749         /* FALL THROUGH */
1750     default:
1751         croak("Can't emulate -%.1s on #! line",s);
1752     }
1753     return Nullch;
1754 }
1755
1756 /* compliments of Tom Christiansen */
1757
1758 /* unexec() can be found in the Gnu emacs distribution */
1759
1760 void
1761 my_unexec()
1762 {
1763 #ifdef UNEXEC
1764     SV*    prog;
1765     SV*    file;
1766     int    status;
1767     extern int etext;
1768
1769     prog = newSVpv(BIN_EXP);
1770     sv_catpv(prog, "/perl");
1771     file = newSVpv(origfilename);
1772     sv_catpv(file, ".perldump");
1773
1774     status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1775     if (status)
1776         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1777                       SvPVX(prog), SvPVX(file));
1778     exit(status);
1779 #else
1780 #  ifdef VMS
1781 #    include <lib$routines.h>
1782      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1783 #  else
1784     ABORT();            /* for use with undump */
1785 #  endif
1786 #endif
1787 }
1788
1789 static void
1790 init_main_stash()
1791 {
1792     dTHR;
1793     GV *gv;
1794
1795     /* Note that strtab is a rather special HV.  Assumptions are made
1796        about not iterating on it, and not adding tie magic to it.
1797        It is properly deallocated in perl_destruct() */
1798     strtab = newHV();
1799     HvSHAREKEYS_off(strtab);                    /* mandatory */
1800     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1801          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1802
1803     curstash = defstash = newHV();
1804     curstname = newSVpv("main",4);
1805     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1806     SvREFCNT_dec(GvHV(gv));
1807     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1808     SvREADONLY_on(gv);
1809     HvNAME(defstash) = savepv("main");
1810     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1811     GvMULTI_on(incgv);
1812     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1813     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1814     GvMULTI_on(errgv);
1815     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1816     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1817     sv_setpvn(ERRSV, "", 0);
1818     curstash = defstash;
1819     compiling.cop_stash = defstash;
1820     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1821     /* We must init $/ before switches are processed. */
1822     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1823 }
1824
1825 #ifdef CAN_PROTOTYPE
1826 static void
1827 open_script(char *scriptname, bool dosearch, SV *sv)
1828 #else
1829 static void
1830 open_script(scriptname,dosearch,sv)
1831 char *scriptname;
1832 bool dosearch;
1833 SV *sv;
1834 #endif
1835 {
1836     dTHR;
1837     char *xfound = Nullch;
1838     char *xfailed = Nullch;
1839     register char *s;
1840     I32 len;
1841     int retval;
1842 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1843 #  define SEARCH_EXTS ".bat", ".cmd", NULL
1844 #  define MAX_EXT_LEN 4
1845 #endif
1846 #ifdef OS2
1847 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1848 #  define MAX_EXT_LEN 4
1849 #endif
1850 #ifdef VMS
1851 #  define SEARCH_EXTS ".pl", ".com", NULL
1852 #  define MAX_EXT_LEN 4
1853 #endif
1854     /* additional extensions to try in each dir if scriptname not found */
1855 #ifdef SEARCH_EXTS
1856     char *ext[] = { SEARCH_EXTS };
1857     int extidx = 0, i = 0;
1858     char *curext = Nullch;
1859 #else
1860 #  define MAX_EXT_LEN 0
1861 #endif
1862
1863     /*
1864      * If dosearch is true and if scriptname does not contain path
1865      * delimiters, search the PATH for scriptname.
1866      *
1867      * If SEARCH_EXTS is also defined, will look for each
1868      * scriptname{SEARCH_EXTS} whenever scriptname is not found
1869      * while searching the PATH.
1870      *
1871      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1872      * proceeds as follows:
1873      *   If DOSISH:
1874      *     + look for ./scriptname{,.foo,.bar}
1875      *     + search the PATH for scriptname{,.foo,.bar}
1876      *
1877      *   If !DOSISH:
1878      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
1879      *       this will not look in '.' if it's not in the PATH)
1880      */
1881
1882 #ifdef VMS
1883     if (dosearch) {
1884         int hasdir, idx = 0, deftypes = 1;
1885         bool seen_dot = 1;
1886
1887         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1888         /* The first time through, just add SEARCH_EXTS to whatever we
1889          * already have, so we can check for default file types. */
1890         while (deftypes ||
1891                (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1892         {
1893             if (deftypes) {
1894                 deftypes = 0;
1895                 *tokenbuf = '\0';
1896             }
1897             if ((strlen(tokenbuf) + strlen(scriptname)
1898                  + MAX_EXT_LEN) >= sizeof tokenbuf)
1899                 continue;       /* don't search dir with too-long name */
1900             strcat(tokenbuf, scriptname);
1901 #else  /* !VMS */
1902
1903 #ifdef DOSISH
1904     if (strEQ(scriptname, "-"))
1905         dosearch = 0;
1906     if (dosearch) {             /* Look in '.' first. */
1907         char *cur = scriptname;
1908 #ifdef SEARCH_EXTS
1909         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1910             while (ext[i])
1911                 if (strEQ(ext[i++],curext)) {
1912                     extidx = -1;                /* already has an ext */
1913                     break;
1914                 }
1915         do {
1916 #endif
1917             DEBUG_p(PerlIO_printf(Perl_debug_log,
1918                                   "Looking for %s\n",cur));
1919             if (Stat(cur,&statbuf) >= 0) {
1920                 dosearch = 0;
1921                 scriptname = cur;
1922 #ifdef SEARCH_EXTS
1923                 break;
1924 #endif
1925             }
1926 #ifdef SEARCH_EXTS
1927             if (cur == scriptname) {
1928                 len = strlen(scriptname);
1929                 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1930                     break;
1931                 cur = strcpy(tokenbuf, scriptname);
1932             }
1933         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
1934                  && strcpy(tokenbuf+len, ext[extidx++]));
1935 #endif
1936     }
1937 #endif
1938
1939     if (dosearch && !strchr(scriptname, '/')
1940 #ifdef DOSISH
1941                  && !strchr(scriptname, '\\')
1942 #endif
1943                  && (s = getenv("PATH"))) {
1944         bool seen_dot = 0;
1945
1946         bufend = s + strlen(s);
1947         while (s < bufend) {
1948 #if defined(atarist) || defined(DOSISH)
1949             for (len = 0; *s
1950 #  ifdef atarist
1951                     && *s != ','
1952 #  endif
1953                     && *s != ';'; len++, s++) {
1954                 if (len < sizeof tokenbuf)
1955                     tokenbuf[len] = *s;
1956             }
1957             if (len < sizeof tokenbuf)
1958                 tokenbuf[len] = '\0';
1959 #else  /* ! (atarist || DOSISH) */
1960             s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1961                         ':',
1962                         &len);
1963 #endif /* ! (atarist || DOSISH) */
1964             if (s < bufend)
1965                 s++;
1966             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1967                 continue;       /* don't search dir with too-long name */
1968             if (len
1969 #if defined(atarist) || defined(DOSISH)
1970                 && tokenbuf[len - 1] != '/'
1971                 && tokenbuf[len - 1] != '\\'
1972 #endif
1973                )
1974                 tokenbuf[len++] = '/';
1975             if (len == 2 && tokenbuf[0] == '.')
1976                 seen_dot = 1;
1977             (void)strcpy(tokenbuf + len, scriptname);
1978 #endif  /* !VMS */
1979
1980 #ifdef SEARCH_EXTS
1981             len = strlen(tokenbuf);
1982             if (extidx > 0)     /* reset after previous loop */
1983                 extidx = 0;
1984             do {
1985 #endif
1986                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1987                 retval = Stat(tokenbuf,&statbuf);
1988 #ifdef SEARCH_EXTS
1989             } while (  retval < 0               /* not there */
1990                     && extidx>=0 && ext[extidx] /* try an extension? */
1991                     && strcpy(tokenbuf+len, ext[extidx++])
1992                 );
1993 #endif
1994             if (retval < 0)
1995                 continue;
1996             if (S_ISREG(statbuf.st_mode)
1997                 && cando(S_IRUSR,TRUE,&statbuf)
1998 #ifndef DOSISH
1999                 && cando(S_IXUSR,TRUE,&statbuf)
2000 #endif
2001                 )
2002             {
2003                 xfound = tokenbuf;              /* bingo! */
2004                 break;
2005             }
2006             if (!xfailed)
2007                 xfailed = savepv(tokenbuf);
2008         }
2009 #ifndef DOSISH
2010         if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
2011 #endif
2012             seen_dot = 1;                       /* Disable message. */
2013         if (!xfound)
2014             croak("Can't %s %s%s%s",
2015                   (xfailed ? "execute" : "find"),
2016                   (xfailed ? xfailed : scriptname),
2017                   (xfailed ? "" : " on PATH"),
2018                   (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2019         if (xfailed)
2020             Safefree(xfailed);
2021         scriptname = xfound;
2022     }
2023
2024     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2025         char *s = scriptname + 8;
2026         fdscript = atoi(s);
2027         while (isDIGIT(*s))
2028             s++;
2029         if (*s)
2030             scriptname = s + 1;
2031     }
2032     else
2033         fdscript = -1;
2034     origfilename = savepv(e_tmpname ? "-e" : scriptname);
2035     curcop->cop_filegv = gv_fetchfile(origfilename);
2036     if (strEQ(origfilename,"-"))
2037         scriptname = "";
2038     if (fdscript >= 0) {
2039         rsfp = PerlIO_fdopen(fdscript,"r");
2040 #if defined(HAS_FCNTL) && defined(F_SETFD)
2041         if (rsfp)
2042             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2043 #endif
2044     }
2045     else if (preprocess) {
2046         char *cpp_cfg = CPPSTDIN;
2047         SV *cpp = NEWSV(0,0);
2048         SV *cmd = NEWSV(0,0);
2049
2050         if (strEQ(cpp_cfg, "cppstdin"))
2051             sv_catpvf(cpp, "%s/", BIN_EXP);
2052         sv_catpv(cpp, cpp_cfg);
2053
2054         sv_catpv(sv,"-I");
2055         sv_catpv(sv,PRIVLIB_EXP);
2056
2057 #ifdef MSDOS
2058         sv_setpvf(cmd, "\
2059 sed %s -e \"/^[^#]/b\" \
2060  -e \"/^#[      ]*include[      ]/b\" \
2061  -e \"/^#[      ]*define[       ]/b\" \
2062  -e \"/^#[      ]*if[   ]/b\" \
2063  -e \"/^#[      ]*ifdef[        ]/b\" \
2064  -e \"/^#[      ]*ifndef[       ]/b\" \
2065  -e \"/^#[      ]*else/b\" \
2066  -e \"/^#[      ]*elif[         ]/b\" \
2067  -e \"/^#[      ]*undef[        ]/b\" \
2068  -e \"/^#[      ]*endif/b\" \
2069  -e \"s/^#.*//\" \
2070  %s | %_ -C %_ %s",
2071           (doextract ? "-e \"1,/^#/d\n\"" : ""),
2072 #else
2073         sv_setpvf(cmd, "\
2074 %s %s -e '/^[^#]/b' \
2075  -e '/^#[       ]*include[      ]/b' \
2076  -e '/^#[       ]*define[       ]/b' \
2077  -e '/^#[       ]*if[   ]/b' \
2078  -e '/^#[       ]*ifdef[        ]/b' \
2079  -e '/^#[       ]*ifndef[       ]/b' \
2080  -e '/^#[       ]*else/b' \
2081  -e '/^#[       ]*elif[         ]/b' \
2082  -e '/^#[       ]*undef[        ]/b' \
2083  -e '/^#[       ]*endif/b' \
2084  -e 's/^[       ]*#.*//' \
2085  %s | %_ -C %_ %s",
2086 #ifdef LOC_SED
2087           LOC_SED,
2088 #else
2089           "sed",
2090 #endif
2091           (doextract ? "-e '1,/^#/d\n'" : ""),
2092 #endif
2093           scriptname, cpp, sv, CPPMINUS);
2094         doextract = FALSE;
2095 #ifdef IAMSUID                          /* actually, this is caught earlier */
2096         if (euid != uid && !euid) {     /* if running suidperl */
2097 #ifdef HAS_SETEUID
2098             (void)seteuid(uid);         /* musn't stay setuid root */
2099 #else
2100 #ifdef HAS_SETREUID
2101             (void)setreuid((Uid_t)-1, uid);
2102 #else
2103 #ifdef HAS_SETRESUID
2104             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2105 #else
2106             setuid(uid);
2107 #endif
2108 #endif
2109 #endif
2110             if (geteuid() != uid)
2111                 croak("Can't do seteuid!\n");
2112         }
2113 #endif /* IAMSUID */
2114         rsfp = my_popen(SvPVX(cmd), "r");
2115         SvREFCNT_dec(cmd);
2116         SvREFCNT_dec(cpp);
2117     }
2118     else if (!*scriptname) {
2119         forbid_setid("program input from stdin");
2120         rsfp = PerlIO_stdin();
2121     }
2122     else {
2123         rsfp = PerlIO_open(scriptname,"r");
2124 #if defined(HAS_FCNTL) && defined(F_SETFD)
2125         if (rsfp)
2126             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2127 #endif
2128     }
2129     if (e_tmpname) {
2130         e_fp = rsfp;
2131     }
2132     if (!rsfp) {
2133 #ifdef DOSUID
2134 #ifndef IAMSUID         /* in case script is not readable before setuid */
2135         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2136           statbuf.st_mode & (S_ISUID|S_ISGID)) {
2137             /* try again */
2138             execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2139             croak("Can't do setuid\n");
2140         }
2141 #endif
2142 #endif
2143         croak("Can't open perl script \"%s\": %s\n",
2144           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2145     }
2146 }
2147
2148 static void
2149 validate_suid(validarg, scriptname)
2150 char *validarg;
2151 char *scriptname;
2152 {
2153     int which;
2154
2155     /* do we need to emulate setuid on scripts? */
2156
2157     /* This code is for those BSD systems that have setuid #! scripts disabled
2158      * in the kernel because of a security problem.  Merely defining DOSUID
2159      * in perl will not fix that problem, but if you have disabled setuid
2160      * scripts in the kernel, this will attempt to emulate setuid and setgid
2161      * on scripts that have those now-otherwise-useless bits set.  The setuid
2162      * root version must be called suidperl or sperlN.NNN.  If regular perl
2163      * discovers that it has opened a setuid script, it calls suidperl with
2164      * the same argv that it had.  If suidperl finds that the script it has
2165      * just opened is NOT setuid root, it sets the effective uid back to the
2166      * uid.  We don't just make perl setuid root because that loses the
2167      * effective uid we had before invoking perl, if it was different from the
2168      * uid.
2169      *
2170      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2171      * be defined in suidperl only.  suidperl must be setuid root.  The
2172      * Configure script will set this up for you if you want it.
2173      */
2174
2175 #ifdef DOSUID
2176     dTHR;
2177     char *s, *s2;
2178
2179     if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2180         croak("Can't stat script \"%s\"",origfilename);
2181     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2182         I32 len;
2183
2184 #ifdef IAMSUID
2185 #ifndef HAS_SETREUID
2186         /* On this access check to make sure the directories are readable,
2187          * there is actually a small window that the user could use to make
2188          * filename point to an accessible directory.  So there is a faint
2189          * chance that someone could execute a setuid script down in a
2190          * non-accessible directory.  I don't know what to do about that.
2191          * But I don't think it's too important.  The manual lies when
2192          * it says access() is useful in setuid programs.
2193          */
2194         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2195             croak("Permission denied");
2196 #else
2197         /* If we can swap euid and uid, then we can determine access rights
2198          * with a simple stat of the file, and then compare device and
2199          * inode to make sure we did stat() on the same file we opened.
2200          * Then we just have to make sure he or she can execute it.
2201          */
2202         {
2203             struct stat tmpstatbuf;
2204
2205             if (
2206 #ifdef HAS_SETREUID
2207                 setreuid(euid,uid) < 0
2208 #else
2209 # if HAS_SETRESUID
2210                 setresuid(euid,uid,(Uid_t)-1) < 0
2211 # endif
2212 #endif
2213                 || getuid() != euid || geteuid() != uid)
2214                 croak("Can't swap uid and euid");       /* really paranoid */
2215             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2216                 croak("Permission denied");     /* testing full pathname here */
2217             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2218                 tmpstatbuf.st_ino != statbuf.st_ino) {
2219                 (void)PerlIO_close(rsfp);
2220                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
2221                     PerlIO_printf(rsfp,
2222 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2223 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2224                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2225                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2226                         SvPVX(GvSV(curcop->cop_filegv)),
2227                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2228                     (void)my_pclose(rsfp);
2229                 }
2230                 croak("Permission denied\n");
2231             }
2232             if (
2233 #ifdef HAS_SETREUID
2234               setreuid(uid,euid) < 0
2235 #else
2236 # if defined(HAS_SETRESUID)
2237               setresuid(uid,euid,(Uid_t)-1) < 0
2238 # endif
2239 #endif
2240               || getuid() != uid || geteuid() != euid)
2241                 croak("Can't reswap uid and euid");
2242             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2243                 croak("Permission denied\n");
2244         }
2245 #endif /* HAS_SETREUID */
2246 #endif /* IAMSUID */
2247
2248         if (!S_ISREG(statbuf.st_mode))
2249             croak("Permission denied");
2250         if (statbuf.st_mode & S_IWOTH)
2251             croak("Setuid/gid script is writable by world");
2252         doswitches = FALSE;             /* -s is insecure in suid */
2253         curcop->cop_line++;
2254         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2255           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2256             croak("No #! line");
2257         s = SvPV(linestr,na)+2;
2258         if (*s == ' ') s++;
2259         while (!isSPACE(*s)) s++;
2260         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2261                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2262         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2263             croak("Not a perl script");
2264         while (*s == ' ' || *s == '\t') s++;
2265         /*
2266          * #! arg must be what we saw above.  They can invoke it by
2267          * mentioning suidperl explicitly, but they may not add any strange
2268          * arguments beyond what #! says if they do invoke suidperl that way.
2269          */
2270         len = strlen(validarg);
2271         if (strEQ(validarg," PHOOEY ") ||
2272             strnNE(s,validarg,len) || !isSPACE(s[len]))
2273             croak("Args must match #! line");
2274
2275 #ifndef IAMSUID
2276         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2277             euid == statbuf.st_uid)
2278             if (!do_undump)
2279                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2280 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2281 #endif /* IAMSUID */
2282
2283         if (euid) {     /* oops, we're not the setuid root perl */
2284             (void)PerlIO_close(rsfp);
2285 #ifndef IAMSUID
2286             /* try again */
2287             execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2288 #endif
2289             croak("Can't do setuid\n");
2290         }
2291
2292         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2293 #ifdef HAS_SETEGID
2294             (void)setegid(statbuf.st_gid);
2295 #else
2296 #ifdef HAS_SETREGID
2297            (void)setregid((Gid_t)-1,statbuf.st_gid);
2298 #else
2299 #ifdef HAS_SETRESGID
2300            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2301 #else
2302             setgid(statbuf.st_gid);
2303 #endif
2304 #endif
2305 #endif
2306             if (getegid() != statbuf.st_gid)
2307                 croak("Can't do setegid!\n");
2308         }
2309         if (statbuf.st_mode & S_ISUID) {
2310             if (statbuf.st_uid != euid)
2311 #ifdef HAS_SETEUID
2312                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2313 #else
2314 #ifdef HAS_SETREUID
2315                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2316 #else
2317 #ifdef HAS_SETRESUID
2318                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2319 #else
2320                 setuid(statbuf.st_uid);
2321 #endif
2322 #endif
2323 #endif
2324             if (geteuid() != statbuf.st_uid)
2325                 croak("Can't do seteuid!\n");
2326         }
2327         else if (uid) {                 /* oops, mustn't run as root */
2328 #ifdef HAS_SETEUID
2329           (void)seteuid((Uid_t)uid);
2330 #else
2331 #ifdef HAS_SETREUID
2332           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2333 #else
2334 #ifdef HAS_SETRESUID
2335           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2336 #else
2337           setuid((Uid_t)uid);
2338 #endif
2339 #endif
2340 #endif
2341             if (geteuid() != uid)
2342                 croak("Can't do seteuid!\n");
2343         }
2344         init_ids();
2345         if (!cando(S_IXUSR,TRUE,&statbuf))
2346             croak("Permission denied\n");       /* they can't do this */
2347     }
2348 #ifdef IAMSUID
2349     else if (preprocess)
2350         croak("-P not allowed for setuid/setgid script\n");
2351     else if (fdscript >= 0)
2352         croak("fd script not allowed in suidperl\n");
2353     else
2354         croak("Script is not setuid/setgid in suidperl\n");
2355
2356     /* We absolutely must clear out any saved ids here, so we */
2357     /* exec the real perl, substituting fd script for scriptname. */
2358     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2359     PerlIO_rewind(rsfp);
2360     lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2361     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2362     if (!origargv[which])
2363         croak("Permission denied");
2364     origargv[which] = savepv(form("/dev/fd/%d/%s",
2365                                   PerlIO_fileno(rsfp), origargv[which]));
2366 #if defined(HAS_FCNTL) && defined(F_SETFD)
2367     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2368 #endif
2369     execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);    /* try again */
2370     croak("Can't do setuid\n");
2371 #endif /* IAMSUID */
2372 #else /* !DOSUID */
2373     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2374 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2375         dTHR;
2376         Fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2377         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2378             ||
2379             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2380            )
2381             if (!do_undump)
2382                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2383 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2384 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2385         /* not set-id, must be wrapped */
2386     }
2387 #endif /* DOSUID */
2388 }
2389
2390 static void
2391 find_beginning()
2392 {
2393     register char *s, *s2;
2394
2395     /* skip forward in input to the real script? */
2396
2397     forbid_setid("-x");
2398     while (doextract) {
2399         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2400             croak("No Perl script found in input\n");
2401         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2402             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2403             doextract = FALSE;
2404             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2405             s2 = s;
2406             while (*s == ' ' || *s == '\t') s++;
2407             if (*s++ == '-') {
2408                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2409                 if (strnEQ(s2-4,"perl",4))
2410                     /*SUPPRESS 530*/
2411                     while (s = moreswitches(s)) ;
2412             }
2413             if (cddir && chdir(cddir) < 0)
2414                 croak("Can't chdir to %s",cddir);
2415         }
2416     }
2417 }
2418
2419 static void
2420 init_ids()
2421 {
2422     uid = (int)getuid();
2423     euid = (int)geteuid();
2424     gid = (int)getgid();
2425     egid = (int)getegid();
2426 #ifdef VMS
2427     uid |= gid << 16;
2428     euid |= egid << 16;
2429 #endif
2430     tainting |= (uid && (euid != uid || egid != gid));
2431 }
2432
2433 static void
2434 forbid_setid(s)
2435 char *s;
2436 {
2437     if (euid != uid)
2438         croak("No %s allowed while running setuid", s);
2439     if (egid != gid)
2440         croak("No %s allowed while running setgid", s);
2441 }
2442
2443 static void
2444 init_debugger()
2445 {
2446     dTHR;
2447     curstash = debstash;
2448     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2449     AvREAL_off(dbargs);
2450     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2451     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2452     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2453     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2454     sv_setiv(DBsingle, 0);
2455     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2456     sv_setiv(DBtrace, 0);
2457     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2458     sv_setiv(DBsignal, 0);
2459     curstash = defstash;
2460 }
2461
2462 void
2463 init_stacks(ARGS)
2464 dARGS
2465 {
2466     curstack = newAV();
2467     mainstack = curstack;               /* remember in case we switch stacks */
2468     AvREAL_off(curstack);               /* not a real array */
2469     av_extend(curstack,127);
2470
2471     stack_base = AvARRAY(curstack);
2472     stack_sp = stack_base;
2473     stack_max = stack_base + 127;
2474
2475     cxstack_max = 8192 / sizeof(CONTEXT) - 2;   /* Use most of 8K. */
2476     New(50,cxstack,cxstack_max + 1,CONTEXT);
2477     cxstack_ix  = -1;
2478
2479     New(50,tmps_stack,128,SV*);
2480     tmps_floor = -1;
2481     tmps_ix = -1;
2482     tmps_max = 128;
2483
2484     /*
2485      * The following stacks almost certainly should be per-interpreter,
2486      * but for now they're not.  XXX
2487      */
2488
2489     if (markstack) {
2490         markstack_ptr = markstack;
2491     } else {
2492         New(54,markstack,64,I32);
2493         markstack_ptr = markstack;
2494         markstack_max = markstack + 64;
2495     }
2496
2497     if (scopestack) {
2498         scopestack_ix = 0;
2499     } else {
2500         New(54,scopestack,32,I32);
2501         scopestack_ix = 0;
2502         scopestack_max = 32;
2503     }
2504
2505     if (savestack) {
2506         savestack_ix = 0;
2507     } else {
2508         New(54,savestack,128,ANY);
2509         savestack_ix = 0;
2510         savestack_max = 128;
2511     }
2512
2513     if (retstack) {
2514         retstack_ix = 0;
2515     } else {
2516         New(54,retstack,16,OP*);
2517         retstack_ix = 0;
2518         retstack_max = 16;
2519     }
2520 }
2521
2522 static void
2523 nuke_stacks()
2524 {
2525     dTHR;
2526     Safefree(cxstack);
2527     Safefree(tmps_stack);
2528     DEBUG( {
2529         Safefree(debname);
2530         Safefree(debdelim);
2531     } )
2532 }
2533
2534 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2535
2536 static void
2537 init_lexer()
2538 {
2539     tmpfp = rsfp;
2540     rsfp = Nullfp;
2541     lex_start(linestr);
2542     rsfp = tmpfp;
2543     subname = newSVpv("main",4);
2544 }
2545
2546 static void
2547 init_predump_symbols()
2548 {
2549     dTHR;
2550     GV *tmpgv;
2551     GV *othergv;
2552
2553 #ifdef USE_THREADS
2554     sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1);
2555 #else
2556     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2557 #endif /* USE_THREADS */
2558
2559     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2560     GvMULTI_on(stdingv);
2561     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2562     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2563     GvMULTI_on(tmpgv);
2564     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2565
2566     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2567     GvMULTI_on(tmpgv);
2568     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2569     setdefout(tmpgv);
2570     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2571     GvMULTI_on(tmpgv);
2572     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2573
2574     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2575     GvMULTI_on(othergv);
2576     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2577     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2578     GvMULTI_on(tmpgv);
2579     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2580
2581     statname = NEWSV(66,0);             /* last filename we did stat on */
2582
2583     if (!osname)
2584         osname = savepv(OSNAME);
2585 }
2586
2587 static void
2588 init_postdump_symbols(argc,argv,env)
2589 register int argc;
2590 register char **argv;
2591 register char **env;
2592 {
2593     dTHR;
2594     char *s;
2595     SV *sv;
2596     GV* tmpgv;
2597
2598     argc--,argv++;      /* skip name of script */
2599     if (doswitches) {
2600         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2601             if (!argv[0][1])
2602                 break;
2603             if (argv[0][1] == '-') {
2604                 argc--,argv++;
2605                 break;
2606             }
2607             if (s = strchr(argv[0], '=')) {
2608                 *s++ = '\0';
2609                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2610             }
2611             else
2612                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2613         }
2614     }
2615     toptarget = NEWSV(0,0);
2616     sv_upgrade(toptarget, SVt_PVFM);
2617     sv_setpvn(toptarget, "", 0);
2618     bodytarget = NEWSV(0,0);
2619     sv_upgrade(bodytarget, SVt_PVFM);
2620     sv_setpvn(bodytarget, "", 0);
2621     formtarget = bodytarget;
2622
2623     TAINT;
2624     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2625         sv_setpv(GvSV(tmpgv),origfilename);
2626         magicname("0", "0", 1);
2627     }
2628     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2629         sv_setpv(GvSV(tmpgv),origargv[0]);
2630     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2631         GvMULTI_on(argvgv);
2632         (void)gv_AVadd(argvgv);
2633         av_clear(GvAVn(argvgv));
2634         for (; argc > 0; argc--,argv++) {
2635             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2636         }
2637     }
2638     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2639         HV *hv;
2640         GvMULTI_on(envgv);
2641         hv = GvHVn(envgv);
2642         hv_magic(hv, envgv, 'E');
2643 #ifndef VMS  /* VMS doesn't have environ array */
2644         /* Note that if the supplied env parameter is actually a copy
2645            of the global environ then it may now point to free'd memory
2646            if the environment has been modified since. To avoid this
2647            problem we treat env==NULL as meaning 'use the default'
2648         */
2649         if (!env)
2650             env = environ;
2651         if (env != environ)
2652             environ[0] = Nullch;
2653         for (; *env; env++) {
2654             if (!(s = strchr(*env,'=')))
2655                 continue;
2656             *s++ = '\0';
2657 #ifdef WIN32
2658             (void)strupr(*env);
2659 #endif
2660             sv = newSVpv(s--,0);
2661             (void)hv_store(hv, *env, s - *env, sv, 0);
2662             *s = '=';
2663 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2664             /* Sins of the RTL. See note in my_setenv(). */
2665             (void)putenv(savepv(*env));
2666 #endif
2667         }
2668 #endif
2669 #ifdef DYNAMIC_ENV_FETCH
2670         HvNAME(hv) = savepv(ENV_HV_NAME);
2671 #endif
2672     }
2673     TAINT_NOT;
2674     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2675         sv_setiv(GvSV(tmpgv), (IV)getpid());
2676 }
2677
2678 static void
2679 init_perllib()
2680 {
2681     char *s;
2682     if (!tainting) {
2683 #ifndef VMS
2684         s = getenv("PERL5LIB");
2685         if (s)
2686             incpush(s, TRUE);
2687         else
2688             incpush(getenv("PERLLIB"), FALSE);
2689 #else /* VMS */
2690         /* Treat PERL5?LIB as a possible search list logical name -- the
2691          * "natural" VMS idiom for a Unix path string.  We allow each
2692          * element to be a set of |-separated directories for compatibility.
2693          */
2694         char buf[256];
2695         int idx = 0;
2696         if (my_trnlnm("PERL5LIB",buf,0))
2697             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2698         else
2699             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2700 #endif /* VMS */
2701     }
2702
2703 /* Use the ~-expanded versions of APPLLIB (undocumented),
2704     ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2705 */
2706 #ifdef APPLLIB_EXP
2707     incpush(APPLLIB_EXP, FALSE);
2708 #endif
2709
2710 #ifdef ARCHLIB_EXP
2711     incpush(ARCHLIB_EXP, FALSE);
2712 #endif
2713 #ifndef PRIVLIB_EXP
2714 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2715 #endif
2716     incpush(PRIVLIB_EXP, FALSE);
2717
2718 #ifdef SITEARCH_EXP
2719     incpush(SITEARCH_EXP, FALSE);
2720 #endif
2721 #ifdef SITELIB_EXP
2722     incpush(SITELIB_EXP, FALSE);
2723 #endif
2724 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2725     incpush(OLDARCHLIB_EXP, FALSE);
2726 #endif
2727
2728     if (!tainting)
2729         incpush(".", FALSE);
2730 }
2731
2732 #if defined(DOSISH)
2733 #    define PERLLIB_SEP ';'
2734 #else
2735 #  if defined(VMS)
2736 #    define PERLLIB_SEP '|'
2737 #  else
2738 #    define PERLLIB_SEP ':'
2739 #  endif
2740 #endif
2741 #ifndef PERLLIB_MANGLE
2742 #  define PERLLIB_MANGLE(s,n) (s)
2743 #endif
2744
2745 static void
2746 incpush(p, addsubdirs)
2747 char *p;
2748 int addsubdirs;
2749 {
2750     SV *subdir = Nullsv;
2751     static char *archpat_auto;
2752
2753     if (!p)
2754         return;
2755
2756     if (addsubdirs) {
2757         subdir = newSV(0);
2758         if (!archpat_auto) {
2759             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2760                           + sizeof("//auto"));
2761             New(55, archpat_auto, len, char);
2762             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2763 #ifdef VMS
2764         for (len = sizeof(ARCHNAME) + 2;
2765              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2766                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2767 #endif
2768         }
2769     }
2770
2771     /* Break at all separators */
2772     while (p && *p) {
2773         SV *libdir = newSV(0);
2774         char *s;
2775
2776         /* skip any consecutive separators */
2777         while ( *p == PERLLIB_SEP ) {
2778             /* Uncomment the next line for PATH semantics */
2779             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2780             p++;
2781         }
2782
2783         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2784             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2785                       (STRLEN)(s - p));
2786             p = s + 1;
2787         }
2788         else {
2789             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2790             p = Nullch; /* break out */
2791         }
2792
2793         /*
2794          * BEFORE pushing libdir onto @INC we may first push version- and
2795          * archname-specific sub-directories.
2796          */
2797         if (addsubdirs) {
2798             struct stat tmpstatbuf;
2799 #ifdef VMS
2800             char *unix;
2801             STRLEN len;
2802
2803             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2804                 len = strlen(unix);
2805                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2806                 sv_usepvn(libdir,unix,len);
2807             }
2808             else
2809                 PerlIO_printf(PerlIO_stderr(),
2810                               "Failed to unixify @INC element \"%s\"\n",
2811                               SvPV(libdir,na));
2812 #endif
2813             /* .../archname/version if -d .../archname/version/auto */
2814             sv_setsv(subdir, libdir);
2815             sv_catpv(subdir, archpat_auto);
2816             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2817                   S_ISDIR(tmpstatbuf.st_mode))
2818                 av_push(GvAVn(incgv),
2819                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2820
2821             /* .../archname if -d .../archname/auto */
2822             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2823                       strlen(patchlevel) + 1, "", 0);
2824             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2825                   S_ISDIR(tmpstatbuf.st_mode))
2826                 av_push(GvAVn(incgv),
2827                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2828         }
2829
2830         /* finally push this lib directory on the end of @INC */
2831         av_push(GvAVn(incgv), libdir);
2832     }
2833
2834     SvREFCNT_dec(subdir);
2835 }
2836
2837 #ifdef USE_THREADS
2838 static struct thread *
2839 init_main_thread()
2840 {
2841     struct thread *thr;
2842     XPV *xpv;
2843
2844     Newz(53, thr, 1, struct thread);
2845     curcop = &compiling;
2846     thr->cvcache = newHV();
2847     thr->magicals = newAV();
2848     thr->specific = newAV();
2849     thr->errsv = newSVpv("", 0);
2850     thr->errhv = newHV();
2851     thr->flags = THRf_R_JOINABLE;
2852     MUTEX_INIT(&thr->mutex);
2853     /* Handcraft thrsv similarly to mess_sv */
2854     New(53, thrsv, 1, SV);
2855     Newz(53, xpv, 1, XPV);
2856     SvFLAGS(thrsv) = SVt_PV;
2857     SvANY(thrsv) = (void*)xpv;
2858     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2859     SvPVX(thrsv) = (char*)thr;
2860     SvCUR_set(thrsv, sizeof(thr));
2861     SvLEN_set(thrsv, sizeof(thr));
2862     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2863     thr->oursv = thrsv;
2864     curcop = &compiling;
2865     chopset = " \n-";
2866
2867     MUTEX_LOCK(&threads_mutex);
2868     nthreads++;
2869     thr->tid = 0;
2870     thr->next = thr;
2871     thr->prev = thr;
2872     MUTEX_UNLOCK(&threads_mutex);
2873
2874 #ifdef HAVE_THREAD_INTERN
2875     init_thread_intern(thr);
2876 #else
2877     thr->self = pthread_self();
2878 #endif /* HAVE_THREAD_INTERN */
2879     SET_THR(thr);
2880
2881     /*
2882      * These must come after the SET_THR because sv_setpvn does
2883      * SvTAINT and the taint fields require dTHR.
2884      */
2885     toptarget = NEWSV(0,0);
2886     sv_upgrade(toptarget, SVt_PVFM);
2887     sv_setpvn(toptarget, "", 0);
2888     bodytarget = NEWSV(0,0);
2889     sv_upgrade(bodytarget, SVt_PVFM);
2890     sv_setpvn(bodytarget, "", 0);
2891     formtarget = bodytarget;
2892     return thr;
2893 }
2894 #endif /* USE_THREADS */
2895
2896 void
2897 call_list(oldscope, list)
2898 I32 oldscope;
2899 AV* list;
2900 {
2901     dTHR;
2902     line_t oldline = curcop->cop_line;
2903     STRLEN len;
2904     dJMPENV;
2905     int ret;
2906
2907     while (AvFILL(list) >= 0) {
2908         CV *cv = (CV*)av_shift(list);
2909
2910         SAVEFREESV(cv);
2911
2912         JMPENV_PUSH(ret);
2913         switch (ret) {
2914         case 0: {
2915                 SV* atsv = ERRSV;
2916                 PUSHMARK(stack_sp);
2917                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2918                 (void)SvPV(atsv, len);
2919                 if (len) {
2920                     JMPENV_POP;
2921                     curcop = &compiling;
2922                     curcop->cop_line = oldline;
2923                     if (list == beginav)
2924                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2925                     else
2926                         sv_catpv(atsv, "END failed--cleanup aborted");
2927                     while (scopestack_ix > oldscope)
2928                         LEAVE;
2929                     croak("%s", SvPVX(atsv));
2930                 }
2931             }
2932             break;
2933         case 1:
2934             STATUS_ALL_FAILURE;
2935             /* FALL THROUGH */
2936         case 2:
2937             /* my_exit() was called */
2938             while (scopestack_ix > oldscope)
2939                 LEAVE;
2940             FREETMPS;
2941             curstash = defstash;
2942             if (endav)
2943                 call_list(oldscope, endav);
2944             JMPENV_POP;
2945             curcop = &compiling;
2946             curcop->cop_line = oldline;
2947             if (statusvalue) {
2948                 if (list == beginav)
2949                     croak("BEGIN failed--compilation aborted");
2950                 else
2951                     croak("END failed--cleanup aborted");
2952             }
2953             my_exit_jump();
2954             /* NOTREACHED */
2955         case 3:
2956             if (!restartop) {
2957                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2958                 FREETMPS;
2959                 break;
2960             }
2961             JMPENV_POP;
2962             curcop = &compiling;
2963             curcop->cop_line = oldline;
2964             JMPENV_JUMP(3);
2965         }
2966         JMPENV_POP;
2967     }
2968 }
2969
2970 void
2971 my_exit(status)
2972 U32 status;
2973 {
2974     dTHR;
2975
2976 #ifdef USE_THREADS
2977     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2978                           thr, (unsigned long) status));
2979 #endif /* USE_THREADS */
2980     switch (status) {
2981     case 0:
2982         STATUS_ALL_SUCCESS;
2983         break;
2984     case 1:
2985         STATUS_ALL_FAILURE;
2986         break;
2987     default:
2988         STATUS_NATIVE_SET(status);
2989         break;
2990     }
2991     my_exit_jump();
2992 }
2993
2994 void
2995 my_failure_exit()
2996 {
2997 #ifdef VMS
2998     if (vaxc$errno & 1) {
2999         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3000             STATUS_NATIVE_SET(44);
3001     }
3002     else {
3003         if (!vaxc$errno && errno)       /* unlikely */
3004             STATUS_NATIVE_SET(44);
3005         else
3006             STATUS_NATIVE_SET(vaxc$errno);
3007     }
3008 #else
3009     if (errno & 255)
3010         STATUS_POSIX_SET(errno);
3011     else if (STATUS_POSIX == 0)
3012         STATUS_POSIX_SET(255);
3013 #endif
3014     my_exit_jump();
3015 }
3016
3017 static void
3018 my_exit_jump()
3019 {
3020     dTHR;
3021     register CONTEXT *cx;
3022     I32 gimme;
3023     SV **newsp;
3024
3025     if (e_tmpname) {
3026         if (e_fp) {
3027             PerlIO_close(e_fp);
3028             e_fp = Nullfp;
3029         }
3030         (void)UNLINK(e_tmpname);
3031         Safefree(e_tmpname);
3032         e_tmpname = Nullch;
3033     }
3034
3035     if (cxstack_ix >= 0) {
3036         if (cxstack_ix > 0)
3037             dounwind(0);
3038         POPBLOCK(cx,curpm);
3039         LEAVE;
3040     }
3041
3042     JMPENV_JUMP(2);
3043 }