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