perl.c

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