perl.c

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