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-1998\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 static void
1759 open_script(char *scriptname, bool dosearch, SV *sv)
1760 {
1761     dTHR;
1762     char *xfound = Nullch;
1763     char *xfailed = Nullch;
1764     register char *s;
1765     I32 len;
1766     int retval;
1767 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1768 #  define SEARCH_EXTS ".bat", ".cmd", NULL
1769 #  define MAX_EXT_LEN 4
1770 #endif
1771 #ifdef OS2
1772 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1773 #  define MAX_EXT_LEN 4
1774 #endif
1775 #ifdef VMS
1776 #  define SEARCH_EXTS ".pl", ".com", NULL
1777 #  define MAX_EXT_LEN 4
1778 #endif
1779     /* additional extensions to try in each dir if scriptname not found */
1780 #ifdef SEARCH_EXTS
1781     char *ext[] = { SEARCH_EXTS };
1782     int extidx = 0, i = 0;
1783     char *curext = Nullch;
1784 #else
1785 #  define MAX_EXT_LEN 0
1786 #endif
1787
1788     /*
1789      * If dosearch is true and if scriptname does not contain path
1790      * delimiters, search the PATH for scriptname.
1791      *
1792      * If SEARCH_EXTS is also defined, will look for each
1793      * scriptname{SEARCH_EXTS} whenever scriptname is not found
1794      * while searching the PATH.
1795      *
1796      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1797      * proceeds as follows:
1798      *   If DOSISH or VMSISH:
1799      *     + look for ./scriptname{,.foo,.bar}
1800      *     + search the PATH for scriptname{,.foo,.bar}
1801      *
1802      *   If !DOSISH:
1803      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
1804      *       this will not look in '.' if it's not in the PATH)
1805      */
1806
1807 #ifdef VMS
1808 #  ifdef ALWAYS_DEFTYPES
1809     len = strlen(scriptname);
1810     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1811         int hasdir, idx = 0, deftypes = 1;
1812         bool seen_dot = 1;
1813
1814         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1815 #  else
1816     if (dosearch) {
1817         int hasdir, idx = 0, deftypes = 1;
1818         bool seen_dot = 1;
1819
1820         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1821 #  endif
1822         /* The first time through, just add SEARCH_EXTS to whatever we
1823          * already have, so we can check for default file types. */
1824         while (deftypes ||
1825                (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1826         {
1827             if (deftypes) {
1828                 deftypes = 0;
1829                 *tokenbuf = '\0';
1830             }
1831             if ((strlen(tokenbuf) + strlen(scriptname)
1832                  + MAX_EXT_LEN) >= sizeof tokenbuf)
1833                 continue;       /* don't search dir with too-long name */
1834             strcat(tokenbuf, scriptname);
1835 #else  /* !VMS */
1836
1837 #ifdef DOSISH
1838     if (strEQ(scriptname, "-"))
1839         dosearch = 0;
1840     if (dosearch) {             /* Look in '.' first. */
1841         char *cur = scriptname;
1842 #ifdef SEARCH_EXTS
1843         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1844             while (ext[i])
1845                 if (strEQ(ext[i++],curext)) {
1846                     extidx = -1;                /* already has an ext */
1847                     break;
1848                 }
1849         do {
1850 #endif
1851             DEBUG_p(PerlIO_printf(Perl_debug_log,
1852                                   "Looking for %s\n",cur));
1853             if (Stat(cur,&statbuf) >= 0) {
1854                 dosearch = 0;
1855                 scriptname = cur;
1856 #ifdef SEARCH_EXTS
1857                 break;
1858 #endif
1859             }
1860 #ifdef SEARCH_EXTS
1861             if (cur == scriptname) {
1862                 len = strlen(scriptname);
1863                 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1864                     break;
1865                 cur = strcpy(tokenbuf, scriptname);
1866             }
1867         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
1868                  && strcpy(tokenbuf+len, ext[extidx++]));
1869 #endif
1870     }
1871 #endif
1872
1873     if (dosearch && !strchr(scriptname, '/')
1874 #ifdef DOSISH
1875                  && !strchr(scriptname, '\\')
1876 #endif
1877                  && (s = PerlEnv_getenv("PATH"))) {
1878         bool seen_dot = 0;
1879
1880         bufend = s + strlen(s);
1881         while (s < bufend) {
1882 #if defined(atarist) || defined(DOSISH)
1883             for (len = 0; *s
1884 #  ifdef atarist
1885                     && *s != ','
1886 #  endif
1887                     && *s != ';'; len++, s++) {
1888                 if (len < sizeof tokenbuf)
1889                     tokenbuf[len] = *s;
1890             }
1891             if (len < sizeof tokenbuf)
1892                 tokenbuf[len] = '\0';
1893 #else  /* ! (atarist || DOSISH) */
1894             s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1895                         ':',
1896                         &len);
1897 #endif /* ! (atarist || DOSISH) */
1898             if (s < bufend)
1899                 s++;
1900             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1901                 continue;       /* don't search dir with too-long name */
1902             if (len
1903 #if defined(atarist) || defined(DOSISH)
1904                 && tokenbuf[len - 1] != '/'
1905                 && tokenbuf[len - 1] != '\\'
1906 #endif
1907                )
1908                 tokenbuf[len++] = '/';
1909             if (len == 2 && tokenbuf[0] == '.')
1910                 seen_dot = 1;
1911             (void)strcpy(tokenbuf + len, scriptname);
1912 #endif  /* !VMS */
1913
1914 #ifdef SEARCH_EXTS
1915             len = strlen(tokenbuf);
1916             if (extidx > 0)     /* reset after previous loop */
1917                 extidx = 0;
1918             do {
1919 #endif
1920                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1921                 retval = Stat(tokenbuf,&statbuf);
1922 #ifdef SEARCH_EXTS
1923             } while (  retval < 0               /* not there */
1924                     && extidx>=0 && ext[extidx] /* try an extension? */
1925                     && strcpy(tokenbuf+len, ext[extidx++])
1926                 );
1927 #endif
1928             if (retval < 0)
1929                 continue;
1930             if (S_ISREG(statbuf.st_mode)
1931                 && cando(S_IRUSR,TRUE,&statbuf)
1932 #ifndef DOSISH
1933                 && cando(S_IXUSR,TRUE,&statbuf)
1934 #endif
1935                 )
1936             {
1937                 xfound = tokenbuf;              /* bingo! */
1938                 break;
1939             }
1940             if (!xfailed)
1941                 xfailed = savepv(tokenbuf);
1942         }
1943 #ifndef DOSISH
1944         if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1945 #endif
1946             seen_dot = 1;                       /* Disable message. */
1947         if (!xfound)
1948             croak("Can't %s %s%s%s",
1949                   (xfailed ? "execute" : "find"),
1950                   (xfailed ? xfailed : scriptname),
1951                   (xfailed ? "" : " on PATH"),
1952                   (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1953         if (xfailed)
1954             Safefree(xfailed);
1955         scriptname = xfound;
1956     }
1957
1958     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1959         char *s = scriptname + 8;
1960         fdscript = atoi(s);
1961         while (isDIGIT(*s))
1962             s++;
1963         if (*s)
1964             scriptname = s + 1;
1965     }
1966     else
1967         fdscript = -1;
1968     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1969     curcop->cop_filegv = gv_fetchfile(origfilename);
1970     if (strEQ(origfilename,"-"))
1971         scriptname = "";
1972     if (fdscript >= 0) {
1973         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1974 #if defined(HAS_FCNTL) && defined(F_SETFD)
1975         if (rsfp)
1976             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1977 #endif
1978     }
1979     else if (preprocess) {
1980         char *cpp_cfg = CPPSTDIN;
1981         SV *cpp = NEWSV(0,0);
1982         SV *cmd = NEWSV(0,0);
1983
1984         if (strEQ(cpp_cfg, "cppstdin"))
1985             sv_catpvf(cpp, "%s/", BIN_EXP);
1986         sv_catpv(cpp, cpp_cfg);
1987
1988         sv_catpv(sv,"-I");
1989         sv_catpv(sv,PRIVLIB_EXP);
1990
1991 #ifdef MSDOS
1992         sv_setpvf(cmd, "\
1993 sed %s -e \"/^[^#]/b\" \
1994  -e \"/^#[      ]*include[      ]/b\" \
1995  -e \"/^#[      ]*define[       ]/b\" \
1996  -e \"/^#[      ]*if[   ]/b\" \
1997  -e \"/^#[      ]*ifdef[        ]/b\" \
1998  -e \"/^#[      ]*ifndef[       ]/b\" \
1999  -e \"/^#[      ]*else/b\" \
2000  -e \"/^#[      ]*elif[         ]/b\" \
2001  -e \"/^#[      ]*undef[        ]/b\" \
2002  -e \"/^#[      ]*endif/b\" \
2003  -e \"s/^#.*//\" \
2004  %s | %_ -C %_ %s",
2005           (doextract ? "-e \"1,/^#/d\n\"" : ""),
2006 #else
2007         sv_setpvf(cmd, "\
2008 %s %s -e '/^[^#]/b' \
2009  -e '/^#[       ]*include[      ]/b' \
2010  -e '/^#[       ]*define[       ]/b' \
2011  -e '/^#[       ]*if[   ]/b' \
2012  -e '/^#[       ]*ifdef[        ]/b' \
2013  -e '/^#[       ]*ifndef[       ]/b' \
2014  -e '/^#[       ]*else/b' \
2015  -e '/^#[       ]*elif[         ]/b' \
2016  -e '/^#[       ]*undef[        ]/b' \
2017  -e '/^#[       ]*endif/b' \
2018  -e 's/^[       ]*#.*//' \
2019  %s | %_ -C %_ %s",
2020 #ifdef LOC_SED
2021           LOC_SED,
2022 #else
2023           "sed",
2024 #endif
2025           (doextract ? "-e '1,/^#/d\n'" : ""),
2026 #endif
2027           scriptname, cpp, sv, CPPMINUS);
2028         doextract = FALSE;
2029 #ifdef IAMSUID                          /* actually, this is caught earlier */
2030         if (euid != uid && !euid) {     /* if running suidperl */
2031 #ifdef HAS_SETEUID
2032             (void)seteuid(uid);         /* musn't stay setuid root */
2033 #else
2034 #ifdef HAS_SETREUID
2035             (void)setreuid((Uid_t)-1, uid);
2036 #else
2037 #ifdef HAS_SETRESUID
2038             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2039 #else
2040             setuid(uid);
2041 #endif
2042 #endif
2043 #endif
2044             if (geteuid() != uid)
2045                 croak("Can't do seteuid!\n");
2046         }
2047 #endif /* IAMSUID */
2048         rsfp = PerlProc_popen(SvPVX(cmd), "r");
2049         SvREFCNT_dec(cmd);
2050         SvREFCNT_dec(cpp);
2051     }
2052     else if (!*scriptname) {
2053         forbid_setid("program input from stdin");
2054         rsfp = PerlIO_stdin();
2055     }
2056     else {
2057         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2058 #if defined(HAS_FCNTL) && defined(F_SETFD)
2059         if (rsfp)
2060             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2061 #endif
2062     }
2063     if (e_tmpname) {
2064         e_fp = rsfp;
2065     }
2066     if (!rsfp) {
2067 #ifdef DOSUID
2068 #ifndef IAMSUID         /* in case script is not readable before setuid */
2069         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2070           statbuf.st_mode & (S_ISUID|S_ISGID)) {
2071             /* try again */
2072             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2073             croak("Can't do setuid\n");
2074         }
2075 #endif
2076 #endif
2077         croak("Can't open perl script \"%s\": %s\n",
2078           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2079     }
2080 }
2081
2082 static void
2083 validate_suid(char *validarg, char *scriptname)
2084 {
2085     int which;
2086
2087     /* do we need to emulate setuid on scripts? */
2088
2089     /* This code is for those BSD systems that have setuid #! scripts disabled
2090      * in the kernel because of a security problem.  Merely defining DOSUID
2091      * in perl will not fix that problem, but if you have disabled setuid
2092      * scripts in the kernel, this will attempt to emulate setuid and setgid
2093      * on scripts that have those now-otherwise-useless bits set.  The setuid
2094      * root version must be called suidperl or sperlN.NNN.  If regular perl
2095      * discovers that it has opened a setuid script, it calls suidperl with
2096      * the same argv that it had.  If suidperl finds that the script it has
2097      * just opened is NOT setuid root, it sets the effective uid back to the
2098      * uid.  We don't just make perl setuid root because that loses the
2099      * effective uid we had before invoking perl, if it was different from the
2100      * uid.
2101      *
2102      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2103      * be defined in suidperl only.  suidperl must be setuid root.  The
2104      * Configure script will set this up for you if you want it.
2105      */
2106
2107 #ifdef DOSUID
2108     dTHR;
2109     char *s, *s2;
2110
2111     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2112         croak("Can't stat script \"%s\"",origfilename);
2113     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2114         I32 len;
2115
2116 #ifdef IAMSUID
2117 #ifndef HAS_SETREUID
2118         /* On this access check to make sure the directories are readable,
2119          * there is actually a small window that the user could use to make
2120          * filename point to an accessible directory.  So there is a faint
2121          * chance that someone could execute a setuid script down in a
2122          * non-accessible directory.  I don't know what to do about that.
2123          * But I don't think it's too important.  The manual lies when
2124          * it says access() is useful in setuid programs.
2125          */
2126         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2127             croak("Permission denied");
2128 #else
2129         /* If we can swap euid and uid, then we can determine access rights
2130          * with a simple stat of the file, and then compare device and
2131          * inode to make sure we did stat() on the same file we opened.
2132          * Then we just have to make sure he or she can execute it.
2133          */
2134         {
2135             struct stat tmpstatbuf;
2136
2137             if (
2138 #ifdef HAS_SETREUID
2139                 setreuid(euid,uid) < 0
2140 #else
2141 # if HAS_SETRESUID
2142                 setresuid(euid,uid,(Uid_t)-1) < 0
2143 # endif
2144 #endif
2145                 || getuid() != euid || geteuid() != uid)
2146                 croak("Can't swap uid and euid");       /* really paranoid */
2147             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2148                 croak("Permission denied");     /* testing full pathname here */
2149             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2150                 tmpstatbuf.st_ino != statbuf.st_ino) {
2151                 (void)PerlIO_close(rsfp);
2152                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2153                     PerlIO_printf(rsfp,
2154 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2155 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2156                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2157                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2158                         SvPVX(GvSV(curcop->cop_filegv)),
2159                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2160                     (void)PerlProc_pclose(rsfp);
2161                 }
2162                 croak("Permission denied\n");
2163             }
2164             if (
2165 #ifdef HAS_SETREUID
2166               setreuid(uid,euid) < 0
2167 #else
2168 # if defined(HAS_SETRESUID)
2169               setresuid(uid,euid,(Uid_t)-1) < 0
2170 # endif
2171 #endif
2172               || getuid() != uid || geteuid() != euid)
2173                 croak("Can't reswap uid and euid");
2174             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2175                 croak("Permission denied\n");
2176         }
2177 #endif /* HAS_SETREUID */
2178 #endif /* IAMSUID */
2179
2180         if (!S_ISREG(statbuf.st_mode))
2181             croak("Permission denied");
2182         if (statbuf.st_mode & S_IWOTH)
2183             croak("Setuid/gid script is writable by world");
2184         doswitches = FALSE;             /* -s is insecure in suid */
2185         curcop->cop_line++;
2186         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2187           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2188             croak("No #! line");
2189         s = SvPV(linestr,na)+2;
2190         if (*s == ' ') s++;
2191         while (!isSPACE(*s)) s++;
2192         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2193                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2194         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2195             croak("Not a perl script");
2196         while (*s == ' ' || *s == '\t') s++;
2197         /*
2198          * #! arg must be what we saw above.  They can invoke it by
2199          * mentioning suidperl explicitly, but they may not add any strange
2200          * arguments beyond what #! says if they do invoke suidperl that way.
2201          */
2202         len = strlen(validarg);
2203         if (strEQ(validarg," PHOOEY ") ||
2204             strnNE(s,validarg,len) || !isSPACE(s[len]))
2205             croak("Args must match #! line");
2206
2207 #ifndef IAMSUID
2208         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2209             euid == statbuf.st_uid)
2210             if (!do_undump)
2211                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2212 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2213 #endif /* IAMSUID */
2214
2215         if (euid) {     /* oops, we're not the setuid root perl */
2216             (void)PerlIO_close(rsfp);
2217 #ifndef IAMSUID
2218             /* try again */
2219             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2220 #endif
2221             croak("Can't do setuid\n");
2222         }
2223
2224         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2225 #ifdef HAS_SETEGID
2226             (void)setegid(statbuf.st_gid);
2227 #else
2228 #ifdef HAS_SETREGID
2229            (void)setregid((Gid_t)-1,statbuf.st_gid);
2230 #else
2231 #ifdef HAS_SETRESGID
2232            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2233 #else
2234             setgid(statbuf.st_gid);
2235 #endif
2236 #endif
2237 #endif
2238             if (getegid() != statbuf.st_gid)
2239                 croak("Can't do setegid!\n");
2240         }
2241         if (statbuf.st_mode & S_ISUID) {
2242             if (statbuf.st_uid != euid)
2243 #ifdef HAS_SETEUID
2244                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2245 #else
2246 #ifdef HAS_SETREUID
2247                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2248 #else
2249 #ifdef HAS_SETRESUID
2250                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2251 #else
2252                 setuid(statbuf.st_uid);
2253 #endif
2254 #endif
2255 #endif
2256             if (geteuid() != statbuf.st_uid)
2257                 croak("Can't do seteuid!\n");
2258         }
2259         else if (uid) {                 /* oops, mustn't run as root */
2260 #ifdef HAS_SETEUID
2261           (void)seteuid((Uid_t)uid);
2262 #else
2263 #ifdef HAS_SETREUID
2264           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2265 #else
2266 #ifdef HAS_SETRESUID
2267           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2268 #else
2269           setuid((Uid_t)uid);
2270 #endif
2271 #endif
2272 #endif
2273             if (geteuid() != uid)
2274                 croak("Can't do seteuid!\n");
2275         }
2276         init_ids();
2277         if (!cando(S_IXUSR,TRUE,&statbuf))
2278             croak("Permission denied\n");       /* they can't do this */
2279     }
2280 #ifdef IAMSUID
2281     else if (preprocess)
2282         croak("-P not allowed for setuid/setgid script\n");
2283     else if (fdscript >= 0)
2284         croak("fd script not allowed in suidperl\n");
2285     else
2286         croak("Script is not setuid/setgid in suidperl\n");
2287
2288     /* We absolutely must clear out any saved ids here, so we */
2289     /* exec the real perl, substituting fd script for scriptname. */
2290     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2291     PerlIO_rewind(rsfp);
2292     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2293     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2294     if (!origargv[which])
2295         croak("Permission denied");
2296     origargv[which] = savepv(form("/dev/fd/%d/%s",
2297                                   PerlIO_fileno(rsfp), origargv[which]));
2298 #if defined(HAS_FCNTL) && defined(F_SETFD)
2299     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2300 #endif
2301     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2302     croak("Can't do setuid\n");
2303 #endif /* IAMSUID */
2304 #else /* !DOSUID */
2305     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2306 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2307         dTHR;
2308         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2309         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2310             ||
2311             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2312            )
2313             if (!do_undump)
2314                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2315 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2316 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2317         /* not set-id, must be wrapped */
2318     }
2319 #endif /* DOSUID */
2320 }
2321
2322 static void
2323 find_beginning(void)
2324 {
2325     register char *s, *s2;
2326
2327     /* skip forward in input to the real script? */
2328
2329     forbid_setid("-x");
2330     while (doextract) {
2331         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2332             croak("No Perl script found in input\n");
2333         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2334             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2335             doextract = FALSE;
2336             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2337             s2 = s;
2338             while (*s == ' ' || *s == '\t') s++;
2339             if (*s++ == '-') {
2340                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2341                 if (strnEQ(s2-4,"perl",4))
2342                     /*SUPPRESS 530*/
2343                     while (s = moreswitches(s)) ;
2344             }
2345             if (cddir && PerlDir_chdir(cddir) < 0)
2346                 croak("Can't chdir to %s",cddir);
2347         }
2348     }
2349 }
2350
2351 static void
2352 init_ids(void)
2353 {
2354     uid = (int)getuid();
2355     euid = (int)geteuid();
2356     gid = (int)getgid();
2357     egid = (int)getegid();
2358 #ifdef VMS
2359     uid |= gid << 16;
2360     euid |= egid << 16;
2361 #endif
2362     tainting |= (uid && (euid != uid || egid != gid));
2363 }
2364
2365 static void
2366 forbid_setid(char *s)
2367 {
2368     if (euid != uid)
2369         croak("No %s allowed while running setuid", s);
2370     if (egid != gid)
2371         croak("No %s allowed while running setgid", s);
2372 }
2373
2374 static void
2375 init_debugger(void)
2376 {
2377     dTHR;
2378     curstash = debstash;
2379     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2380     AvREAL_off(dbargs);
2381     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2382     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2383     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2384     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2385     sv_setiv(DBsingle, 0);
2386     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2387     sv_setiv(DBtrace, 0);
2388     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2389     sv_setiv(DBsignal, 0);
2390     curstash = defstash;
2391 }
2392
2393 void
2394 init_stacks(ARGSproto)
2395 {
2396     curstack = newAV();
2397     mainstack = curstack;               /* remember in case we switch stacks */
2398     AvREAL_off(curstack);               /* not a real array */
2399     av_extend(curstack,127);
2400
2401     stack_base = AvARRAY(curstack);
2402     stack_sp = stack_base;
2403     stack_max = stack_base + 127;
2404
2405     cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2;      /* Use most of 8K. */
2406     New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2407     cxstack_ix  = -1;
2408
2409     New(50,tmps_stack,128,SV*);
2410     tmps_floor = -1;
2411     tmps_ix = -1;
2412     tmps_max = 128;
2413
2414     /*
2415      * The following stacks almost certainly should be per-interpreter,
2416      * but for now they're not.  XXX
2417      */
2418
2419     if (markstack) {
2420         markstack_ptr = markstack;
2421     } else {
2422         New(54,markstack,64,I32);
2423         markstack_ptr = markstack;
2424         markstack_max = markstack + 64;
2425     }
2426
2427     if (scopestack) {
2428         scopestack_ix = 0;
2429     } else {
2430         New(54,scopestack,32,I32);
2431         scopestack_ix = 0;
2432         scopestack_max = 32;
2433     }
2434
2435     if (savestack) {
2436         savestack_ix = 0;
2437     } else {
2438         New(54,savestack,128,ANY);
2439         savestack_ix = 0;
2440         savestack_max = 128;
2441     }
2442
2443     if (retstack) {
2444         retstack_ix = 0;
2445     } else {
2446         New(54,retstack,16,OP*);
2447         retstack_ix = 0;
2448         retstack_max = 16;
2449     }
2450 }
2451
2452 static void
2453 nuke_stacks(void)
2454 {
2455     dTHR;
2456     Safefree(cxstack);
2457     Safefree(tmps_stack);
2458     DEBUG( {
2459         Safefree(debname);
2460         Safefree(debdelim);
2461     } )
2462 }
2463
2464 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2465
2466 static void
2467 init_lexer(void)
2468 {
2469     tmpfp = rsfp;
2470     rsfp = Nullfp;
2471     lex_start(linestr);
2472     rsfp = tmpfp;
2473     subname = newSVpv("main",4);
2474 }
2475
2476 static void
2477 init_predump_symbols(void)
2478 {
2479     dTHR;
2480     GV *tmpgv;
2481     GV *othergv;
2482
2483     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2484     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2485     GvMULTI_on(stdingv);
2486     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2487     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2488     GvMULTI_on(tmpgv);
2489     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2490
2491     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2492     GvMULTI_on(tmpgv);
2493     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2494     setdefout(tmpgv);
2495     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2496     GvMULTI_on(tmpgv);
2497     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2498
2499     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2500     GvMULTI_on(othergv);
2501     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2502     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2503     GvMULTI_on(tmpgv);
2504     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2505
2506     statname = NEWSV(66,0);             /* last filename we did stat on */
2507
2508     if (!osname)
2509         osname = savepv(OSNAME);
2510 }
2511
2512 static void
2513 init_postdump_symbols(register int argc, register char **argv, register char **env)
2514 {
2515     dTHR;
2516     char *s;
2517     SV *sv;
2518     GV* tmpgv;
2519
2520     argc--,argv++;      /* skip name of script */
2521     if (doswitches) {
2522         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2523             if (!argv[0][1])
2524                 break;
2525             if (argv[0][1] == '-') {
2526                 argc--,argv++;
2527                 break;
2528             }
2529             if (s = strchr(argv[0], '=')) {
2530                 *s++ = '\0';
2531                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2532             }
2533             else
2534                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2535         }
2536     }
2537     toptarget = NEWSV(0,0);
2538     sv_upgrade(toptarget, SVt_PVFM);
2539     sv_setpvn(toptarget, "", 0);
2540     bodytarget = NEWSV(0,0);
2541     sv_upgrade(bodytarget, SVt_PVFM);
2542     sv_setpvn(bodytarget, "", 0);
2543     formtarget = bodytarget;
2544
2545     TAINT;
2546     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2547         sv_setpv(GvSV(tmpgv),origfilename);
2548         magicname("0", "0", 1);
2549     }
2550     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2551         sv_setpv(GvSV(tmpgv),origargv[0]);
2552     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2553         GvMULTI_on(argvgv);
2554         (void)gv_AVadd(argvgv);
2555         av_clear(GvAVn(argvgv));
2556         for (; argc > 0; argc--,argv++) {
2557             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2558         }
2559     }
2560     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2561         HV *hv;
2562         GvMULTI_on(envgv);
2563         hv = GvHVn(envgv);
2564         hv_magic(hv, envgv, 'E');
2565 #ifndef VMS  /* VMS doesn't have environ array */
2566         /* Note that if the supplied env parameter is actually a copy
2567            of the global environ then it may now point to free'd memory
2568            if the environment has been modified since. To avoid this
2569            problem we treat env==NULL as meaning 'use the default'
2570         */
2571         if (!env)
2572             env = environ;
2573         if (env != environ)
2574             environ[0] = Nullch;
2575         for (; *env; env++) {
2576             if (!(s = strchr(*env,'=')))
2577                 continue;
2578             *s++ = '\0';
2579 #if defined(WIN32) || defined(MSDOS)
2580             (void)strupr(*env);
2581 #endif
2582             sv = newSVpv(s--,0);
2583             (void)hv_store(hv, *env, s - *env, sv, 0);
2584             *s = '=';
2585 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2586             /* Sins of the RTL. See note in my_setenv(). */
2587             (void)PerlEnv_putenv(savepv(*env));
2588 #endif
2589         }
2590 #endif
2591 #ifdef DYNAMIC_ENV_FETCH
2592         HvNAME(hv) = savepv(ENV_HV_NAME);
2593 #endif
2594     }
2595     TAINT_NOT;
2596     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2597         sv_setiv(GvSV(tmpgv), (IV)getpid());
2598 }
2599
2600 static void
2601 init_perllib(void)
2602 {
2603     char *s;
2604     if (!tainting) {
2605 #ifndef VMS
2606         s = PerlEnv_getenv("PERL5LIB");
2607         if (s)
2608             incpush(s, TRUE);
2609         else
2610             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2611 #else /* VMS */
2612         /* Treat PERL5?LIB as a possible search list logical name -- the
2613          * "natural" VMS idiom for a Unix path string.  We allow each
2614          * element to be a set of |-separated directories for compatibility.
2615          */
2616         char buf[256];
2617         int idx = 0;
2618         if (my_trnlnm("PERL5LIB",buf,0))
2619             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2620         else
2621             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2622 #endif /* VMS */
2623     }
2624
2625 /* Use the ~-expanded versions of APPLLIB (undocumented),
2626     ARCHLIB PRIVLIB SITEARCH and SITELIB
2627 */
2628 #ifdef APPLLIB_EXP
2629     incpush(APPLLIB_EXP, FALSE);
2630 #endif
2631
2632 #ifdef ARCHLIB_EXP
2633     incpush(ARCHLIB_EXP, FALSE);
2634 #endif
2635 #ifndef PRIVLIB_EXP
2636 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2637 #endif
2638     incpush(PRIVLIB_EXP, FALSE);
2639
2640 #ifdef SITEARCH_EXP
2641     incpush(SITEARCH_EXP, FALSE);
2642 #endif
2643 #ifdef SITELIB_EXP
2644     incpush(SITELIB_EXP, FALSE);
2645 #endif
2646     if (!tainting)
2647         incpush(".", FALSE);
2648 }
2649
2650 #if defined(DOSISH)
2651 #    define PERLLIB_SEP ';'
2652 #else
2653 #  if defined(VMS)
2654 #    define PERLLIB_SEP '|'
2655 #  else
2656 #    define PERLLIB_SEP ':'
2657 #  endif
2658 #endif
2659 #ifndef PERLLIB_MANGLE
2660 #  define PERLLIB_MANGLE(s,n) (s)
2661 #endif
2662
2663 static void
2664 incpush(char *p, int addsubdirs)
2665 {
2666     SV *subdir = Nullsv;
2667     static char *archpat_auto;
2668
2669     if (!p)
2670         return;
2671
2672     if (addsubdirs) {
2673         subdir = NEWSV(55,0);
2674         if (!archpat_auto) {
2675             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2676                           + sizeof("//auto"));
2677             New(55, archpat_auto, len, char);
2678             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2679 #ifdef VMS
2680         for (len = sizeof(ARCHNAME) + 2;
2681              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2682                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2683 #endif
2684         }
2685     }
2686
2687     /* Break at all separators */
2688     while (p && *p) {
2689         SV *libdir = NEWSV(55,0);
2690         char *s;
2691
2692         /* skip any consecutive separators */
2693         while ( *p == PERLLIB_SEP ) {
2694             /* Uncomment the next line for PATH semantics */
2695             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2696             p++;
2697         }
2698
2699         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2700             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2701                       (STRLEN)(s - p));
2702             p = s + 1;
2703         }
2704         else {
2705             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2706             p = Nullch; /* break out */
2707         }
2708
2709         /*
2710          * BEFORE pushing libdir onto @INC we may first push version- and
2711          * archname-specific sub-directories.
2712          */
2713         if (addsubdirs) {
2714             struct stat tmpstatbuf;
2715 #ifdef VMS
2716             char *unix;
2717             STRLEN len;
2718
2719             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2720                 len = strlen(unix);
2721                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2722                 sv_usepvn(libdir,unix,len);
2723             }
2724             else
2725                 PerlIO_printf(PerlIO_stderr(),
2726                               "Failed to unixify @INC element \"%s\"\n",
2727                               SvPV(libdir,na));
2728 #endif
2729             /* .../archname/version if -d .../archname/version/auto */
2730             sv_setsv(subdir, libdir);
2731             sv_catpv(subdir, archpat_auto);
2732             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2733                   S_ISDIR(tmpstatbuf.st_mode))
2734                 av_push(GvAVn(incgv),
2735                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2736
2737             /* .../archname if -d .../archname/auto */
2738             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2739                       strlen(patchlevel) + 1, "", 0);
2740             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2741                   S_ISDIR(tmpstatbuf.st_mode))
2742                 av_push(GvAVn(incgv),
2743                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2744         }
2745
2746         /* finally push this lib directory on the end of @INC */
2747         av_push(GvAVn(incgv), libdir);
2748     }
2749
2750     SvREFCNT_dec(subdir);
2751 }
2752
2753 #ifdef USE_THREADS
2754 static struct perl_thread *
2755 init_main_thread()
2756 {
2757     struct perl_thread *thr;
2758     XPV *xpv;
2759
2760     Newz(53, thr, 1, struct perl_thread);
2761     curcop = &compiling;
2762     thr->cvcache = newHV();
2763     thr->threadsv = newAV();
2764     /* thr->threadsvp is set when find_threadsv is called */
2765     thr->specific = newAV();
2766     thr->errhv = newHV();
2767     thr->flags = THRf_R_JOINABLE;
2768     MUTEX_INIT(&thr->mutex);
2769     /* Handcraft thrsv similarly to mess_sv */
2770     New(53, thrsv, 1, SV);
2771     Newz(53, xpv, 1, XPV);
2772     SvFLAGS(thrsv) = SVt_PV;
2773     SvANY(thrsv) = (void*)xpv;
2774     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2775     SvPVX(thrsv) = (char*)thr;
2776     SvCUR_set(thrsv, sizeof(thr));
2777     SvLEN_set(thrsv, sizeof(thr));
2778     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2779     thr->oursv = thrsv;
2780     curcop = &compiling;
2781     chopset = " \n-";
2782
2783     MUTEX_LOCK(&threads_mutex);
2784     nthreads++;
2785     thr->tid = 0;
2786     thr->next = thr;
2787     thr->prev = thr;
2788     MUTEX_UNLOCK(&threads_mutex);
2789
2790 #ifdef HAVE_THREAD_INTERN
2791     init_thread_intern(thr);
2792 #endif
2793
2794 #ifdef SET_THREAD_SELF
2795     SET_THREAD_SELF(thr);
2796 #else
2797     thr->self = pthread_self();
2798 #endif /* SET_THREAD_SELF */
2799     SET_THR(thr);
2800
2801     /*
2802      * These must come after the SET_THR because sv_setpvn does
2803      * SvTAINT and the taint fields require dTHR.
2804      */
2805     toptarget = NEWSV(0,0);
2806     sv_upgrade(toptarget, SVt_PVFM);
2807     sv_setpvn(toptarget, "", 0);
2808     bodytarget = NEWSV(0,0);
2809     sv_upgrade(bodytarget, SVt_PVFM);
2810     sv_setpvn(bodytarget, "", 0);
2811     formtarget = bodytarget;
2812     thr->errsv = newSVpv("", 0);
2813     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2814     return thr;
2815 }
2816 #endif /* USE_THREADS */
2817
2818 void
2819 call_list(I32 oldscope, AV *list)
2820 {
2821     dTHR;
2822     line_t oldline = curcop->cop_line;
2823     STRLEN len;
2824     dJMPENV;
2825     int ret;
2826
2827     while (AvFILL(list) >= 0) {
2828         CV *cv = (CV*)av_shift(list);
2829
2830         SAVEFREESV(cv);
2831
2832         JMPENV_PUSH(ret);
2833         switch (ret) {
2834         case 0: {
2835                 SV* atsv = ERRSV;
2836                 PUSHMARK(stack_sp);
2837                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2838                 (void)SvPV(atsv, len);
2839                 if (len) {
2840                     JMPENV_POP;
2841                     curcop = &compiling;
2842                     curcop->cop_line = oldline;
2843                     if (list == beginav)
2844                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2845                     else
2846                         sv_catpv(atsv, "END failed--cleanup aborted");
2847                     while (scopestack_ix > oldscope)
2848                         LEAVE;
2849                     croak("%s", SvPVX(atsv));
2850                 }
2851             }
2852             break;
2853         case 1:
2854             STATUS_ALL_FAILURE;
2855             /* FALL THROUGH */
2856         case 2:
2857             /* my_exit() was called */
2858             while (scopestack_ix > oldscope)
2859                 LEAVE;
2860             FREETMPS;
2861             curstash = defstash;
2862             if (endav)
2863                 call_list(oldscope, endav);
2864             JMPENV_POP;
2865             curcop = &compiling;
2866             curcop->cop_line = oldline;
2867             if (statusvalue) {
2868                 if (list == beginav)
2869                     croak("BEGIN failed--compilation aborted");
2870                 else
2871                     croak("END failed--cleanup aborted");
2872             }
2873             my_exit_jump();
2874             /* NOTREACHED */
2875         case 3:
2876             if (!restartop) {
2877                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2878                 FREETMPS;
2879                 break;
2880             }
2881             JMPENV_POP;
2882             curcop = &compiling;
2883             curcop->cop_line = oldline;
2884             JMPENV_JUMP(3);
2885         }
2886         JMPENV_POP;
2887     }
2888 }
2889
2890 void
2891 my_exit(U32 status)
2892 {
2893     dTHR;
2894
2895 #ifdef USE_THREADS
2896     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2897                           thr, (unsigned long) status));
2898 #endif /* USE_THREADS */
2899     switch (status) {
2900     case 0:
2901         STATUS_ALL_SUCCESS;
2902         break;
2903     case 1:
2904         STATUS_ALL_FAILURE;
2905         break;
2906     default:
2907         STATUS_NATIVE_SET(status);
2908         break;
2909     }
2910     my_exit_jump();
2911 }
2912
2913 void
2914 my_failure_exit(void)
2915 {
2916 #ifdef VMS
2917     if (vaxc$errno & 1) {
2918         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2919             STATUS_NATIVE_SET(44);
2920     }
2921     else {
2922         if (!vaxc$errno && errno)       /* unlikely */
2923             STATUS_NATIVE_SET(44);
2924         else
2925             STATUS_NATIVE_SET(vaxc$errno);
2926     }
2927 #else
2928     if (errno & 255)
2929         STATUS_POSIX_SET(errno);
2930     else if (STATUS_POSIX == 0)
2931         STATUS_POSIX_SET(255);
2932 #endif
2933     my_exit_jump();
2934 }
2935
2936 static void
2937 my_exit_jump(void)
2938 {
2939     dTHR;
2940     register PERL_CONTEXT *cx;
2941     I32 gimme;
2942     SV **newsp;
2943
2944     if (e_tmpname) {
2945         if (e_fp) {
2946             PerlIO_close(e_fp);
2947             e_fp = Nullfp;
2948         }
2949         (void)UNLINK(e_tmpname);
2950         Safefree(e_tmpname);
2951         e_tmpname = Nullch;
2952     }
2953
2954     if (cxstack_ix >= 0) {
2955         if (cxstack_ix > 0)
2956             dounwind(0);
2957         POPBLOCK(cx,curpm);
2958         LEAVE;
2959     }
2960
2961     JMPENV_JUMP(2);
2962 }
2963
2964
2965