perl.c

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