perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (c) 1987-1998 Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
  12  */
  13
  14 #include "EXTERN.h"
  15 #include "perl.h"
  16 #include "patchlevel.h"
  17
  18 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  19 #ifdef I_UNISTD
  20 #include <unistd.h>
  21 #endif
  22
  23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
  24 char *getenv _((char *)); /* Usually in <stdlib.h> */
  25 #endif
  26
  27 #ifdef I_FCNTL
  28 #include <fcntl.h>
  29 #endif
  30 #ifdef I_SYS_FILE
  31 #include <sys/file.h>
  32 #endif
  33
  34 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
  35
  36 #ifdef IAMSUID
  37 #ifndef DOSUID
  38 #define DOSUID
  39 #endif
  40 #endif
  41
  42 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  43 #ifdef DOSUID
  44 #undef DOSUID
  45 #endif
  46 #endif
  47
  48 #define I_REINIT \
  49   STMT_START {                  \
  50     chopset     = " \n-";       \
  51     copline     = NOLINE;       \
  52     curcop      = &compiling;   \
  53     curcopdb    = NULL;         \
  54     dbargs      = 0;            \
  55     dlmax       = 128;          \
  56     laststatval = -1;           \
  57     laststype   = OP_STAT;      \
  58     maxscream   = -1;           \
  59     maxsysfd    = MAXSYSFD;     \
  60     statname    = Nullsv;       \
  61     tmps_floor  = -1;           \
  62     tmps_ix     = -1;           \
  63     op_mask     = NULL;         \
  64     dlmax       = 128;          \
  65     laststatval = -1;           \
  66     laststype   = OP_STAT;      \
  67     mess_sv     = Nullsv;       \
  68     splitstr    = " ";          \
  69     generation  = 100;          \
  70     exitlist    = NULL;         \
  71     exitlistlen = 0;            \
  72     regindent   = 0;            \
  73     in_clean_objs = FALSE;      \
  74     in_clean_all= FALSE;        \
  75   } STMT_END
  76
  77 #ifdef PERL_OBJECT
  78 static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
  79 #else
  80 static void find_beginning _((void));
  81 static void forbid_setid _((char *));
  82 static void incpush _((char *, int));
  83 static void init_ids _((void));
  84 static void init_debugger _((void));
  85 static void init_lexer _((void));
  86 static void init_main_stash _((void));
  87 #ifdef USE_THREADS
  88 static struct perl_thread * init_main_thread _((void));
  89 #endif /* USE_THREADS */
  90 static void init_perllib _((void));
  91 static void init_postdump_symbols _((int, char **, char **));
  92 static void init_predump_symbols _((void));
  93 static void my_exit_jump _((void)) __attribute__((noreturn));
  94 static void nuke_stacks _((void));
  95 static void open_script _((char *, bool, SV *, int *fd));
  96 static void usage _((char *));
  97 static void validate_suid _((char *, char*, int));
  98 static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
  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 /* PERL_OBJECT */
 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 #ifdef EMULATE_ATOMIC_REFCOUNTS
 167         MUTEX_INIT(&svref_mutex);
 168 #endif /* EMULATE_ATOMIC_REFCOUNTS */
 169
 170         thr = init_main_thread();
 171 #endif /* USE_THREADS */
 172
 173         linestr = NEWSV(65,80);
 174         sv_upgrade(linestr,SVt_PVIV);
 175
 176         if (!SvREADONLY(&sv_undef)) {
 177             SvREADONLY_on(&sv_undef);
 178
 179             sv_setpv(&sv_no,No);
 180             SvNV(&sv_no);
 181             SvREADONLY_on(&sv_no);
 182
 183             sv_setpv(&sv_yes,Yes);
 184             SvNV(&sv_yes);
 185             SvREADONLY_on(&sv_yes);
 186         }
 187
 188         nrs = newSVpv("\n", 1);
 189         rs = SvREFCNT_inc(nrs);
 190
 191 #ifdef PERL_OBJECT
 192         /* TODO: */
 193         /* sighandlerp = sighandler; */
 194 #else
 195         sighandlerp = sighandler;
 196 #endif
 197         pidstatus = newHV();
 198
 199 #ifdef MSDOS
 200         /*
 201          * There is no way we can refer to them from Perl so close them to save
 202          * space.  The other alternative would be to provide STDAUX and STDPRN
 203          * filehandles.
 204          */
 205         (void)fclose(stdaux);
 206         (void)fclose(stdprn);
 207 #endif
 208     }
 209
 210     init_stacks(ARGS);
 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     modglobal = newHV();                /* pointers to per-interpreter module globals */
 246
 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     curcop = &compiling;
 369     main_start = Nullop;
 370     SvREFCNT_dec(main_cv);
 371     main_cv = Nullcv;
 372
 373     if (sv_objcount) {
 374         /*
 375          * Try to destruct global references.  We do this first so that the
 376          * destructors and destructees still exist.  Some sv's might remain.
 377          * Non-referenced objects are on their own.
 378          */
 379
 380         dirty = TRUE;
 381         sv_clean_objs();
 382     }
 383
 384     /* unhook hooks which will soon be, or use, destroyed data */
 385     SvREFCNT_dec(warnhook);
 386     warnhook = Nullsv;
 387     SvREFCNT_dec(diehook);
 388     diehook = Nullsv;
 389     SvREFCNT_dec(parsehook);
 390     parsehook = Nullsv;
 391
 392     /* call exit list functions */
 393     while (exitlistlen-- > 0)
 394         exitlist[exitlistlen].fn(PERL_OBJECT_THIS_ exitlist[exitlistlen].ptr);
 395
 396     Safefree(exitlist);
 397
 398     if (destruct_level == 0){
 399
 400         DEBUG_P(debprofdump());
 401
 402         /* The exit() function will do everything that needs doing. */
 403         return;
 404     }
 405
 406     /* loosen bonds of global variables */
 407
 408     if(rsfp) {
 409         (void)PerlIO_close(rsfp);
 410         rsfp = Nullfp;
 411     }
 412
 413     /* Filters for program text */
 414     SvREFCNT_dec(rsfp_filters);
 415     rsfp_filters = Nullav;
 416
 417     /* switches */
 418     preprocess   = FALSE;
 419     minus_n      = FALSE;
 420     minus_p      = FALSE;
 421     minus_l      = FALSE;
 422     minus_a      = FALSE;
 423     minus_F      = FALSE;
 424     doswitches   = FALSE;
 425     dowarn       = FALSE;
 426     doextract    = FALSE;
 427     sawampersand = FALSE;       /* must save all match strings */
 428     sawstudy     = FALSE;       /* do fbm_instr on all strings */
 429     sawvec       = FALSE;
 430     unsafe       = FALSE;
 431
 432     Safefree(inplace);
 433     inplace = Nullch;
 434
 435     if (e_script) {
 436         SvREFCNT_dec(e_script);
 437         e_script = Nullsv;
 438     }
 439
 440     /* magical thingies */
 441
 442     Safefree(ofs);      /* $, */
 443     ofs = Nullch;
 444
 445     Safefree(ors);      /* $\ */
 446     ors = Nullch;
 447
 448     SvREFCNT_dec(nrs);  /* $\ helper */
 449     nrs = Nullsv;
 450
 451     multiline = 0;      /* $* */
 452
 453     SvREFCNT_dec(statname);
 454     statname = Nullsv;
 455     statgv = Nullgv;
 456
 457     /* defgv, aka *_ should be taken care of elsewhere */
 458
 459     /* clean up after study() */
 460     SvREFCNT_dec(lastscream);
 461     lastscream = Nullsv;
 462     Safefree(screamfirst);
 463     screamfirst = 0;
 464     Safefree(screamnext);
 465     screamnext  = 0;
 466
 467     /* startup and shutdown function lists */
 468     SvREFCNT_dec(beginav);
 469     SvREFCNT_dec(endav);
 470     SvREFCNT_dec(initav);
 471     beginav = Nullav;
 472     endav = Nullav;
 473     initav = 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     replgv = Nullgv;
 485
 486     /* reset so print() ends up where we expect */
 487     setdefout(Nullgv);
 488
 489     /* Prepare to destruct main symbol table.  */
 490
 491     hv = defstash;
 492     defstash = 0;
 493     SvREFCNT_dec(hv);
 494
 495     FREETMPS;
 496     if (destruct_level >= 2) {
 497         if (scopestack_ix != 0)
 498             warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 499                  (long)scopestack_ix);
 500         if (savestack_ix != 0)
 501             warn("Unbalanced saves: %ld more saves than restores\n",
 502                  (long)savestack_ix);
 503         if (tmps_floor != -1)
 504             warn("Unbalanced tmps: %ld more allocs than frees\n",
 505                  (long)tmps_floor + 1);
 506         if (cxstack_ix != -1)
 507             warn("Unbalanced context: %ld more PUSHes than POPs\n",
 508                  (long)cxstack_ix + 1);
 509     }
 510
 511     /* Now absolutely destruct everything, somehow or other, loops or no. */
 512     last_sv_count = 0;
 513     SvFLAGS(strtab) |= SVTYPEMASK;              /* don't clean out strtab now */
 514     while (sv_count != 0 && sv_count != last_sv_count) {
 515         last_sv_count = sv_count;
 516         sv_clean_all();
 517     }
 518     SvFLAGS(strtab) &= ~SVTYPEMASK;
 519     SvFLAGS(strtab) |= SVt_PVHV;
 520
 521     /* Destruct the global string table. */
 522     {
 523         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 524          * so that sv_free() won't fail on them.
 525          */
 526         I32 riter;
 527         I32 max;
 528         HE *hent;
 529         HE **array;
 530
 531         riter = 0;
 532         max = HvMAX(strtab);
 533         array = HvARRAY(strtab);
 534         hent = array[0];
 535         for (;;) {
 536             if (hent) {
 537                 warn("Unbalanced string table refcount: (%d) for \"%s\"",
 538                      HeVAL(hent) - Nullsv, HeKEY(hent));
 539                 HeVAL(hent) = Nullsv;
 540                 hent = HeNEXT(hent);
 541             }
 542             if (!hent) {
 543                 if (++riter > max)
 544                     break;
 545                 hent = array[riter];
 546             }
 547         }
 548     }
 549     SvREFCNT_dec(strtab);
 550
 551     if (sv_count != 0)
 552         warn("Scalars leaked: %ld\n", (long)sv_count);
 553
 554     sv_free_arenas();
 555
 556     /* No SVs have survived, need to clean out */
 557     linestr = NULL;
 558     pidstatus = Nullhv;
 559     Safefree(origfilename);
 560     Safefree(archpat_auto);
 561     Safefree(reg_start_tmp);
 562     Safefree(HeKEY_hek(&hv_fetch_ent_mh));
 563     Safefree(op_mask);
 564     nuke_stacks();
 565     hints = 0;          /* Reset hints. Should hints be per-interpreter ? */
 566
 567     DEBUG_P(debprofdump());
 568 #ifdef USE_THREADS
 569     MUTEX_DESTROY(&sv_mutex);
 570     MUTEX_DESTROY(&eval_mutex);
 571     COND_DESTROY(&eval_cond);
 572
 573     /* As the penultimate thing, free the non-arena SV for thrsv */
 574     Safefree(SvPVX(thrsv));
 575     Safefree(SvANY(thrsv));
 576     Safefree(thrsv);
 577     thrsv = Nullsv;
 578 #endif /* USE_THREADS */
 579
 580     /* As the absolutely last thing, free the non-arena SV for mess() */
 581
 582     if (mess_sv) {
 583         /* we know that type >= SVt_PV */
 584         SvOOK_off(mess_sv);
 585         Safefree(SvPVX(mess_sv));
 586         Safefree(SvANY(mess_sv));
 587         Safefree(mess_sv);
 588         mess_sv = Nullsv;
 589     }
 590 }
 591
 592 void
 593 #ifdef PERL_OBJECT
 594 CPerlObj::perl_free(void)
 595 #else
 596 perl_free(PerlInterpreter *sv_interp)
 597 #endif
 598 {
 599 #ifdef PERL_OBJECT
 600         Safefree(this);
 601 #else
 602     if (!(curinterp = sv_interp))
 603         return;
 604     Safefree(sv_interp);
 605 #endif
 606 }
 607
 608 void
 609 #ifdef PERL_OBJECT
 610 CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
 611 #else
 612 perl_atexit(void (*fn) (void *), void *ptr)
 613 #endif
 614 {
 615     Renew(exitlist, exitlistlen+1, PerlExitListEntry);
 616     exitlist[exitlistlen].fn = fn;
 617     exitlist[exitlistlen].ptr = ptr;
 618     ++exitlistlen;
 619 }
 620
 621 int
 622 #ifdef PERL_OBJECT
 623 CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
 624 #else
 625 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
 626 #endif
 627 {
 628     dTHR;
 629     register SV *sv;
 630     register char *s;
 631     char *scriptname = NULL;
 632     VOL bool dosearch = FALSE;
 633     char *validarg = "";
 634     I32 oldscope;
 635     AV* comppadlist;
 636     dJMPENV;
 637     int ret;
 638     int fdscript = -1;
 639
 640 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 641 #ifdef IAMSUID
 642 #undef IAMSUID
 643     croak("suidperl is no longer needed since the kernel can now execute\n\
 644 setuid perl scripts securely.\n");
 645 #endif
 646 #endif
 647
 648 #ifndef PERL_OBJECT
 649     if (!(curinterp = sv_interp))
 650         return 255;
 651 #endif
 652
 653 #if defined(NeXT) && defined(__DYNAMIC__)
 654     _dyld_lookup_and_bind
 655         ("__environ", (unsigned long *) &environ_pointer, NULL);
 656 #endif /* environ */
 657
 658     origargv = argv;
 659     origargc = argc;
 660 #ifndef VMS  /* VMS doesn't have environ array */
 661     origenviron = environ;
 662 #endif
 663
 664     if (do_undump) {
 665
 666         /* Come here if running an undumped a.out. */
 667
 668         origfilename = savepv(argv[0]);
 669         do_undump = FALSE;
 670         cxstack_ix = -1;                /* start label stack again */
 671         init_ids();
 672         init_postdump_symbols(argc,argv,env);
 673         return 0;
 674     }
 675
 676     if (main_root) {
 677         curpad = AvARRAY(comppad);
 678         op_free(main_root);
 679         main_root = Nullop;
 680     }
 681     main_start = Nullop;
 682     SvREFCNT_dec(main_cv);
 683     main_cv = Nullcv;
 684
 685     time(&basetime);
 686     oldscope = scopestack_ix;
 687
 688     JMPENV_PUSH(ret);
 689     switch (ret) {
 690     case 1:
 691         STATUS_ALL_FAILURE;
 692         /* FALL THROUGH */
 693     case 2:
 694         /* my_exit() was called */
 695         while (scopestack_ix > oldscope)
 696             LEAVE;
 697         FREETMPS;
 698         curstash = defstash;
 699         if (endav)
 700             call_list(oldscope, endav);
 701         JMPENV_POP;
 702         return STATUS_NATIVE_EXPORT;
 703     case 3:
 704         JMPENV_POP;
 705         PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
 706         return 1;
 707     }
 708
 709     sv_setpvn(linestr,"",0);
 710     sv = newSVpv("",0);         /* first used for -I flags */
 711     SAVEFREESV(sv);
 712     init_main_stash();
 713
 714     for (argc--,argv++; argc > 0; argc--,argv++) {
 715         if (argv[0][0] != '-' || !argv[0][1])
 716             break;
 717 #ifdef DOSUID
 718     if (*validarg)
 719         validarg = " PHOOEY ";
 720     else
 721         validarg = argv[0];
 722 #endif
 723         s = argv[0]+1;
 724       reswitch:
 725         switch (*s) {
 726         case ' ':
 727         case '0':
 728         case 'F':
 729         case 'a':
 730         case 'c':
 731         case 'd':
 732         case 'D':
 733         case 'h':
 734         case 'i':
 735         case 'l':
 736         case 'M':
 737         case 'm':
 738         case 'n':
 739         case 'p':
 740         case 's':
 741         case 'u':
 742         case 'U':
 743         case 'v':
 744         case 'w':
 745             if (s = moreswitches(s))
 746                 goto reswitch;
 747             break;
 748
 749         case 'T':
 750             tainting = TRUE;
 751             s++;
 752             goto reswitch;
 753
 754         case 'e':
 755             if (euid != uid || egid != gid)
 756                 croak("No -e allowed in setuid scripts");
 757             if (!e_script) {
 758                 e_script = newSVpv("",0);
 759                 filter_add(read_e_script, NULL);
 760             }
 761             if (*++s)
 762                 sv_catpv(e_script, s);
 763             else if (argv[1]) {
 764                 sv_catpv(e_script, argv[1]);
 765                 argc--,argv++;
 766             }
 767             else
 768                 croak("No code specified for -e");
 769             sv_catpv(e_script, "\n");
 770             break;
 771
 772         case 'I':       /* -I handled both here and in moreswitches() */
 773             forbid_setid("-I");
 774             if (!*++s && (s=argv[1]) != Nullch) {
 775                 argc--,argv++;
 776             }
 777             while (s && isSPACE(*s))
 778                 ++s;
 779             if (s && *s) {
 780                 char *e, *p;
 781                 for (e = s; *e && !isSPACE(*e); e++) ;
 782                 p = savepvn(s, e-s);
 783                 incpush(p, TRUE);
 784                 sv_catpv(sv,"-I");
 785                 sv_catpv(sv,p);
 786                 sv_catpv(sv," ");
 787                 Safefree(p);
 788             }   /* XXX else croak? */
 789             break;
 790         case 'P':
 791             forbid_setid("-P");
 792             preprocess = TRUE;
 793             s++;
 794             goto reswitch;
 795         case 'S':
 796             forbid_setid("-S");
 797             dosearch = TRUE;
 798             s++;
 799             goto reswitch;
 800         case 'V':
 801             if (!preambleav)
 802                 preambleav = newAV();
 803             av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
 804             if (*++s != ':')  {
 805                 Sv = newSVpv("print myconfig();",0);
 806 #ifdef VMS
 807                 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
 808 #else
 809                 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 810 #endif
 811 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
 812                 sv_catpv(Sv,"\"  Compile-time options:");
 813 #  ifdef DEBUGGING
 814                 sv_catpv(Sv," DEBUGGING");
 815 #  endif
 816 #  ifdef NO_EMBED
 817                 sv_catpv(Sv," NO_EMBED");
 818 #  endif
 819 #  ifdef MULTIPLICITY
 820                 sv_catpv(Sv," MULTIPLICITY");
 821 #  endif
 822                 sv_catpv(Sv,"\\n\",");
 823 #endif
 824 #if defined(LOCAL_PATCH_COUNT)
 825                 if (LOCAL_PATCH_COUNT > 0) {
 826                     int i;
 827                     sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
 828                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
 829                         if (localpatches[i])
 830                             sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
 831                     }
 832                 }
 833 #endif
 834                 sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
 835 #ifdef __DATE__
 836 #  ifdef __TIME__
 837                 sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 838 #  else
 839                 sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
 840 #  endif
 841 #endif
 842                 sv_catpv(Sv, "; \
 843 $\"=\"\\n    \"; \
 844 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
 845 print \"  \\%ENV:\\n    @env\\n\" if @env; \
 846 print \"  \\@INC:\\n    @INC\\n\";");
 847             }
 848             else {
 849                 Sv = newSVpv("config_vars(qw(",0);
 850                 sv_catpv(Sv, ++s);
 851                 sv_catpv(Sv, "))");
 852                 s += strlen(s);
 853             }
 854             av_push(preambleav, Sv);
 855             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
 856             goto reswitch;
 857         case 'x':
 858             doextract = TRUE;
 859             s++;
 860             if (*s)
 861                 cddir = savepv(s);
 862             break;
 863         case 0:
 864             break;
 865         case '-':
 866             if (!*++s || isSPACE(*s)) {
 867                 argc--,argv++;
 868                 goto switch_end;
 869             }
 870             /* catch use of gnu style long options */
 871             if (strEQ(s, "version")) {
 872                 s = "v";
 873                 goto reswitch;
 874             }
 875             if (strEQ(s, "help")) {
 876                 s = "h";
 877                 goto reswitch;
 878             }
 879             s--;
 880             /* FALL THROUGH */
 881         default:
 882             croak("Unrecognized switch: -%s  (-h will show valid options)",s);
 883         }
 884     }
 885   switch_end:
 886
 887     if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
 888         while (s && *s) {
 889             while (isSPACE(*s))
 890                 s++;
 891             if (*s == '-') {
 892                 s++;
 893                 if (isSPACE(*s))
 894                     continue;
 895             }
 896             if (!*s)
 897                 break;
 898             if (!strchr("DIMUdmw", *s))
 899                 croak("Illegal switch in PERL5OPT: -%c", *s);
 900             s = moreswitches(s);
 901         }
 902     }
 903
 904     if (!scriptname)
 905         scriptname = argv[0];
 906     if (e_script) {
 907         argc++,argv--;
 908         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
 909     }
 910     else if (scriptname == Nullch) {
 911 #ifdef MSDOS
 912         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
 913             moreswitches("h");
 914 #endif
 915         scriptname = "-";
 916     }
 917
 918     init_perllib();
 919
 920     open_script(scriptname,dosearch,sv,&fdscript);
 921
 922     validate_suid(validarg, scriptname,fdscript);
 923
 924     if (doextract)
 925         find_beginning();
 926
 927     main_cv = compcv = (CV*)NEWSV(1104,0);
 928     sv_upgrade((SV *)compcv, SVt_PVCV);
 929     CvUNIQUE_on(compcv);
 930
 931     comppad = newAV();
 932     av_push(comppad, Nullsv);
 933     curpad = AvARRAY(comppad);
 934     comppad_name = newAV();
 935     comppad_name_fill = 0;
 936     min_intro_pending = 0;
 937     padix = 0;
 938 #ifdef USE_THREADS
 939     av_store(comppad_name, 0, newSVpv("@_", 2));
 940     curpad[0] = (SV*)newAV();
 941     SvPADMY_on(curpad[0]);      /* XXX Needed? */
 942     CvOWNER(compcv) = 0;
 943     New(666, CvMUTEXP(compcv), 1, perl_mutex);
 944     MUTEX_INIT(CvMUTEXP(compcv));
 945 #endif /* USE_THREADS */
 946
 947     comppadlist = newAV();
 948     AvREAL_off(comppadlist);
 949     av_store(comppadlist, 0, (SV*)comppad_name);
 950     av_store(comppadlist, 1, (SV*)comppad);
 951     CvPADLIST(compcv) = comppadlist;
 952
 953     boot_core_UNIVERSAL();
 954
 955     if (xsinit)
 956         (*xsinit)(PERL_OBJECT_THIS);    /* in case linked C routines want magical variables */
 957 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
 958     init_os_extras();
 959 #endif
 960
 961     init_predump_symbols();
 962     /* init_postdump_symbols not currently designed to be called */
 963     /* more than once (ENV isn't cleared first, for example)     */
 964     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
 965     if (!do_undump)
 966         init_postdump_symbols(argc,argv,env);
 967
 968     init_lexer();
 969
 970     /* now parse the script */
 971
 972     SETERRNO(0,SS$_NORMAL);
 973     error_count = 0;
 974     if (yyparse() || error_count) {
 975         if (minus_c)
 976             croak("%s had compilation errors.\n", origfilename);
 977         else {
 978             croak("Execution of %s aborted due to compilation errors.\n",
 979                 origfilename);
 980         }
 981     }
 982     curcop->cop_line = 0;
 983     curstash = defstash;
 984     preprocess = FALSE;
 985     if (e_script) {
 986         SvREFCNT_dec(e_script);
 987         e_script = Nullsv;
 988     }
 989
 990     /* now that script is parsed, we can modify record separator */
 991     SvREFCNT_dec(rs);
 992     rs = SvREFCNT_inc(nrs);
 993     sv_setsv(perl_get_sv("/", TRUE), rs);
 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     dSP;
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         POPSTACK_TO(mainstack);
1060         break;
1061     }
1062
1063     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1064                     sawampersand ? "Enabling" : "Omitting"));
1065
1066     if (!restartop) {
1067         DEBUG_x(dump_all());
1068         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1069 #ifdef USE_THREADS
1070         DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1071                               (unsigned long) thr));
1072 #endif /* USE_THREADS */
1073
1074         if (minus_c) {
1075             PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1076             my_exit(0);
1077         }
1078         if (PERLDB_SINGLE && DBsingle)
1079            sv_setiv(DBsingle, 1);
1080         if (initav)
1081             call_list(oldscope, initav);
1082     }
1083
1084     /* do it */
1085
1086     if (restartop) {
1087         op = restartop;
1088         restartop = 0;
1089         CALLRUNOPS();
1090     }
1091     else if (main_start) {
1092         CvDEPTH(main_cv) = 1;
1093         op = main_start;
1094         CALLRUNOPS();
1095     }
1096
1097     my_exit(0);
1098     /* NOTREACHED */
1099     return 0;
1100 }
1101
1102 SV*
1103 perl_get_sv(char *name, I32 create)
1104 {
1105     GV *gv;
1106 #ifdef USE_THREADS
1107     if (name[1] == '\0' && !isALPHA(name[0])) {
1108         PADOFFSET tmp = find_threadsv(name);
1109         if (tmp != NOT_IN_PAD) {
1110             dTHR;
1111             return THREADSV(tmp);
1112         }
1113     }
1114 #endif /* USE_THREADS */
1115     gv = gv_fetchpv(name, create, SVt_PV);
1116     if (gv)
1117         return GvSV(gv);
1118     return Nullsv;
1119 }
1120
1121 AV*
1122 perl_get_av(char *name, I32 create)
1123 {
1124     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1125     if (create)
1126         return GvAVn(gv);
1127     if (gv)
1128         return GvAV(gv);
1129     return Nullav;
1130 }
1131
1132 HV*
1133 perl_get_hv(char *name, I32 create)
1134 {
1135     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1136     if (create)
1137         return GvHVn(gv);
1138     if (gv)
1139         return GvHV(gv);
1140     return Nullhv;
1141 }
1142
1143 CV*
1144 perl_get_cv(char *name, I32 create)
1145 {
1146     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1147     if (create && !GvCVu(gv))
1148         return newSUB(start_subparse(FALSE, 0),
1149                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1150                       Nullop,
1151                       Nullop);
1152     if (gv)
1153         return GvCVu(gv);
1154     return Nullcv;
1155 }
1156
1157 /* Be sure to refetch the stack pointer after calling these routines. */
1158
1159 I32
1160 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1161
1162                         /* See G_* flags in cop.h */
1163                         /* null terminated arg list */
1164 {
1165     dSP;
1166
1167     PUSHMARK(SP);
1168     if (argv) {
1169         while (*argv) {
1170             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1171             argv++;
1172         }
1173         PUTBACK;
1174     }
1175     return perl_call_pv(sub_name, flags);
1176 }
1177
1178 I32
1179 perl_call_pv(char *sub_name, I32 flags)
1180                         /* name of the subroutine */
1181                         /* See G_* flags in cop.h */
1182 {
1183     return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1184 }
1185
1186 I32
1187 perl_call_method(char *methname, I32 flags)
1188                         /* name of the subroutine */
1189                         /* See G_* flags in cop.h */
1190 {
1191     dSP;
1192     OP myop;
1193     if (!op)
1194         op = &myop;
1195     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1196     PUTBACK;
1197     pp_method(ARGS);
1198         if(op == &myop)
1199                 op = Nullop;
1200     return perl_call_sv(*stack_sp--, flags);
1201 }
1202
1203 /* May be called with any of a CV, a GV, or an SV containing the name. */
1204 I32
1205 perl_call_sv(SV *sv, I32 flags)
1206
1207                         /* See G_* flags in cop.h */
1208 {
1209     dSP;
1210     LOGOP myop;         /* fake syntax tree node */
1211     I32 oldmark;
1212     I32 retval;
1213     I32 oldscope;
1214     bool oldcatch = CATCH_GET;
1215     dJMPENV;
1216     int ret;
1217     OP* oldop = op;
1218
1219     if (flags & G_DISCARD) {
1220         ENTER;
1221         SAVETMPS;
1222     }
1223
1224     Zero(&myop, 1, LOGOP);
1225     myop.op_next = Nullop;
1226     if (!(flags & G_NOARGS))
1227         myop.op_flags |= OPf_STACKED;
1228     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1229                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1230                       OPf_WANT_SCALAR);
1231     SAVEOP();
1232     op = (OP*)&myop;
1233
1234     EXTEND(stack_sp, 1);
1235     *++stack_sp = sv;
1236     oldmark = TOPMARK;
1237     oldscope = scopestack_ix;
1238
1239     if (PERLDB_SUB && curstash != debstash
1240            /* Handle first BEGIN of -d. */
1241           && (DBcv || (DBcv = GvCV(DBsub)))
1242            /* Try harder, since this may have been a sighandler, thus
1243             * curstash may be meaningless. */
1244           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)
1245           && !(flags & G_NODEBUG))
1246         op->op_private |= OPpENTERSUB_DB;
1247
1248     if (flags & G_EVAL) {
1249         cLOGOP->op_other = op;
1250         markstack_ptr--;
1251         /* we're trying to emulate pp_entertry() here */
1252         {
1253             register PERL_CONTEXT *cx;
1254             I32 gimme = GIMME_V;
1255
1256             ENTER;
1257             SAVETMPS;
1258
1259             push_return(op->op_next);
1260             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1261             PUSHEVAL(cx, 0, 0);
1262             eval_root = op;             /* Only needed so that goto works right. */
1263
1264             in_eval = 1;
1265             if (flags & G_KEEPERR)
1266                 in_eval |= 4;
1267             else
1268                 sv_setpv(ERRSV,"");
1269         }
1270         markstack_ptr++;
1271
1272         JMPENV_PUSH(ret);
1273         switch (ret) {
1274         case 0:
1275             break;
1276         case 1:
1277             STATUS_ALL_FAILURE;
1278             /* FALL THROUGH */
1279         case 2:
1280             /* my_exit() was called */
1281             curstash = defstash;
1282             FREETMPS;
1283             JMPENV_POP;
1284             if (statusvalue)
1285                 croak("Callback called exit");
1286             my_exit_jump();
1287             /* NOTREACHED */
1288         case 3:
1289             if (restartop) {
1290                 op = restartop;
1291                 restartop = 0;
1292                 break;
1293             }
1294             stack_sp = stack_base + oldmark;
1295             if (flags & G_ARRAY)
1296                 retval = 0;
1297             else {
1298                 retval = 1;
1299                 *++stack_sp = &sv_undef;
1300             }
1301             goto cleanup;
1302         }
1303     }
1304     else
1305         CATCH_SET(TRUE);
1306
1307     if (op == (OP*)&myop)
1308         op = pp_entersub(ARGS);
1309     if (op)
1310         CALLRUNOPS();
1311     retval = stack_sp - (stack_base + oldmark);
1312     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1313         sv_setpv(ERRSV,"");
1314
1315   cleanup:
1316     if (flags & G_EVAL) {
1317         if (scopestack_ix > oldscope) {
1318             SV **newsp;
1319             PMOP *newpm;
1320             I32 gimme;
1321             register PERL_CONTEXT *cx;
1322             I32 optype;
1323
1324             POPBLOCK(cx,newpm);
1325             POPEVAL(cx);
1326             pop_return();
1327             curpm = newpm;
1328             LEAVE;
1329         }
1330         JMPENV_POP;
1331     }
1332     else
1333         CATCH_SET(oldcatch);
1334
1335     if (flags & G_DISCARD) {
1336         stack_sp = stack_base + oldmark;
1337         retval = 0;
1338         FREETMPS;
1339         LEAVE;
1340     }
1341     op = oldop;
1342     return retval;
1343 }
1344
1345 /* Eval a string. The G_EVAL flag is always assumed. */
1346
1347 I32
1348 perl_eval_sv(SV *sv, I32 flags)
1349
1350                         /* See G_* flags in cop.h */
1351 {
1352     dSP;
1353     UNOP myop;          /* fake syntax tree node */
1354     I32 oldmark = SP - stack_base;
1355     I32 retval;
1356     I32 oldscope;
1357     dJMPENV;
1358     int ret;
1359     OP* oldop = op;
1360
1361     if (flags & G_DISCARD) {
1362         ENTER;
1363         SAVETMPS;
1364     }
1365
1366     SAVEOP();
1367     op = (OP*)&myop;
1368     Zero(op, 1, UNOP);
1369     EXTEND(stack_sp, 1);
1370     *++stack_sp = sv;
1371     oldscope = scopestack_ix;
1372
1373     if (!(flags & G_NOARGS))
1374         myop.op_flags = OPf_STACKED;
1375     myop.op_next = Nullop;
1376     myop.op_type = OP_ENTEREVAL;
1377     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1378                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1379                       OPf_WANT_SCALAR);
1380     if (flags & G_KEEPERR)
1381         myop.op_flags |= OPf_SPECIAL;
1382
1383     JMPENV_PUSH(ret);
1384     switch (ret) {
1385     case 0:
1386         break;
1387     case 1:
1388         STATUS_ALL_FAILURE;
1389         /* FALL THROUGH */
1390     case 2:
1391         /* my_exit() was called */
1392         curstash = defstash;
1393         FREETMPS;
1394         JMPENV_POP;
1395         if (statusvalue)
1396             croak("Callback called exit");
1397         my_exit_jump();
1398         /* NOTREACHED */
1399     case 3:
1400         if (restartop) {
1401             op = restartop;
1402             restartop = 0;
1403             break;
1404         }
1405         stack_sp = stack_base + oldmark;
1406         if (flags & G_ARRAY)
1407             retval = 0;
1408         else {
1409             retval = 1;
1410             *++stack_sp = &sv_undef;
1411         }
1412         goto cleanup;
1413     }
1414
1415     if (op == (OP*)&myop)
1416         op = pp_entereval(ARGS);
1417     if (op)
1418         CALLRUNOPS();
1419     retval = stack_sp - (stack_base + oldmark);
1420     if (!(flags & G_KEEPERR))
1421         sv_setpv(ERRSV,"");
1422
1423   cleanup:
1424     JMPENV_POP;
1425     if (flags & G_DISCARD) {
1426         stack_sp = stack_base + oldmark;
1427         retval = 0;
1428         FREETMPS;
1429         LEAVE;
1430     }
1431     op = oldop;
1432     return retval;
1433 }
1434
1435 SV*
1436 perl_eval_pv(char *p, I32 croak_on_error)
1437 {
1438     dSP;
1439     SV* sv = newSVpv(p, 0);
1440
1441     PUSHMARK(SP);
1442     perl_eval_sv(sv, G_SCALAR);
1443     SvREFCNT_dec(sv);
1444
1445     SPAGAIN;
1446     sv = POPs;
1447     PUTBACK;
1448
1449     if (croak_on_error && SvTRUE(ERRSV))
1450         croak(SvPVx(ERRSV, na));
1451
1452     return sv;
1453 }
1454
1455 /* Require a module. */
1456
1457 void
1458 perl_require_pv(char *pv)
1459 {
1460     SV* sv = sv_newmortal();
1461     sv_setpv(sv, "require '");
1462     sv_catpv(sv, pv);
1463     sv_catpv(sv, "'");
1464     perl_eval_sv(sv, G_DISCARD);
1465 }
1466
1467 void
1468 magicname(char *sym, char *name, I32 namlen)
1469 {
1470     register GV *gv;
1471
1472     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1473         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1474 }
1475
1476 STATIC void
1477 usage(char *name)               /* XXX move this out into a module ? */
1478
1479 {
1480     /* This message really ought to be max 23 lines.
1481      * Removed -h because the user already knows that opton. Others? */
1482
1483     static char *usage_msg[] = {
1484 "-0[octal]       specify record separator (\\0, if no argument)",
1485 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1486 "-c              check syntax only (runs BEGIN and END blocks)",
1487 "-d[:debugger]   run scripts under debugger",
1488 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1489 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1490 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1491 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1492 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1493 "-l[octal]       enable line ending processing, specifies line terminator",
1494 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1495 "-n              assume 'while (<>) { ... }' loop around your script",
1496 "-p              assume loop like -n but print line also like sed",
1497 "-P              run script through C preprocessor before compilation",
1498 "-s              enable some switch parsing for switches after script name",
1499 "-S              look for the script using PATH environment variable",
1500 "-T              turn on tainting checks",
1501 "-u              dump core after parsing script",
1502 "-U              allow unsafe operations",
1503 "-v              print version number, patchlevel plus VERY IMPORTANT perl info",
1504 "-V[:variable]   print perl configuration information",
1505 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1506 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1507 "\n",
1508 NULL
1509 };
1510     char **p = usage_msg;
1511
1512     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1513     while (*p)
1514         printf("\n  %s", *p++);
1515 }
1516
1517 /* This routine handles any switches that can be given during run */
1518
1519 char *
1520 moreswitches(char *s)
1521 {
1522     I32 numlen;
1523     U32 rschar;
1524
1525     switch (*s) {
1526     case '0':
1527     {
1528         dTHR;
1529         rschar = scan_oct(s, 4, &numlen);
1530         SvREFCNT_dec(nrs);
1531         if (rschar & ~((U8)~0))
1532             nrs = &sv_undef;
1533         else if (!rschar && numlen >= 2)
1534             nrs = newSVpv("", 0);
1535         else {
1536             char ch = rschar;
1537             nrs = newSVpv(&ch, 1);
1538         }
1539         return s + numlen;
1540     }
1541     case 'F':
1542         minus_F = TRUE;
1543         splitstr = savepv(s + 1);
1544         s += strlen(s);
1545         return s;
1546     case 'a':
1547         minus_a = TRUE;
1548         s++;
1549         return s;
1550     case 'c':
1551         minus_c = TRUE;
1552         s++;
1553         return s;
1554     case 'd':
1555         forbid_setid("-d");
1556         s++;
1557         if (*s == ':' || *s == '=')  {
1558             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1559             s += strlen(s);
1560         }
1561         if (!perldb) {
1562             perldb = PERLDB_ALL;
1563             init_debugger();
1564         }
1565         return s;
1566     case 'D':
1567 #ifdef DEBUGGING
1568         forbid_setid("-D");
1569         if (isALPHA(s[1])) {
1570             static char debopts[] = "psltocPmfrxuLHXD";
1571             char *d;
1572
1573             for (s++; *s && (d = strchr(debopts,*s)); s++)
1574                 debug |= 1 << (d - debopts);
1575         }
1576         else {
1577             debug = atoi(s+1);
1578             for (s++; isDIGIT(*s); s++) ;
1579         }
1580         debug |= 0x80000000;
1581 #else
1582         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1583         for (s++; isALNUM(*s); s++) ;
1584 #endif
1585         /*SUPPRESS 530*/
1586         return s;
1587     case 'h':
1588         usage(origargv[0]);
1589         PerlProc_exit(0);
1590     case 'i':
1591         if (inplace)
1592             Safefree(inplace);
1593         inplace = savepv(s+1);
1594         /*SUPPRESS 530*/
1595         for (s = inplace; *s && !isSPACE(*s); s++) ;
1596         if (*s) {
1597             *s++ = '\0';
1598             if (*s == '-')      /* Additional switches on #! line. */
1599                 s++;
1600         }
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-1998, 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-1998\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-1998, 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 Complete documentation for Perl, including FAQ lists, should be found on\n\
1735 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
1736 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1737         PerlProc_exit(0);
1738     case 'w':
1739         dowarn = TRUE;
1740         s++;
1741         return s;
1742     case '*':
1743     case ' ':
1744         if (s[1] == '-')        /* Additional switches on #! line. */
1745             return s+2;
1746         break;
1747     case '-':
1748     case 0:
1749 #ifdef WIN32
1750     case '\r':
1751 #endif
1752     case '\n':
1753     case '\t':
1754         break;
1755 #ifdef ALTERNATE_SHEBANG
1756     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1757         break;
1758 #endif
1759     case 'P':
1760         if (preprocess)
1761             return s+1;
1762         /* FALL THROUGH */
1763     default:
1764         croak("Can't emulate -%.1s on #! line",s);
1765     }
1766     return Nullch;
1767 }
1768
1769 /* compliments of Tom Christiansen */
1770
1771 /* unexec() can be found in the Gnu emacs distribution */
1772 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1773
1774 void
1775 my_unexec(void)
1776 {
1777 #ifdef UNEXEC
1778     SV*    prog;
1779     SV*    file;
1780     int    status = 1;
1781     extern int etext;
1782
1783     prog = newSVpv(BIN_EXP, 0);
1784     sv_catpv(prog, "/perl");
1785     file = newSVpv(origfilename, 0);
1786     sv_catpv(file, ".perldump");
1787
1788     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1789     /* unexec prints msg to stderr in case of failure */
1790     PerlProc_exit(status);
1791 #else
1792 #  ifdef VMS
1793 #    include <lib$routines.h>
1794      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1795 #  else
1796     ABORT();            /* for use with undump */
1797 #  endif
1798 #endif
1799 }
1800
1801 STATIC void
1802 init_main_stash(void)
1803 {
1804     dTHR;
1805     GV *gv;
1806
1807     /* Note that strtab is a rather special HV.  Assumptions are made
1808        about not iterating on it, and not adding tie magic to it.
1809        It is properly deallocated in perl_destruct() */
1810     strtab = newHV();
1811     HvSHAREKEYS_off(strtab);                    /* mandatory */
1812     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1813          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1814
1815     curstash = defstash = newHV();
1816     curstname = newSVpv("main",4);
1817     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1818     SvREFCNT_dec(GvHV(gv));
1819     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1820     SvREADONLY_on(gv);
1821     HvNAME(defstash) = savepv("main");
1822     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1823     GvMULTI_on(incgv);
1824     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1825     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1826     GvMULTI_on(errgv);
1827     replgv = gv_HVadd(gv_fetchpv("\022", TRUE, SVt_PV)); /* ^R */
1828     GvMULTI_on(replgv);
1829     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1830     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1831     sv_setpvn(ERRSV, "", 0);
1832     curstash = defstash;
1833     compiling.cop_stash = defstash;
1834     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1835     globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1836     /* We must init $/ before switches are processed. */
1837     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1838 }
1839
1840 STATIC void
1841 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
1842 {
1843     dTHR;
1844     register char *s;
1845
1846     scriptname = find_script(scriptname, dosearch, NULL, 0);
1847
1848     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1849         char *s = scriptname + 8;
1850         *fdscript = atoi(s);
1851         while (isDIGIT(*s))
1852             s++;
1853         if (*s)
1854             scriptname = s + 1;
1855     }
1856     else
1857         *fdscript = -1;
1858     origfilename = savepv(e_script ? "-e" : scriptname);
1859     curcop->cop_filegv = gv_fetchfile(origfilename);
1860     if (strEQ(origfilename,"-"))
1861         scriptname = "";
1862     if (*fdscript >= 0) {
1863         rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1864 #if defined(HAS_FCNTL) && defined(F_SETFD)
1865         if (rsfp)
1866             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1867 #endif
1868     }
1869     else if (preprocess) {
1870         char *cpp_cfg = CPPSTDIN;
1871         SV *cpp = NEWSV(0,0);
1872         SV *cmd = NEWSV(0,0);
1873
1874         if (strEQ(cpp_cfg, "cppstdin"))
1875             sv_catpvf(cpp, "%s/", BIN_EXP);
1876         sv_catpv(cpp, cpp_cfg);
1877
1878         sv_catpv(sv,"-I");
1879         sv_catpv(sv,PRIVLIB_EXP);
1880
1881 #ifdef MSDOS
1882         sv_setpvf(cmd, "\
1883 sed %s -e \"/^[^#]/b\" \
1884  -e \"/^#[      ]*include[      ]/b\" \
1885  -e \"/^#[      ]*define[       ]/b\" \
1886  -e \"/^#[      ]*if[   ]/b\" \
1887  -e \"/^#[      ]*ifdef[        ]/b\" \
1888  -e \"/^#[      ]*ifndef[       ]/b\" \
1889  -e \"/^#[      ]*else/b\" \
1890  -e \"/^#[      ]*elif[         ]/b\" \
1891  -e \"/^#[      ]*undef[        ]/b\" \
1892  -e \"/^#[      ]*endif/b\" \
1893  -e \"s/^#.*//\" \
1894  %s | %_ -C %_ %s",
1895           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1896 #else
1897         sv_setpvf(cmd, "\
1898 %s %s -e '/^[^#]/b' \
1899  -e '/^#[       ]*include[      ]/b' \
1900  -e '/^#[       ]*define[       ]/b' \
1901  -e '/^#[       ]*if[   ]/b' \
1902  -e '/^#[       ]*ifdef[        ]/b' \
1903  -e '/^#[       ]*ifndef[       ]/b' \
1904  -e '/^#[       ]*else/b' \
1905  -e '/^#[       ]*elif[         ]/b' \
1906  -e '/^#[       ]*undef[        ]/b' \
1907  -e '/^#[       ]*endif/b' \
1908  -e 's/^[       ]*#.*//' \
1909  %s | %_ -C %_ %s",
1910 #ifdef LOC_SED
1911           LOC_SED,
1912 #else
1913           "sed",
1914 #endif
1915           (doextract ? "-e '1,/^#/d\n'" : ""),
1916 #endif
1917           scriptname, cpp, sv, CPPMINUS);
1918         doextract = FALSE;
1919 #ifdef IAMSUID                          /* actually, this is caught earlier */
1920         if (euid != uid && !euid) {     /* if running suidperl */
1921 #ifdef HAS_SETEUID
1922             (void)seteuid(uid);         /* musn't stay setuid root */
1923 #else
1924 #ifdef HAS_SETREUID
1925             (void)setreuid((Uid_t)-1, uid);
1926 #else
1927 #ifdef HAS_SETRESUID
1928             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1929 #else
1930             PerlProc_setuid(uid);
1931 #endif
1932 #endif
1933 #endif
1934             if (PerlProc_geteuid() != uid)
1935                 croak("Can't do seteuid!\n");
1936         }
1937 #endif /* IAMSUID */
1938         rsfp = PerlProc_popen(SvPVX(cmd), "r");
1939         SvREFCNT_dec(cmd);
1940         SvREFCNT_dec(cpp);
1941     }
1942     else if (!*scriptname) {
1943         forbid_setid("program input from stdin");
1944         rsfp = PerlIO_stdin();
1945     }
1946     else {
1947         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1948 #if defined(HAS_FCNTL) && defined(F_SETFD)
1949         if (rsfp)
1950             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1951 #endif
1952     }
1953     if (!rsfp) {
1954 #ifdef DOSUID
1955 #ifndef IAMSUID         /* in case script is not readable before setuid */
1956         if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1957           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1958             /* try again */
1959             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1960             croak("Can't do setuid\n");
1961         }
1962 #endif
1963 #endif
1964         croak("Can't open perl script \"%s\": %s\n",
1965           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1966     }
1967 }
1968
1969 STATIC void
1970 validate_suid(char *validarg, char *scriptname, int fdscript)
1971 {
1972     int which;
1973
1974     /* do we need to emulate setuid on scripts? */
1975
1976     /* This code is for those BSD systems that have setuid #! scripts disabled
1977      * in the kernel because of a security problem.  Merely defining DOSUID
1978      * in perl will not fix that problem, but if you have disabled setuid
1979      * scripts in the kernel, this will attempt to emulate setuid and setgid
1980      * on scripts that have those now-otherwise-useless bits set.  The setuid
1981      * root version must be called suidperl or sperlN.NNN.  If regular perl
1982      * discovers that it has opened a setuid script, it calls suidperl with
1983      * the same argv that it had.  If suidperl finds that the script it has
1984      * just opened is NOT setuid root, it sets the effective uid back to the
1985      * uid.  We don't just make perl setuid root because that loses the
1986      * effective uid we had before invoking perl, if it was different from the
1987      * uid.
1988      *
1989      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1990      * be defined in suidperl only.  suidperl must be setuid root.  The
1991      * Configure script will set this up for you if you want it.
1992      */
1993
1994 #ifdef DOSUID
1995     dTHR;
1996     char *s, *s2;
1997
1998     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
1999         croak("Can't stat script \"%s\"",origfilename);
2000     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2001         I32 len;
2002
2003 #ifdef IAMSUID
2004 #ifndef HAS_SETREUID
2005         /* On this access check to make sure the directories are readable,
2006          * there is actually a small window that the user could use to make
2007          * filename point to an accessible directory.  So there is a faint
2008          * chance that someone could execute a setuid script down in a
2009          * non-accessible directory.  I don't know what to do about that.
2010          * But I don't think it's too important.  The manual lies when
2011          * it says access() is useful in setuid programs.
2012          */
2013         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2014             croak("Permission denied");
2015 #else
2016         /* If we can swap euid and uid, then we can determine access rights
2017          * with a simple stat of the file, and then compare device and
2018          * inode to make sure we did stat() on the same file we opened.
2019          * Then we just have to make sure he or she can execute it.
2020          */
2021         {
2022             struct stat tmpstatbuf;
2023
2024             if (
2025 #ifdef HAS_SETREUID
2026                 setreuid(euid,uid) < 0
2027 #else
2028 # if HAS_SETRESUID
2029                 setresuid(euid,uid,(Uid_t)-1) < 0
2030 # endif
2031 #endif
2032                 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
2033                 croak("Can't swap uid and euid");       /* really paranoid */
2034             if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2035                 croak("Permission denied");     /* testing full pathname here */
2036             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2037                 tmpstatbuf.st_ino != statbuf.st_ino) {
2038                 (void)PerlIO_close(rsfp);
2039                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2040                     PerlIO_printf(rsfp,
2041 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2042 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2043                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2044                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2045                         SvPVX(GvSV(curcop->cop_filegv)),
2046                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2047                     (void)PerlProc_pclose(rsfp);
2048                 }
2049                 croak("Permission denied\n");
2050             }
2051             if (
2052 #ifdef HAS_SETREUID
2053               setreuid(uid,euid) < 0
2054 #else
2055 # if defined(HAS_SETRESUID)
2056               setresuid(uid,euid,(Uid_t)-1) < 0
2057 # endif
2058 #endif
2059               || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
2060                 croak("Can't reswap uid and euid");
2061             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2062                 croak("Permission denied\n");
2063         }
2064 #endif /* HAS_SETREUID */
2065 #endif /* IAMSUID */
2066
2067         if (!S_ISREG(statbuf.st_mode))
2068             croak("Permission denied");
2069         if (statbuf.st_mode & S_IWOTH)
2070             croak("Setuid/gid script is writable by world");
2071         doswitches = FALSE;             /* -s is insecure in suid */
2072         curcop->cop_line++;
2073         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2074           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2075             croak("No #! line");
2076         s = SvPV(linestr,na)+2;
2077         if (*s == ' ') s++;
2078         while (!isSPACE(*s)) s++;
2079         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2080                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2081         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2082             croak("Not a perl script");
2083         while (*s == ' ' || *s == '\t') s++;
2084         /*
2085          * #! arg must be what we saw above.  They can invoke it by
2086          * mentioning suidperl explicitly, but they may not add any strange
2087          * arguments beyond what #! says if they do invoke suidperl that way.
2088          */
2089         len = strlen(validarg);
2090         if (strEQ(validarg," PHOOEY ") ||
2091             strnNE(s,validarg,len) || !isSPACE(s[len]))
2092             croak("Args must match #! line");
2093
2094 #ifndef IAMSUID
2095         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2096             euid == statbuf.st_uid)
2097             if (!do_undump)
2098                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2099 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2100 #endif /* IAMSUID */
2101
2102         if (euid) {     /* oops, we're not the setuid root perl */
2103             (void)PerlIO_close(rsfp);
2104 #ifndef IAMSUID
2105             /* try again */
2106             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2107 #endif
2108             croak("Can't do setuid\n");
2109         }
2110
2111         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2112 #ifdef HAS_SETEGID
2113             (void)setegid(statbuf.st_gid);
2114 #else
2115 #ifdef HAS_SETREGID
2116            (void)setregid((Gid_t)-1,statbuf.st_gid);
2117 #else
2118 #ifdef HAS_SETRESGID
2119            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2120 #else
2121             PerlProc_setgid(statbuf.st_gid);
2122 #endif
2123 #endif
2124 #endif
2125             if (PerlProc_getegid() != statbuf.st_gid)
2126                 croak("Can't do setegid!\n");
2127         }
2128         if (statbuf.st_mode & S_ISUID) {
2129             if (statbuf.st_uid != euid)
2130 #ifdef HAS_SETEUID
2131                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2132 #else
2133 #ifdef HAS_SETREUID
2134                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2135 #else
2136 #ifdef HAS_SETRESUID
2137                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2138 #else
2139                 PerlProc_setuid(statbuf.st_uid);
2140 #endif
2141 #endif
2142 #endif
2143             if (PerlProc_geteuid() != statbuf.st_uid)
2144                 croak("Can't do seteuid!\n");
2145         }
2146         else if (uid) {                 /* oops, mustn't run as root */
2147 #ifdef HAS_SETEUID
2148           (void)seteuid((Uid_t)uid);
2149 #else
2150 #ifdef HAS_SETREUID
2151           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2152 #else
2153 #ifdef HAS_SETRESUID
2154           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2155 #else
2156           PerlProc_setuid((Uid_t)uid);
2157 #endif
2158 #endif
2159 #endif
2160             if (PerlProc_geteuid() != uid)
2161                 croak("Can't do seteuid!\n");
2162         }
2163         init_ids();
2164         if (!cando(S_IXUSR,TRUE,&statbuf))
2165             croak("Permission denied\n");       /* they can't do this */
2166     }
2167 #ifdef IAMSUID
2168     else if (preprocess)
2169         croak("-P not allowed for setuid/setgid script\n");
2170     else if (fdscript >= 0)
2171         croak("fd script not allowed in suidperl\n");
2172     else
2173         croak("Script is not setuid/setgid in suidperl\n");
2174
2175     /* We absolutely must clear out any saved ids here, so we */
2176     /* exec the real perl, substituting fd script for scriptname. */
2177     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2178     PerlIO_rewind(rsfp);
2179     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2180     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2181     if (!origargv[which])
2182         croak("Permission denied");
2183     origargv[which] = savepv(form("/dev/fd/%d/%s",
2184                                   PerlIO_fileno(rsfp), origargv[which]));
2185 #if defined(HAS_FCNTL) && defined(F_SETFD)
2186     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2187 #endif
2188     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2189     croak("Can't do setuid\n");
2190 #endif /* IAMSUID */
2191 #else /* !DOSUID */
2192     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2193 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2194         dTHR;
2195         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2196         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2197             ||
2198             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2199            )
2200             if (!do_undump)
2201                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2202 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2203 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2204         /* not set-id, must be wrapped */
2205     }
2206 #endif /* DOSUID */
2207 }
2208
2209 STATIC void
2210 find_beginning(void)
2211 {
2212     register char *s, *s2;
2213
2214     /* skip forward in input to the real script? */
2215
2216     forbid_setid("-x");
2217     while (doextract) {
2218         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2219             croak("No Perl script found in input\n");
2220         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2221             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2222             doextract = FALSE;
2223             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2224             s2 = s;
2225             while (*s == ' ' || *s == '\t') s++;
2226             if (*s++ == '-') {
2227                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2228                 if (strnEQ(s2-4,"perl",4))
2229                     /*SUPPRESS 530*/
2230                     while (s = moreswitches(s)) ;
2231             }
2232             if (cddir && PerlDir_chdir(cddir) < 0)
2233                 croak("Can't chdir to %s",cddir);
2234         }
2235     }
2236 }
2237
2238
2239 STATIC void
2240 init_ids(void)
2241 {
2242     uid = (int)PerlProc_getuid();
2243     euid = (int)PerlProc_geteuid();
2244     gid = (int)PerlProc_getgid();
2245     egid = (int)PerlProc_getegid();
2246 #ifdef VMS
2247     uid |= gid << 16;
2248     euid |= egid << 16;
2249 #endif
2250     tainting |= (uid && (euid != uid || egid != gid));
2251 }
2252
2253 STATIC void
2254 forbid_setid(char *s)
2255 {
2256     if (euid != uid)
2257         croak("No %s allowed while running setuid", s);
2258     if (egid != gid)
2259         croak("No %s allowed while running setgid", s);
2260 }
2261
2262 STATIC void
2263 init_debugger(void)
2264 {
2265     dTHR;
2266     curstash = debstash;
2267     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2268     AvREAL_off(dbargs);
2269     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2270     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2271     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2272     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2273     sv_setiv(DBsingle, 0);
2274     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2275     sv_setiv(DBtrace, 0);
2276     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2277     sv_setiv(DBsignal, 0);
2278     curstash = defstash;
2279 }
2280
2281 #ifndef STRESS_REALLOC
2282 #define REASONABLE(size) (size)
2283 #else
2284 #define REASONABLE(size) (1) /* unreasonable */
2285 #endif
2286
2287 void
2288 init_stacks(ARGSproto)
2289 {
2290     /* start with 128-item stack and 8K cxstack */
2291     curstackinfo = new_stackinfo(REASONABLE(128),
2292                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2293     curstackinfo->si_type = SI_MAIN;
2294     curstack = curstackinfo->si_stack;
2295     mainstack = curstack;               /* remember in case we switch stacks */
2296
2297     stack_base = AvARRAY(curstack);
2298     stack_sp = stack_base;
2299     stack_max = stack_base + AvMAX(curstack);
2300
2301     New(50,tmps_stack,REASONABLE(128),SV*);
2302     tmps_floor = -1;
2303     tmps_ix = -1;
2304     tmps_max = REASONABLE(128);
2305
2306     /*
2307      * The following stacks almost certainly should be per-interpreter,
2308      * but for now they're not.  XXX
2309      */
2310
2311     if (markstack) {
2312         markstack_ptr = markstack;
2313     } else {
2314         New(54,markstack,REASONABLE(32),I32);
2315         markstack_ptr = markstack;
2316         markstack_max = markstack + REASONABLE(32);
2317     }
2318
2319     SET_MARKBASE;
2320
2321     if (scopestack) {
2322         scopestack_ix = 0;
2323     } else {
2324         New(54,scopestack,REASONABLE(32),I32);
2325         scopestack_ix = 0;
2326         scopestack_max = REASONABLE(32);
2327     }
2328
2329     if (savestack) {
2330         savestack_ix = 0;
2331     } else {
2332         New(54,savestack,REASONABLE(128),ANY);
2333         savestack_ix = 0;
2334         savestack_max = REASONABLE(128);
2335     }
2336
2337     if (retstack) {
2338         retstack_ix = 0;
2339     } else {
2340         New(54,retstack,REASONABLE(16),OP*);
2341         retstack_ix = 0;
2342         retstack_max = REASONABLE(16);
2343     }
2344 }
2345
2346 #undef REASONABLE
2347
2348 STATIC void
2349 nuke_stacks(void)
2350 {
2351     dTHR;
2352     while (curstackinfo->si_next)
2353         curstackinfo = curstackinfo->si_next;
2354     while (curstackinfo) {
2355         PERL_SI *p = curstackinfo->si_prev;
2356         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2357         Safefree(curstackinfo->si_cxstack);
2358         Safefree(curstackinfo);
2359         curstackinfo = p;
2360     }
2361     Safefree(tmps_stack);
2362     /*  XXX refcount interpreters to determine when to free global data
2363     Safefree(markstack);
2364     Safefree(scopestack);
2365     Safefree(savestack);
2366     Safefree(retstack);
2367     */
2368     DEBUG( {
2369         Safefree(debname);
2370         Safefree(debdelim);
2371     } )
2372 }
2373
2374 #ifndef PERL_OBJECT
2375 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2376 #endif
2377
2378 STATIC void
2379 init_lexer(void)
2380 {
2381 #ifdef PERL_OBJECT
2382         PerlIO *tmpfp;
2383 #endif
2384     tmpfp = rsfp;
2385     rsfp = Nullfp;
2386     lex_start(linestr);
2387     rsfp = tmpfp;
2388     subname = newSVpv("main",4);
2389 }
2390
2391 STATIC void
2392 init_predump_symbols(void)
2393 {
2394     dTHR;
2395     GV *tmpgv;
2396     GV *othergv;
2397
2398     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2399     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2400     GvMULTI_on(stdingv);
2401     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2402     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2403     GvMULTI_on(tmpgv);
2404     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2405
2406     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2407     GvMULTI_on(tmpgv);
2408     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2409     setdefout(tmpgv);
2410     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2411     GvMULTI_on(tmpgv);
2412     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2413
2414     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2415     GvMULTI_on(othergv);
2416     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2417     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2418     GvMULTI_on(tmpgv);
2419     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2420
2421     statname = NEWSV(66,0);             /* last filename we did stat on */
2422
2423     if (!osname)
2424         osname = savepv(OSNAME);
2425 }
2426
2427 STATIC void
2428 init_postdump_symbols(register int argc, register char **argv, register char **env)
2429 {
2430     dTHR;
2431     char *s;
2432     SV *sv;
2433     GV* tmpgv;
2434
2435     argc--,argv++;      /* skip name of script */
2436     if (doswitches) {
2437         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2438             if (!argv[0][1])
2439                 break;
2440             if (argv[0][1] == '-') {
2441                 argc--,argv++;
2442                 break;
2443             }
2444             if (s = strchr(argv[0], '=')) {
2445                 *s++ = '\0';
2446                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2447             }
2448             else
2449                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2450         }
2451     }
2452     toptarget = NEWSV(0,0);
2453     sv_upgrade(toptarget, SVt_PVFM);
2454     sv_setpvn(toptarget, "", 0);
2455     bodytarget = NEWSV(0,0);
2456     sv_upgrade(bodytarget, SVt_PVFM);
2457     sv_setpvn(bodytarget, "", 0);
2458     formtarget = bodytarget;
2459
2460     TAINT;
2461     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2462         sv_setpv(GvSV(tmpgv),origfilename);
2463         magicname("0", "0", 1);
2464     }
2465     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2466         sv_setpv(GvSV(tmpgv),origargv[0]);
2467     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2468         GvMULTI_on(argvgv);
2469         (void)gv_AVadd(argvgv);
2470         av_clear(GvAVn(argvgv));
2471         for (; argc > 0; argc--,argv++) {
2472             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2473         }
2474     }
2475     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2476         HV *hv;
2477         GvMULTI_on(envgv);
2478         hv = GvHVn(envgv);
2479         hv_magic(hv, envgv, 'E');
2480 #ifndef VMS  /* VMS doesn't have environ array */
2481         /* Note that if the supplied env parameter is actually a copy
2482            of the global environ then it may now point to free'd memory
2483            if the environment has been modified since. To avoid this
2484            problem we treat env==NULL as meaning 'use the default'
2485         */
2486         if (!env)
2487             env = environ;
2488         if (env != environ)
2489             environ[0] = Nullch;
2490         for (; *env; env++) {
2491             if (!(s = strchr(*env,'=')))
2492                 continue;
2493             *s++ = '\0';
2494 #if defined(MSDOS)
2495             (void)strupr(*env);
2496 #endif
2497             sv = newSVpv(s--,0);
2498             (void)hv_store(hv, *env, s - *env, sv, 0);
2499             *s = '=';
2500 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2501             /* Sins of the RTL. See note in my_setenv(). */
2502             (void)PerlEnv_putenv(savepv(*env));
2503 #endif
2504         }
2505 #endif
2506 #ifdef DYNAMIC_ENV_FETCH
2507         HvNAME(hv) = savepv(ENV_HV_NAME);
2508 #endif
2509     }
2510     TAINT_NOT;
2511     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2512         sv_setiv(GvSV(tmpgv), (IV)getpid());
2513 }
2514
2515 STATIC void
2516 init_perllib(void)
2517 {
2518     char *s;
2519     if (!tainting) {
2520 #ifndef VMS
2521         s = PerlEnv_getenv("PERL5LIB");
2522         if (s)
2523             incpush(s, TRUE);
2524         else
2525             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2526 #else /* VMS */
2527         /* Treat PERL5?LIB as a possible search list logical name -- the
2528          * "natural" VMS idiom for a Unix path string.  We allow each
2529          * element to be a set of |-separated directories for compatibility.
2530          */
2531         char buf[256];
2532         int idx = 0;
2533         if (my_trnlnm("PERL5LIB",buf,0))
2534             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2535         else
2536             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2537 #endif /* VMS */
2538     }
2539
2540 /* Use the ~-expanded versions of APPLLIB (undocumented),
2541     ARCHLIB PRIVLIB SITEARCH and SITELIB
2542 */
2543 #ifdef APPLLIB_EXP
2544     incpush(APPLLIB_EXP, TRUE);
2545 #endif
2546
2547 #ifdef ARCHLIB_EXP
2548     incpush(ARCHLIB_EXP, FALSE);
2549 #endif
2550 #ifndef PRIVLIB_EXP
2551 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2552 #endif
2553 #if defined(WIN32)
2554     incpush(PRIVLIB_EXP, TRUE);
2555 #else
2556     incpush(PRIVLIB_EXP, FALSE);
2557 #endif
2558
2559 #ifdef SITEARCH_EXP
2560     incpush(SITEARCH_EXP, FALSE);
2561 #endif
2562 #ifdef SITELIB_EXP
2563 #if defined(WIN32)
2564     incpush(SITELIB_EXP, TRUE);
2565 #else
2566     incpush(SITELIB_EXP, FALSE);
2567 #endif
2568 #endif
2569     if (!tainting)
2570         incpush(".", FALSE);
2571 }
2572
2573 #if defined(DOSISH)
2574 #    define PERLLIB_SEP ';'
2575 #else
2576 #  if defined(VMS)
2577 #    define PERLLIB_SEP '|'
2578 #  else
2579 #    define PERLLIB_SEP ':'
2580 #  endif
2581 #endif
2582 #ifndef PERLLIB_MANGLE
2583 #  define PERLLIB_MANGLE(s,n) (s)
2584 #endif
2585
2586 STATIC void
2587 incpush(char *p, int addsubdirs)
2588 {
2589     SV *subdir = Nullsv;
2590
2591     if (!p)
2592         return;
2593
2594     if (addsubdirs) {
2595         subdir = sv_newmortal();
2596         if (!archpat_auto) {
2597             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2598                           + sizeof("//auto"));
2599             New(55, archpat_auto, len, char);
2600             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2601 #ifdef VMS
2602         for (len = sizeof(ARCHNAME) + 2;
2603              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2604                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2605 #endif
2606         }
2607     }
2608
2609     /* Break at all separators */
2610     while (p && *p) {
2611         SV *libdir = NEWSV(55,0);
2612         char *s;
2613
2614         /* skip any consecutive separators */
2615         while ( *p == PERLLIB_SEP ) {
2616             /* Uncomment the next line for PATH semantics */
2617             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2618             p++;
2619         }
2620
2621         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2622             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2623                       (STRLEN)(s - p));
2624             p = s + 1;
2625         }
2626         else {
2627             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2628             p = Nullch; /* break out */
2629         }
2630
2631         /*
2632          * BEFORE pushing libdir onto @INC we may first push version- and
2633          * archname-specific sub-directories.
2634          */
2635         if (addsubdirs) {
2636             struct stat tmpstatbuf;
2637 #ifdef VMS
2638             char *unix;
2639             STRLEN len;
2640
2641             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2642                 len = strlen(unix);
2643                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2644                 sv_usepvn(libdir,unix,len);
2645             }
2646             else
2647                 PerlIO_printf(PerlIO_stderr(),
2648                               "Failed to unixify @INC element \"%s\"\n",
2649                               SvPV(libdir,na));
2650 #endif
2651             /* .../archname/version if -d .../archname/version/auto */
2652             sv_setsv(subdir, libdir);
2653             sv_catpv(subdir, archpat_auto);
2654             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2655                   S_ISDIR(tmpstatbuf.st_mode))
2656                 av_push(GvAVn(incgv),
2657                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2658
2659             /* .../archname if -d .../archname/auto */
2660             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2661                       strlen(patchlevel) + 1, "", 0);
2662             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2663                   S_ISDIR(tmpstatbuf.st_mode))
2664                 av_push(GvAVn(incgv),
2665                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2666         }
2667
2668         /* finally push this lib directory on the end of @INC */
2669         av_push(GvAVn(incgv), libdir);
2670     }
2671 }
2672
2673 #ifdef USE_THREADS
2674 STATIC struct perl_thread *
2675 init_main_thread()
2676 {
2677     struct perl_thread *thr;
2678     XPV *xpv;
2679
2680     Newz(53, thr, 1, struct perl_thread);
2681     curcop = &compiling;
2682     thr->cvcache = newHV();
2683     thr->threadsv = newAV();
2684     /* thr->threadsvp is set when find_threadsv is called */
2685     thr->specific = newAV();
2686     thr->errhv = newHV();
2687     thr->flags = THRf_R_JOINABLE;
2688     MUTEX_INIT(&thr->mutex);
2689     /* Handcraft thrsv similarly to mess_sv */
2690     New(53, thrsv, 1, SV);
2691     Newz(53, xpv, 1, XPV);
2692     SvFLAGS(thrsv) = SVt_PV;
2693     SvANY(thrsv) = (void*)xpv;
2694     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2695     SvPVX(thrsv) = (char*)thr;
2696     SvCUR_set(thrsv, sizeof(thr));
2697     SvLEN_set(thrsv, sizeof(thr));
2698     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2699     thr->oursv = thrsv;
2700     chopset = " \n-";
2701
2702     MUTEX_LOCK(&threads_mutex);
2703     nthreads++;
2704     thr->tid = 0;
2705     thr->next = thr;
2706     thr->prev = thr;
2707     MUTEX_UNLOCK(&threads_mutex);
2708
2709 #ifdef HAVE_THREAD_INTERN
2710     init_thread_intern(thr);
2711 #endif
2712
2713 #ifdef SET_THREAD_SELF
2714     SET_THREAD_SELF(thr);
2715 #else
2716     thr->self = pthread_self();
2717 #endif /* SET_THREAD_SELF */
2718     SET_THR(thr);
2719
2720     /*
2721      * These must come after the SET_THR because sv_setpvn does
2722      * SvTAINT and the taint fields require dTHR.
2723      */
2724     toptarget = NEWSV(0,0);
2725     sv_upgrade(toptarget, SVt_PVFM);
2726     sv_setpvn(toptarget, "", 0);
2727     bodytarget = NEWSV(0,0);
2728     sv_upgrade(bodytarget, SVt_PVFM);
2729     sv_setpvn(bodytarget, "", 0);
2730     formtarget = bodytarget;
2731     thr->errsv = newSVpv("", 0);
2732     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2733     return thr;
2734 }
2735 #endif /* USE_THREADS */
2736
2737 void
2738 call_list(I32 oldscope, AV *paramList)
2739 {
2740     dTHR;
2741     line_t oldline = curcop->cop_line;
2742     STRLEN len;
2743     dJMPENV;
2744     int ret;
2745
2746     while (AvFILL(paramList) >= 0) {
2747         CV *cv = (CV*)av_shift(paramList);
2748
2749         SAVEFREESV(cv);
2750
2751         JMPENV_PUSH(ret);
2752         switch (ret) {
2753         case 0: {
2754                 SV* atsv = ERRSV;
2755                 PUSHMARK(stack_sp);
2756                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2757                 (void)SvPV(atsv, len);
2758                 if (len) {
2759                     JMPENV_POP;
2760                     curcop = &compiling;
2761                     curcop->cop_line = oldline;
2762                     if (paramList == beginav)
2763                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2764                     else
2765                         sv_catpv(atsv, "END failed--cleanup aborted");
2766                     while (scopestack_ix > oldscope)
2767                         LEAVE;
2768                     croak("%s", SvPVX(atsv));
2769                 }
2770             }
2771             break;
2772         case 1:
2773             STATUS_ALL_FAILURE;
2774             /* FALL THROUGH */
2775         case 2:
2776             /* my_exit() was called */
2777             while (scopestack_ix > oldscope)
2778                 LEAVE;
2779             FREETMPS;
2780             curstash = defstash;
2781             if (endav)
2782                 call_list(oldscope, endav);
2783             JMPENV_POP;
2784             curcop = &compiling;
2785             curcop->cop_line = oldline;
2786             if (statusvalue) {
2787                 if (paramList == beginav)
2788                     croak("BEGIN failed--compilation aborted");
2789                 else
2790                     croak("END failed--cleanup aborted");
2791             }
2792             my_exit_jump();
2793             /* NOTREACHED */
2794         case 3:
2795             if (!restartop) {
2796                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2797                 FREETMPS;
2798                 break;
2799             }
2800             JMPENV_POP;
2801             curcop = &compiling;
2802             curcop->cop_line = oldline;
2803             JMPENV_JUMP(3);
2804         }
2805         JMPENV_POP;
2806     }
2807 }
2808
2809 void
2810 my_exit(U32 status)
2811 {
2812     dTHR;
2813
2814 #ifdef USE_THREADS
2815     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2816                           thr, (unsigned long) status));
2817 #endif /* USE_THREADS */
2818     switch (status) {
2819     case 0:
2820         STATUS_ALL_SUCCESS;
2821         break;
2822     case 1:
2823         STATUS_ALL_FAILURE;
2824         break;
2825     default:
2826         STATUS_NATIVE_SET(status);
2827         break;
2828     }
2829     my_exit_jump();
2830 }
2831
2832 void
2833 my_failure_exit(void)
2834 {
2835 #ifdef VMS
2836     if (vaxc$errno & 1) {
2837         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2838             STATUS_NATIVE_SET(44);
2839     }
2840     else {
2841         if (!vaxc$errno && errno)       /* unlikely */
2842             STATUS_NATIVE_SET(44);
2843         else
2844             STATUS_NATIVE_SET(vaxc$errno);
2845     }
2846 #else
2847     int exitstatus;
2848     if (errno & 255)
2849         STATUS_POSIX_SET(errno);
2850     else {
2851         exitstatus = STATUS_POSIX >> 8;
2852         if (exitstatus & 255)
2853             STATUS_POSIX_SET(exitstatus);
2854         else
2855             STATUS_POSIX_SET(255);
2856     }
2857 #endif
2858     my_exit_jump();
2859 }
2860
2861 STATIC void
2862 my_exit_jump(void)
2863 {
2864     dSP;
2865     register PERL_CONTEXT *cx;
2866     I32 gimme;
2867     SV **newsp;
2868
2869     if (e_script) {
2870         SvREFCNT_dec(e_script);
2871         e_script = Nullsv;
2872     }
2873
2874     POPSTACK_TO(mainstack);
2875     if (cxstack_ix >= 0) {
2876         if (cxstack_ix > 0)
2877             dounwind(0);
2878         POPBLOCK(cx,curpm);
2879         LEAVE;
2880     }
2881
2882     JMPENV_JUMP(2);
2883 }
2884
2885
2886 #include "XSUB.h"
2887
2888 static I32
2889 #ifdef PERL_OBJECT
2890 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
2891 #else
2892 read_e_script(int idx, SV *buf_sv, int maxlen)
2893 #endif
2894 {
2895     char *p, *nl;
2896     p  = SvPVX(e_script);
2897     nl = strchr(p, '\n');
2898     nl = (nl) ? nl+1 : SvEND(e_script);
2899     if (nl-p == 0)
2900         return 0;
2901     sv_catpvn(buf_sv, p, nl-p);
2902     sv_chop(e_script, nl);
2903     return 1;
2904 }
2905
2906