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