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