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