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