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