perl.c

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