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     errgv = Nullgv;
 476     argvgv = Nullgv;
 477     argvoutgv = Nullgv;
 478     stdingv = Nullgv;
 479     last_in_gv = Nullgv;
 480
 481     /* reset so print() ends up where we expect */
 482     setdefout(Nullgv);
 483
 484     /* Prepare to destruct main symbol table.  */
 485
 486     hv = defstash;
 487     defstash = 0;
 488     SvREFCNT_dec(hv);
 489
 490     FREETMPS;
 491     if (destruct_level >= 2) {
 492         if (scopestack_ix != 0)
 493             warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 494                  (long)scopestack_ix);
 495         if (savestack_ix != 0)
 496             warn("Unbalanced saves: %ld more saves than restores\n",
 497                  (long)savestack_ix);
 498         if (tmps_floor != -1)
 499             warn("Unbalanced tmps: %ld more allocs than frees\n",
 500                  (long)tmps_floor + 1);
 501         if (cxstack_ix != -1)
 502             warn("Unbalanced context: %ld more PUSHes than POPs\n",
 503                  (long)cxstack_ix + 1);
 504     }
 505
 506     /* Now absolutely destruct everything, somehow or other, loops or no. */
 507     last_sv_count = 0;
 508     SvFLAGS(strtab) |= SVTYPEMASK;              /* don't clean out strtab now */
 509     while (sv_count != 0 && sv_count != last_sv_count) {
 510         last_sv_count = sv_count;
 511         sv_clean_all();
 512     }
 513     SvFLAGS(strtab) &= ~SVTYPEMASK;
 514     SvFLAGS(strtab) |= SVt_PVHV;
 515
 516     /* Destruct the global string table. */
 517     {
 518         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 519          * so that sv_free() won't fail on them.
 520          */
 521         I32 riter;
 522         I32 max;
 523         HE *hent;
 524         HE **array;
 525
 526         riter = 0;
 527         max = HvMAX(strtab);
 528         array = HvARRAY(strtab);
 529         hent = array[0];
 530         for (;;) {
 531             if (hent) {
 532                 warn("Unbalanced string table refcount: (%d) for \"%s\"",
 533                      HeVAL(hent) - Nullsv, HeKEY(hent));
 534                 HeVAL(hent) = Nullsv;
 535                 hent = HeNEXT(hent);
 536             }
 537             if (!hent) {
 538                 if (++riter > max)
 539                     break;
 540                 hent = array[riter];
 541             }
 542         }
 543     }
 544     SvREFCNT_dec(strtab);
 545
 546     if (sv_count != 0)
 547         warn("Scalars leaked: %ld\n", (long)sv_count);
 548
 549     sv_free_arenas();
 550
 551     /* No SVs have survived, need to clean out */
 552     linestr = NULL;
 553     pidstatus = Nullhv;
 554     if (origfilename)
 555         Safefree(origfilename);
 556     nuke_stacks();
 557     hints = 0;          /* Reset hints. Should hints be per-interpreter ? */
 558
 559     DEBUG_P(debprofdump());
 560 #ifdef USE_THREADS
 561     MUTEX_DESTROY(&sv_mutex);
 562     MUTEX_DESTROY(&malloc_mutex);
 563     MUTEX_DESTROY(&eval_mutex);
 564     COND_DESTROY(&eval_cond);
 565
 566     /* As the penultimate thing, free the non-arena SV for thrsv */
 567     Safefree(SvPVX(thrsv));
 568     Safefree(SvANY(thrsv));
 569     Safefree(thrsv);
 570     thrsv = Nullsv;
 571 #endif /* USE_THREADS */
 572
 573     /* As the absolutely last thing, free the non-arena SV for mess() */
 574
 575     if (mess_sv) {
 576         /* we know that type >= SVt_PV */
 577         SvOOK_off(mess_sv);
 578         Safefree(SvPVX(mess_sv));
 579         Safefree(SvANY(mess_sv));
 580         Safefree(mess_sv);
 581         mess_sv = Nullsv;
 582     }
 583 }
 584
 585 void
 586 perl_free(PerlInterpreter *sv_interp)
 587 {
 588     if (!(curinterp = sv_interp))
 589         return;
 590     Safefree(sv_interp);
 591 }
 592
 593 int
 594 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
 595 {
 596     dTHR;
 597     register SV *sv;
 598     register char *s;
 599     char *scriptname = NULL;
 600     VOL bool dosearch = FALSE;
 601     char *validarg = "";
 602     I32 oldscope;
 603     AV* comppadlist;
 604     dJMPENV;
 605     int ret;
 606
 607 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 608 #ifdef IAMSUID
 609 #undef IAMSUID
 610     croak("suidperl is no longer needed since the kernel can now execute\n\
 611 setuid perl scripts securely.\n");
 612 #endif
 613 #endif
 614
 615     if (!(curinterp = sv_interp))
 616         return 255;
 617
 618 #if defined(NeXT) && defined(__DYNAMIC__)
 619     _dyld_lookup_and_bind
 620         ("__environ", (unsigned long *) &environ_pointer, NULL);
 621 #endif /* environ */
 622
 623     origargv = argv;
 624     origargc = argc;
 625 #ifndef VMS  /* VMS doesn't have environ array */
 626     origenviron = environ;
 627 #endif
 628     e_tmpname = Nullch;
 629
 630     if (do_undump) {
 631
 632         /* Come here if running an undumped a.out. */
 633
 634         origfilename = savepv(argv[0]);
 635         do_undump = FALSE;
 636         cxstack_ix = -1;                /* start label stack again */
 637         init_ids();
 638         init_postdump_symbols(argc,argv,env);
 639         return 0;
 640     }
 641
 642     if (main_root) {
 643         curpad = AvARRAY(comppad);
 644         op_free(main_root);
 645         main_root = Nullop;
 646     }
 647     main_start = Nullop;
 648     SvREFCNT_dec(main_cv);
 649     main_cv = Nullcv;
 650
 651     time(&basetime);
 652     oldscope = scopestack_ix;
 653
 654     JMPENV_PUSH(ret);
 655     switch (ret) {
 656     case 1:
 657         STATUS_ALL_FAILURE;
 658         /* FALL THROUGH */
 659     case 2:
 660         /* my_exit() was called */
 661         while (scopestack_ix > oldscope)
 662             LEAVE;
 663         FREETMPS;
 664         curstash = defstash;
 665         if (endav)
 666             call_list(oldscope, endav);
 667         JMPENV_POP;
 668         return STATUS_NATIVE_EXPORT;
 669     case 3:
 670         JMPENV_POP;
 671         PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
 672         return 1;
 673     }
 674
 675     sv_setpvn(linestr,"",0);
 676     sv = newSVpv("",0);         /* first used for -I flags */
 677     SAVEFREESV(sv);
 678     init_main_stash();
 679
 680     for (argc--,argv++; argc > 0; argc--,argv++) {
 681         if (argv[0][0] != '-' || !argv[0][1])
 682             break;
 683 #ifdef DOSUID
 684     if (*validarg)
 685         validarg = " PHOOEY ";
 686     else
 687         validarg = argv[0];
 688 #endif
 689         s = argv[0]+1;
 690       reswitch:
 691         switch (*s) {
 692         case '0':
 693         case 'F':
 694         case 'a':
 695         case 'c':
 696         case 'd':
 697         case 'D':
 698         case 'h':
 699         case 'i':
 700         case 'l':
 701         case 'M':
 702         case 'm':
 703         case 'n':
 704         case 'p':
 705         case 's':
 706         case 'u':
 707         case 'U':
 708         case 'v':
 709         case 'w':
 710             if (s = moreswitches(s))
 711                 goto reswitch;
 712             break;
 713
 714         case 'T':
 715             tainting = TRUE;
 716             s++;
 717             goto reswitch;
 718
 719         case 'e':
 720             if (euid != uid || egid != gid)
 721                 croak("No -e allowed in setuid scripts");
 722             if (!e_fp) {
 723                 e_tmpname = savepv(TMPPATH);
 724                 (void)mktemp(e_tmpname);
 725                 if (!*e_tmpname)
 726                     croak("Can't mktemp()");
 727                 e_fp = PerlIO_open(e_tmpname,"w");
 728                 if (!e_fp)
 729                     croak("Cannot open temporary file");
 730             }
 731             if (*++s)
 732                 PerlIO_puts(e_fp,s);
 733             else if (argv[1]) {
 734                 PerlIO_puts(e_fp,argv[1]);
 735                 argc--,argv++;
 736             }
 737             else
 738                 croak("No code specified for -e");
 739             (void)PerlIO_putc(e_fp,'\n');
 740             break;
 741         case 'I':       /* -I handled both here and in moreswitches() */
 742             forbid_setid("-I");
 743             if (!*++s && (s=argv[1]) != Nullch) {
 744                 argc--,argv++;
 745             }
 746             while (s && isSPACE(*s))
 747                 ++s;
 748             if (s && *s) {
 749                 char *e, *p;
 750                 for (e = s; *e && !isSPACE(*e); e++) ;
 751                 p = savepvn(s, e-s);
 752                 incpush(p, TRUE);
 753                 sv_catpv(sv,"-I");
 754                 sv_catpv(sv,p);
 755                 sv_catpv(sv," ");
 756                 Safefree(p);
 757             }   /* XXX else croak? */
 758             break;
 759         case 'P':
 760             forbid_setid("-P");
 761             preprocess = TRUE;
 762             s++;
 763             goto reswitch;
 764         case 'S':
 765             forbid_setid("-S");
 766             dosearch = TRUE;
 767             s++;
 768             goto reswitch;
 769         case 'V':
 770             if (!preambleav)
 771                 preambleav = newAV();
 772             av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
 773             if (*++s != ':')  {
 774                 Sv = newSVpv("print myconfig();",0);
 775 #ifdef VMS
 776                 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
 777 #else
 778                 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 779 #endif
 780 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
 781                 sv_catpv(Sv,"\"  Compile-time options:");
 782 #  ifdef DEBUGGING
 783                 sv_catpv(Sv," DEBUGGING");
 784 #  endif
 785 #  ifdef NO_EMBED
 786                 sv_catpv(Sv," NO_EMBED");
 787 #  endif
 788 #  ifdef MULTIPLICITY
 789                 sv_catpv(Sv," MULTIPLICITY");
 790 #  endif
 791                 sv_catpv(Sv,"\\n\",");
 792 #endif
 793 #if defined(LOCAL_PATCH_COUNT)
 794                 if (LOCAL_PATCH_COUNT > 0) {
 795                     int i;
 796                     sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
 797                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
 798                         if (localpatches[i])
 799                             sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
 800                     }
 801                 }
 802 #endif
 803                 sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
 804 #ifdef __DATE__
 805 #  ifdef __TIME__
 806                 sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 807 #  else
 808                 sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
 809 #  endif
 810 #endif
 811                 sv_catpv(Sv, "; \
 812 $\"=\"\\n    \"; \
 813 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
 814 print \"  \\%ENV:\\n    @env\\n\" if @env; \
 815 print \"  \\@INC:\\n    @INC\\n\";");
 816             }
 817             else {
 818                 Sv = newSVpv("config_vars(qw(",0);
 819                 sv_catpv(Sv, ++s);
 820                 sv_catpv(Sv, "))");
 821                 s += strlen(s);
 822             }
 823             av_push(preambleav, Sv);
 824             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
 825             goto reswitch;
 826         case 'x':
 827             doextract = TRUE;
 828             s++;
 829             if (*s)
 830                 cddir = savepv(s);
 831             break;
 832         case 0:
 833             break;
 834         case '-':
 835             if (!*++s || isSPACE(*s)) {
 836                 argc--,argv++;
 837                 goto switch_end;
 838             }
 839             /* catch use of gnu style long options */
 840             if (strEQ(s, "version")) {
 841                 s = "v";
 842                 goto reswitch;
 843             }
 844             if (strEQ(s, "help")) {
 845                 s = "h";
 846                 goto reswitch;
 847             }
 848             s--;
 849             /* FALL THROUGH */
 850         default:
 851             croak("Unrecognized switch: -%s  (-h will show valid options)",s);
 852         }
 853     }
 854   switch_end:
 855
 856     if (!tainting && (s = getenv("PERL5OPT"))) {
 857         while (s && *s) {
 858             while (isSPACE(*s))
 859                 s++;
 860             if (*s == '-') {
 861                 s++;
 862                 if (isSPACE(*s))
 863                     continue;
 864             }
 865             if (!*s)
 866                 break;
 867             if (!strchr("DIMUdmw", *s))
 868                 croak("Illegal switch in PERL5OPT: -%c", *s);
 869             s = moreswitches(s);
 870         }
 871     }
 872
 873     if (!scriptname)
 874         scriptname = argv[0];
 875     if (e_fp) {
 876         if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
 877 #ifndef MULTIPLICITY
 878             warn("Did you forget to compile with -DMULTIPLICITY?");
 879 #endif
 880             croak("Can't write to temp file for -e: %s", Strerror(errno));
 881         }
 882         e_fp = Nullfp;
 883         argc++,argv--;
 884         scriptname = e_tmpname;
 885     }
 886     else if (scriptname == Nullch) {
 887 #ifdef MSDOS
 888         if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
 889             moreswitches("h");
 890 #endif
 891         scriptname = "-";
 892     }
 893
 894     init_perllib();
 895
 896     open_script(scriptname,dosearch,sv);
 897
 898     validate_suid(validarg, scriptname);
 899
 900     if (doextract)
 901         find_beginning();
 902
 903     main_cv = compcv = (CV*)NEWSV(1104,0);
 904     sv_upgrade((SV *)compcv, SVt_PVCV);
 905     CvUNIQUE_on(compcv);
 906
 907     comppad = newAV();
 908     av_push(comppad, Nullsv);
 909     curpad = AvARRAY(comppad);
 910     comppad_name = newAV();
 911     comppad_name_fill = 0;
 912     min_intro_pending = 0;
 913     padix = 0;
 914 #ifdef USE_THREADS
 915     av_store(comppad_name, 0, newSVpv("@_", 2));
 916     curpad[0] = (SV*)newAV();
 917     SvPADMY_on(curpad[0]);      /* XXX Needed? */
 918     CvOWNER(compcv) = 0;
 919     New(666, CvMUTEXP(compcv), 1, perl_mutex);
 920     MUTEX_INIT(CvMUTEXP(compcv));
 921 #endif /* USE_THREADS */
 922
 923     comppadlist = newAV();
 924     AvREAL_off(comppadlist);
 925     av_store(comppadlist, 0, (SV*)comppad_name);
 926     av_store(comppadlist, 1, (SV*)comppad);
 927     CvPADLIST(compcv) = comppadlist;
 928
 929     boot_core_UNIVERSAL();
 930     if (xsinit)
 931         (*xsinit)();    /* in case linked C routines want magical variables */
 932 #if defined(VMS) || defined(WIN32)
 933     init_os_extras();
 934 #endif
 935
 936 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
 937     DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
 938 #endif
 939
 940     init_predump_symbols();
 941     if (!do_undump)
 942         init_postdump_symbols(argc,argv,env);
 943
 944     init_lexer();
 945
 946     /* now parse the script */
 947
 948     error_count = 0;
 949     if (yyparse() || error_count) {
 950         if (minus_c)
 951             croak("%s had compilation errors.\n", origfilename);
 952         else {
 953             croak("Execution of %s aborted due to compilation errors.\n",
 954                 origfilename);
 955         }
 956     }
 957     curcop->cop_line = 0;
 958     curstash = defstash;
 959     preprocess = FALSE;
 960     if (e_tmpname) {
 961         (void)UNLINK(e_tmpname);
 962         Safefree(e_tmpname);
 963         e_tmpname = Nullch;
 964     }
 965
 966     /* now that script is parsed, we can modify record separator */
 967     SvREFCNT_dec(rs);
 968     rs = SvREFCNT_inc(nrs);
 969 #ifdef USE_THREADS
 970     sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs);
 971 #else
 972     sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
 973 #endif /* USE_THREADS */
 974     if (do_undump)
 975         my_unexec();
 976
 977     if (dowarn)
 978         gv_check(defstash);
 979
 980     LEAVE;
 981     FREETMPS;
 982
 983 #ifdef MYMALLOC
 984     if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
 985         dump_mstats("after compilation:");
 986 #endif
 987
 988     ENTER;
 989     restartop = 0;
 990     JMPENV_POP;
 991     return 0;
 992 }
 993
 994 int
 995 perl_run(PerlInterpreter *sv_interp)
 996 {
 997     dTHR;
 998     I32 oldscope;
 999     dJMPENV;
1000     int ret;
1001
1002     if (!(curinterp = sv_interp))
1003         return 255;
1004
1005     oldscope = scopestack_ix;
1006
1007     JMPENV_PUSH(ret);
1008     switch (ret) {
1009     case 1:
1010         cxstack_ix = -1;                /* start context stack again */
1011         break;
1012     case 2:
1013         /* my_exit() was called */
1014         while (scopestack_ix > oldscope)
1015             LEAVE;
1016         FREETMPS;
1017         curstash = defstash;
1018         if (endav)
1019             call_list(oldscope, endav);
1020 #ifdef MYMALLOC
1021         if (getenv("PERL_DEBUG_MSTATS"))
1022             dump_mstats("after execution:  ");
1023 #endif
1024         JMPENV_POP;
1025         return STATUS_NATIVE_EXPORT;
1026     case 3:
1027         if (!restartop) {
1028             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1029             FREETMPS;
1030             JMPENV_POP;
1031             return 1;
1032         }
1033         if (curstack != mainstack) {
1034             dSP;
1035             SWITCHSTACK(curstack, mainstack);
1036         }
1037         break;
1038     }
1039
1040     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1041                     sawampersand ? "Enabling" : "Omitting"));
1042
1043     if (!restartop) {
1044         DEBUG_x(dump_all());
1045         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1046 #ifdef USE_THREADS
1047         DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1048                               (unsigned long) thr));
1049 #endif /* USE_THREADS */
1050
1051         if (minus_c) {
1052             PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1053             my_exit(0);
1054         }
1055         if (PERLDB_SINGLE && DBsingle)
1056            sv_setiv(DBsingle, 1);
1057         if (initav)
1058             call_list(oldscope, initav);
1059     }
1060
1061     /* do it */
1062
1063     if (restartop) {
1064         op = restartop;
1065         restartop = 0;
1066         runops();
1067     }
1068     else if (main_start) {
1069         CvDEPTH(main_cv) = 1;
1070         op = main_start;
1071         runops();
1072     }
1073
1074     my_exit(0);
1075     /* NOTREACHED */
1076     return 0;
1077 }
1078
1079 SV*
1080 perl_get_sv(char *name, I32 create)
1081 {
1082     GV *gv;
1083 #ifdef USE_THREADS
1084     if (name[1] == '\0' && !isALPHA(name[0])) {
1085         PADOFFSET tmp = find_thread_magical(name);
1086         if (tmp != NOT_IN_PAD) {
1087             dTHR;
1088             return *av_fetch(thr->magicals, tmp, FALSE);
1089         }
1090     }
1091 #endif /* USE_THREADS */
1092     gv = gv_fetchpv(name, create, SVt_PV);
1093     if (gv)
1094         return GvSV(gv);
1095     return Nullsv;
1096 }
1097
1098 AV*
1099 perl_get_av(char *name, I32 create)
1100 {
1101     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1102     if (create)
1103         return GvAVn(gv);
1104     if (gv)
1105         return GvAV(gv);
1106     return Nullav;
1107 }
1108
1109 HV*
1110 perl_get_hv(char *name, I32 create)
1111 {
1112     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1113     if (create)
1114         return GvHVn(gv);
1115     if (gv)
1116         return GvHV(gv);
1117     return Nullhv;
1118 }
1119
1120 CV*
1121 perl_get_cv(char *name, I32 create)
1122 {
1123     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1124     if (create && !GvCVu(gv))
1125         return newSUB(start_subparse(FALSE, 0),
1126                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1127                       Nullop,
1128                       Nullop);
1129     if (gv)
1130         return GvCVu(gv);
1131     return Nullcv;
1132 }
1133
1134 /* Be sure to refetch the stack pointer after calling these routines. */
1135
1136 I32
1137 perl_call_argv(char *subname, I32 flags, register char **argv)
1138
1139                         /* See G_* flags in cop.h */
1140                         /* null terminated arg list */
1141 {
1142     dSP;
1143
1144     PUSHMARK(sp);
1145     if (argv) {
1146         while (*argv) {
1147             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1148             argv++;
1149         }
1150         PUTBACK;
1151     }
1152     return perl_call_pv(subname, flags);
1153 }
1154
1155 I32
1156 perl_call_pv(char *subname, I32 flags)
1157                         /* name of the subroutine */
1158                         /* See G_* flags in cop.h */
1159 {
1160     return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1161 }
1162
1163 I32
1164 perl_call_method(char *methname, I32 flags)
1165                         /* name of the subroutine */
1166                         /* See G_* flags in cop.h */
1167 {
1168     dSP;
1169     OP myop;
1170     if (!op)
1171         op = &myop;
1172     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1173     PUTBACK;
1174     pp_method(ARGS);
1175     return perl_call_sv(*stack_sp--, flags);
1176 }
1177
1178 /* May be called with any of a CV, a GV, or an SV containing the name. */
1179 I32
1180 perl_call_sv(SV *sv, I32 flags)
1181
1182                         /* See G_* flags in cop.h */
1183 {
1184     dTHR;
1185     LOGOP myop;         /* fake syntax tree node */
1186     SV** sp = stack_sp;
1187     I32 oldmark;
1188     I32 retval;
1189     I32 oldscope;
1190     static CV *DBcv;
1191     bool oldcatch = CATCH_GET;
1192     dJMPENV;
1193     int ret;
1194     OP* oldop = op;
1195
1196     if (flags & G_DISCARD) {
1197         ENTER;
1198         SAVETMPS;
1199     }
1200
1201     Zero(&myop, 1, LOGOP);
1202     myop.op_next = Nullop;
1203     if (!(flags & G_NOARGS))
1204         myop.op_flags |= OPf_STACKED;
1205     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1206                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1207                       OPf_WANT_SCALAR);
1208     SAVEOP();
1209     op = (OP*)&myop;
1210
1211     EXTEND(stack_sp, 1);
1212     *++stack_sp = sv;
1213     oldmark = TOPMARK;
1214     oldscope = scopestack_ix;
1215
1216     if (PERLDB_SUB && curstash != debstash
1217            /* Handle first BEGIN of -d. */
1218           && (DBcv || (DBcv = GvCV(DBsub)))
1219            /* Try harder, since this may have been a sighandler, thus
1220             * curstash may be meaningless. */
1221           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1222         op->op_private |= OPpENTERSUB_DB;
1223
1224     if (flags & G_EVAL) {
1225         cLOGOP->op_other = op;
1226         markstack_ptr--;
1227         /* we're trying to emulate pp_entertry() here */
1228         {
1229             register CONTEXT *cx;
1230             I32 gimme = GIMME_V;
1231
1232             ENTER;
1233             SAVETMPS;
1234
1235             push_return(op->op_next);
1236             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1237             PUSHEVAL(cx, 0, 0);
1238             eval_root = op;             /* Only needed so that goto works right. */
1239
1240             in_eval = 1;
1241             if (flags & G_KEEPERR)
1242                 in_eval |= 4;
1243             else
1244                 sv_setpv(ERRSV,"");
1245         }
1246         markstack_ptr++;
1247
1248         JMPENV_PUSH(ret);
1249         switch (ret) {
1250         case 0:
1251             break;
1252         case 1:
1253             STATUS_ALL_FAILURE;
1254             /* FALL THROUGH */
1255         case 2:
1256             /* my_exit() was called */
1257             curstash = defstash;
1258             FREETMPS;
1259             JMPENV_POP;
1260             if (statusvalue)
1261                 croak("Callback called exit");
1262             my_exit_jump();
1263             /* NOTREACHED */
1264         case 3:
1265             if (restartop) {
1266                 op = restartop;
1267                 restartop = 0;
1268                 break;
1269             }
1270             stack_sp = stack_base + oldmark;
1271             if (flags & G_ARRAY)
1272                 retval = 0;
1273             else {
1274                 retval = 1;
1275                 *++stack_sp = &sv_undef;
1276             }
1277             goto cleanup;
1278         }
1279     }
1280     else
1281         CATCH_SET(TRUE);
1282
1283     if (op == (OP*)&myop)
1284         op = pp_entersub(ARGS);
1285     if (op)
1286         runops();
1287     retval = stack_sp - (stack_base + oldmark);
1288     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1289         sv_setpv(ERRSV,"");
1290
1291   cleanup:
1292     if (flags & G_EVAL) {
1293         if (scopestack_ix > oldscope) {
1294             SV **newsp;
1295             PMOP *newpm;
1296             I32 gimme;
1297             register CONTEXT *cx;
1298             I32 optype;
1299
1300             POPBLOCK(cx,newpm);
1301             POPEVAL(cx);
1302             pop_return();
1303             curpm = newpm;
1304             LEAVE;
1305         }
1306         JMPENV_POP;
1307     }
1308     else
1309         CATCH_SET(oldcatch);
1310
1311     if (flags & G_DISCARD) {
1312         stack_sp = stack_base + oldmark;
1313         retval = 0;
1314         FREETMPS;
1315         LEAVE;
1316     }
1317     op = oldop;
1318     return retval;
1319 }
1320
1321 /* Eval a string. The G_EVAL flag is always assumed. */
1322
1323 I32
1324 perl_eval_sv(SV *sv, I32 flags)
1325
1326                         /* See G_* flags in cop.h */
1327 {
1328     dTHR;
1329     UNOP myop;          /* fake syntax tree node */
1330     SV** sp = stack_sp;
1331     I32 oldmark = sp - stack_base;
1332     I32 retval;
1333     I32 oldscope;
1334     dJMPENV;
1335     int ret;
1336     OP* oldop = op;
1337
1338     if (flags & G_DISCARD) {
1339         ENTER;
1340         SAVETMPS;
1341     }
1342
1343     SAVEOP();
1344     op = (OP*)&myop;
1345     Zero(op, 1, UNOP);
1346     EXTEND(stack_sp, 1);
1347     *++stack_sp = sv;
1348     oldscope = scopestack_ix;
1349
1350     if (!(flags & G_NOARGS))
1351         myop.op_flags = OPf_STACKED;
1352     myop.op_next = Nullop;
1353     myop.op_type = OP_ENTEREVAL;
1354     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1355                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1356                       OPf_WANT_SCALAR);
1357     if (flags & G_KEEPERR)
1358         myop.op_flags |= OPf_SPECIAL;
1359
1360     JMPENV_PUSH(ret);
1361     switch (ret) {
1362     case 0:
1363         break;
1364     case 1:
1365         STATUS_ALL_FAILURE;
1366         /* FALL THROUGH */
1367     case 2:
1368         /* my_exit() was called */
1369         curstash = defstash;
1370         FREETMPS;
1371         JMPENV_POP;
1372         if (statusvalue)
1373             croak("Callback called exit");
1374         my_exit_jump();
1375         /* NOTREACHED */
1376     case 3:
1377         if (restartop) {
1378             op = restartop;
1379             restartop = 0;
1380             break;
1381         }
1382         stack_sp = stack_base + oldmark;
1383         if (flags & G_ARRAY)
1384             retval = 0;
1385         else {
1386             retval = 1;
1387             *++stack_sp = &sv_undef;
1388         }
1389         goto cleanup;
1390     }
1391
1392     if (op == (OP*)&myop)
1393         op = pp_entereval(ARGS);
1394     if (op)
1395         runops();
1396     retval = stack_sp - (stack_base + oldmark);
1397     if (!(flags & G_KEEPERR))
1398         sv_setpv(ERRSV,"");
1399
1400   cleanup:
1401     JMPENV_POP;
1402     if (flags & G_DISCARD) {
1403         stack_sp = stack_base + oldmark;
1404         retval = 0;
1405         FREETMPS;
1406         LEAVE;
1407     }
1408     op = oldop;
1409     return retval;
1410 }
1411
1412 SV*
1413 perl_eval_pv(char *p, I32 croak_on_error)
1414 {
1415     dSP;
1416     SV* sv = newSVpv(p, 0);
1417
1418     PUSHMARK(sp);
1419     perl_eval_sv(sv, G_SCALAR);
1420     SvREFCNT_dec(sv);
1421
1422     SPAGAIN;
1423     sv = POPs;
1424     PUTBACK;
1425
1426     if (croak_on_error && SvTRUE(ERRSV))
1427         croak(SvPVx(ERRSV, na));
1428
1429     return sv;
1430 }
1431
1432 /* Require a module. */
1433
1434 void
1435 perl_require_pv(char *pv)
1436 {
1437     SV* sv = sv_newmortal();
1438     sv_setpv(sv, "require '");
1439     sv_catpv(sv, pv);
1440     sv_catpv(sv, "'");
1441     perl_eval_sv(sv, G_DISCARD);
1442 }
1443
1444 void
1445 magicname(char *sym, char *name, I32 namlen)
1446 {
1447     register GV *gv;
1448
1449     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1450         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1451 }
1452
1453 static void
1454 usage(char *name)               /* XXX move this out into a module ? */
1455
1456 {
1457     /* This message really ought to be max 23 lines.
1458      * Removed -h because the user already knows that opton. Others? */
1459
1460     static char *usage[] = {
1461 "-0[octal]       specify record separator (\\0, if no argument)",
1462 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1463 "-c              check syntax only (runs BEGIN and END blocks)",
1464 "-d[:debugger]   run scripts under debugger",
1465 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1466 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1467 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1468 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1469 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1470 "-l[octal]       enable line ending processing, specifies line terminator",
1471 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1472 "-n              assume 'while (<>) { ... }' loop around your script",
1473 "-p              assume loop like -n but print line also like sed",
1474 "-P              run script through C preprocessor before compilation",
1475 "-s              enable some switch parsing for switches after script name",
1476 "-S              look for the script using PATH environment variable",
1477 "-T              turn on tainting checks",
1478 "-u              dump core after parsing script",
1479 "-U              allow unsafe operations",
1480 "-v              print version number and patchlevel of perl",
1481 "-V[:variable]   print perl configuration information",
1482 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1483 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1484 "\n",
1485 NULL
1486 };
1487     char **p = usage;
1488
1489     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1490     while (*p)
1491         printf("\n  %s", *p++);
1492 }
1493
1494 /* This routine handles any switches that can be given during run */
1495
1496 char *
1497 moreswitches(char *s)
1498 {
1499     I32 numlen;
1500     U32 rschar;
1501
1502     switch (*s) {
1503     case '0':
1504     {
1505         dTHR;
1506         rschar = scan_oct(s, 4, &numlen);
1507         SvREFCNT_dec(nrs);
1508         if (rschar & ~((U8)~0))
1509             nrs = &sv_undef;
1510         else if (!rschar && numlen >= 2)
1511             nrs = newSVpv("", 0);
1512         else {
1513             char ch = rschar;
1514             nrs = newSVpv(&ch, 1);
1515         }
1516         return s + numlen;
1517     }
1518     case 'F':
1519         minus_F = TRUE;
1520         splitstr = savepv(s + 1);
1521         s += strlen(s);
1522         return s;
1523     case 'a':
1524         minus_a = TRUE;
1525         s++;
1526         return s;
1527     case 'c':
1528         minus_c = TRUE;
1529         s++;
1530         return s;
1531     case 'd':
1532         forbid_setid("-d");
1533         s++;
1534         if (*s == ':' || *s == '=')  {
1535             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1536             s += strlen(s);
1537         }
1538         if (!perldb) {
1539             perldb = PERLDB_ALL;
1540             init_debugger();
1541         }
1542         return s;
1543     case 'D':
1544 #ifdef DEBUGGING
1545         forbid_setid("-D");
1546         if (isALPHA(s[1])) {
1547             static char debopts[] = "psltocPmfrxuLHXD";
1548             char *d;
1549
1550             for (s++; *s && (d = strchr(debopts,*s)); s++)
1551                 debug |= 1 << (d - debopts);
1552         }
1553         else {
1554             debug = atoi(s+1);
1555             for (s++; isDIGIT(*s); s++) ;
1556         }
1557         debug |= 0x80000000;
1558 #else
1559         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1560         for (s++; isALNUM(*s); s++) ;
1561 #endif
1562         /*SUPPRESS 530*/
1563         return s;
1564     case 'h':
1565         usage(origargv[0]);
1566         exit(0);
1567     case 'i':
1568         if (inplace)
1569             Safefree(inplace);
1570         inplace = savepv(s+1);
1571         /*SUPPRESS 530*/
1572         for (s = inplace; *s && !isSPACE(*s); s++) ;
1573         if (*s)
1574             *s++ = '\0';
1575         return s;
1576     case 'I':   /* -I handled both here and in parse_perl() */
1577         forbid_setid("-I");
1578         ++s;
1579         while (*s && isSPACE(*s))
1580             ++s;
1581         if (*s) {
1582             char *e, *p;
1583             for (e = s; *e && !isSPACE(*e); e++) ;
1584             p = savepvn(s, e-s);
1585             incpush(p, TRUE);
1586             Safefree(p);
1587             s = e;
1588         }
1589         else
1590             croak("No space allowed after -I");
1591         return s;
1592     case 'l':
1593         minus_l = TRUE;
1594         s++;
1595         if (ors)
1596             Safefree(ors);
1597         if (isDIGIT(*s)) {
1598             ors = savepv("\n");
1599             orslen = 1;
1600             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1601             s += numlen;
1602         }
1603         else {
1604             dTHR;
1605             if (RsPARA(nrs)) {
1606                 ors = "\n\n";
1607                 orslen = 2;
1608             }
1609             else
1610                 ors = SvPV(nrs, orslen);
1611             ors = savepvn(ors, orslen);
1612         }
1613         return s;
1614     case 'M':
1615         forbid_setid("-M");     /* XXX ? */
1616         /* FALL THROUGH */
1617     case 'm':
1618         forbid_setid("-m");     /* XXX ? */
1619         if (*++s) {
1620             char *start;
1621             SV *sv;
1622             char *use = "use ";
1623             /* -M-foo == 'no foo'       */
1624             if (*s == '-') { use = "no "; ++s; }
1625             sv = newSVpv(use,0);
1626             start = s;
1627             /* We allow -M'Module qw(Foo Bar)'  */
1628             while(isALNUM(*s) || *s==':') ++s;
1629             if (*s != '=') {
1630                 sv_catpv(sv, start);
1631                 if (*(start-1) == 'm') {
1632                     if (*s != '\0')
1633                         croak("Can't use '%c' after -mname", *s);
1634                     sv_catpv( sv, " ()");
1635                 }
1636             } else {
1637                 sv_catpvn(sv, start, s-start);
1638                 sv_catpv(sv, " split(/,/,q{");
1639                 sv_catpv(sv, ++s);
1640                 sv_catpv(sv,    "})");
1641             }
1642             s += strlen(s);
1643             if (preambleav == NULL)
1644                 preambleav = newAV();
1645             av_push(preambleav, sv);
1646         }
1647         else
1648             croak("No space allowed after -%c", *(s-1));
1649         return s;
1650     case 'n':
1651         minus_n = TRUE;
1652         s++;
1653         return s;
1654     case 'p':
1655         minus_p = TRUE;
1656         s++;
1657         return s;
1658     case 's':
1659         forbid_setid("-s");
1660         doswitches = TRUE;
1661         s++;
1662         return s;
1663     case 'T':
1664         if (!tainting)
1665             croak("Too late for \"-T\" option");
1666         s++;
1667         return s;
1668     case 'u':
1669         do_undump = TRUE;
1670         s++;
1671         return s;
1672     case 'U':
1673         unsafe = TRUE;
1674         s++;
1675         return s;
1676     case 'v':
1677 #if defined(SUBVERSION) && SUBVERSION > 0
1678         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1679             PATCHLEVEL, SUBVERSION, ARCHNAME);
1680 #else
1681         printf("\nThis is perl, version %s built for %s",
1682                 patchlevel, ARCHNAME);
1683 #endif
1684 #if defined(LOCAL_PATCH_COUNT)
1685         if (LOCAL_PATCH_COUNT > 0)
1686             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1687                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1688 #endif
1689
1690         printf("\n\nCopyright 1987-1997, Larry Wall\n");
1691 #ifdef MSDOS
1692         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1693 #endif
1694 #ifdef DJGPP
1695         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1696 #endif
1697 #ifdef OS2
1698         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1699             "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1700 #endif
1701 #ifdef atarist
1702         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1703 #endif
1704         printf("\n\
1705 Perl may be copied only under the terms of either the Artistic License or the\n\
1706 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1707         exit(0);
1708     case 'w':
1709         dowarn = TRUE;
1710         s++;
1711         return s;
1712     case '*':
1713     case ' ':
1714         if (s[1] == '-')        /* Additional switches on #! line. */
1715             return s+2;
1716         break;
1717     case '-':
1718     case 0:
1719     case '\n':
1720     case '\t':
1721         break;
1722 #ifdef ALTERNATE_SHEBANG
1723     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1724         break;
1725 #endif
1726     case 'P':
1727         if (preprocess)
1728             return s+1;
1729         /* FALL THROUGH */
1730     default:
1731         croak("Can't emulate -%.1s on #! line",s);
1732     }
1733     return Nullch;
1734 }
1735
1736 /* compliments of Tom Christiansen */
1737
1738 /* unexec() can be found in the Gnu emacs distribution */
1739
1740 void
1741 my_unexec(void)
1742 {
1743 #ifdef UNEXEC
1744     SV*    prog;
1745     SV*    file;
1746     int    status;
1747     extern int etext;
1748
1749     prog = newSVpv(BIN_EXP);
1750     sv_catpv(prog, "/perl");
1751     file = newSVpv(origfilename);
1752     sv_catpv(file, ".perldump");
1753
1754     status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1755     if (status)
1756         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1757                       SvPVX(prog), SvPVX(file));
1758     exit(status);
1759 #else
1760 #  ifdef VMS
1761 #    include <lib$routines.h>
1762      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1763 #  else
1764     ABORT();            /* for use with undump */
1765 #  endif
1766 #endif
1767 }
1768
1769 static void
1770 init_main_stash(void)
1771 {
1772     dTHR;
1773     GV *gv;
1774
1775     /* Note that strtab is a rather special HV.  Assumptions are made
1776        about not iterating on it, and not adding tie magic to it.
1777        It is properly deallocated in perl_destruct() */
1778     strtab = newHV();
1779     HvSHAREKEYS_off(strtab);                    /* mandatory */
1780     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1781          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1782
1783     curstash = defstash = newHV();
1784     curstname = newSVpv("main",4);
1785     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1786     SvREFCNT_dec(GvHV(gv));
1787     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1788     SvREADONLY_on(gv);
1789     HvNAME(defstash) = savepv("main");
1790     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1791     GvMULTI_on(incgv);
1792     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1793     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1794     GvMULTI_on(errgv);
1795     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1796     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1797     sv_setpvn(ERRSV, "", 0);
1798     curstash = defstash;
1799     compiling.cop_stash = defstash;
1800     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1801     globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", 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 #endif
2848
2849 #ifdef SET_THREAD_SELF
2850     SET_THREAD_SELF(thr);
2851 #else
2852     thr->self = pthread_self();
2853 #endif /* SET_THREAD_SELF */
2854     SET_THR(thr);
2855
2856     /*
2857      * These must come after the SET_THR because sv_setpvn does
2858      * SvTAINT and the taint fields require dTHR.
2859      */
2860     toptarget = NEWSV(0,0);
2861     sv_upgrade(toptarget, SVt_PVFM);
2862     sv_setpvn(toptarget, "", 0);
2863     bodytarget = NEWSV(0,0);
2864     sv_upgrade(bodytarget, SVt_PVFM);
2865     sv_setpvn(bodytarget, "", 0);
2866     formtarget = bodytarget;
2867     thr->errsv = newSVpv("", 0);
2868     return thr;
2869 }
2870 #endif /* USE_THREADS */
2871
2872 void
2873 call_list(I32 oldscope, AV *list)
2874 {
2875     dTHR;
2876     line_t oldline = curcop->cop_line;
2877     STRLEN len;
2878     dJMPENV;
2879     int ret;
2880
2881     while (AvFILL(list) >= 0) {
2882         CV *cv = (CV*)av_shift(list);
2883
2884         SAVEFREESV(cv);
2885
2886         JMPENV_PUSH(ret);
2887         switch (ret) {
2888         case 0: {
2889                 SV* atsv = ERRSV;
2890                 PUSHMARK(stack_sp);
2891                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2892                 (void)SvPV(atsv, len);
2893                 if (len) {
2894                     JMPENV_POP;
2895                     curcop = &compiling;
2896                     curcop->cop_line = oldline;
2897                     if (list == beginav)
2898                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2899                     else
2900                         sv_catpv(atsv, "END failed--cleanup aborted");
2901                     while (scopestack_ix > oldscope)
2902                         LEAVE;
2903                     croak("%s", SvPVX(atsv));
2904                 }
2905             }
2906             break;
2907         case 1:
2908             STATUS_ALL_FAILURE;
2909             /* FALL THROUGH */
2910         case 2:
2911             /* my_exit() was called */
2912             while (scopestack_ix > oldscope)
2913                 LEAVE;
2914             FREETMPS;
2915             curstash = defstash;
2916             if (endav)
2917                 call_list(oldscope, endav);
2918             JMPENV_POP;
2919             curcop = &compiling;
2920             curcop->cop_line = oldline;
2921             if (statusvalue) {
2922                 if (list == beginav)
2923                     croak("BEGIN failed--compilation aborted");
2924                 else
2925                     croak("END failed--cleanup aborted");
2926             }
2927             my_exit_jump();
2928             /* NOTREACHED */
2929         case 3:
2930             if (!restartop) {
2931                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2932                 FREETMPS;
2933                 break;
2934             }
2935             JMPENV_POP;
2936             curcop = &compiling;
2937             curcop->cop_line = oldline;
2938             JMPENV_JUMP(3);
2939         }
2940         JMPENV_POP;
2941     }
2942 }
2943
2944 void
2945 my_exit(U32 status)
2946 {
2947     dTHR;
2948
2949 #ifdef USE_THREADS
2950     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2951                           thr, (unsigned long) status));
2952 #endif /* USE_THREADS */
2953     switch (status) {
2954     case 0:
2955         STATUS_ALL_SUCCESS;
2956         break;
2957     case 1:
2958         STATUS_ALL_FAILURE;
2959         break;
2960     default:
2961         STATUS_NATIVE_SET(status);
2962         break;
2963     }
2964     my_exit_jump();
2965 }
2966
2967 void
2968 my_failure_exit(void)
2969 {
2970 #ifdef VMS
2971     if (vaxc$errno & 1) {
2972         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2973             STATUS_NATIVE_SET(44);
2974     }
2975     else {
2976         if (!vaxc$errno && errno)       /* unlikely */
2977             STATUS_NATIVE_SET(44);
2978         else
2979             STATUS_NATIVE_SET(vaxc$errno);
2980     }
2981 #else
2982     if (errno & 255)
2983         STATUS_POSIX_SET(errno);
2984     else if (STATUS_POSIX == 0)
2985         STATUS_POSIX_SET(255);
2986 #endif
2987     my_exit_jump();
2988 }
2989
2990 static void
2991 my_exit_jump(void)
2992 {
2993     dTHR;
2994     register CONTEXT *cx;
2995     I32 gimme;
2996     SV **newsp;
2997
2998     if (e_tmpname) {
2999         if (e_fp) {
3000             PerlIO_close(e_fp);
3001             e_fp = Nullfp;
3002         }
3003         (void)UNLINK(e_tmpname);
3004         Safefree(e_tmpname);
3005         e_tmpname = Nullch;
3006     }
3007
3008     if (cxstack_ix >= 0) {
3009         if (cxstack_ix > 0)
3010             dounwind(0);
3011         POPBLOCK(cx,curpm);
3012         LEAVE;
3013     }
3014
3015     JMPENV_JUMP(2);
3016 }
3017
3018