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