perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (c) 1987-1999 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 #define PERL_IN_PERL_C
  16 #include "perl.h"
  17 #include "patchlevel.h"                 /* for local_patches */
  18
  19 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  20 #ifdef I_UNISTD
  21 #include <unistd.h>
  22 #endif
  23
  24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
  25 char *getenv (char *); /* Usually in <stdlib.h> */
  26 #endif
  27
  28 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
  29
  30 #ifdef I_FCNTL
  31 #include <fcntl.h>
  32 #endif
  33 #ifdef I_SYS_FILE
  34 #include <sys/file.h>
  35 #endif
  36
  37 #ifdef IAMSUID
  38 #ifndef DOSUID
  39 #define DOSUID
  40 #endif
  41 #endif
  42
  43 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  44 #ifdef DOSUID
  45 #undef DOSUID
  46 #endif
  47 #endif
  48
  49 #ifdef PERL_OBJECT
  50 CPerlObj*
  51 perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE,
  52                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
  53                  struct IPerlDir* ipD, struct IPerlSock* ipS,
  54                  struct IPerlProc* ipP)
  55 {
  56     CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
  57     if (pPerl != NULL)
  58         pPerl->Init();
  59
  60     return pPerl;
  61 }
  62 #else
  63
  64 #ifdef PERL_IMPLICIT_SYS
  65 PerlInterpreter *
  66 perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE,
  67                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
  68                  struct IPerlDir* ipD, struct IPerlSock* ipS,
  69                  struct IPerlProc* ipP)
  70 {
  71     PerlInterpreter *my_perl;
  72
  73     /* New() needs interpreter, so call malloc() instead */
  74     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
  75     PERL_SET_INTERP(my_perl);
  76     Zero(my_perl, 1, PerlInterpreter);
  77     PL_Mem = ipM;
  78     PL_Env = ipE;
  79     PL_StdIO = ipStd;
  80     PL_LIO = ipLIO;
  81     PL_Dir = ipD;
  82     PL_Sock = ipS;
  83     PL_Proc = ipP;
  84     return my_perl;
  85 }
  86 #else
  87 PerlInterpreter *
  88 perl_alloc(void)
  89 {
  90     PerlInterpreter *my_perl;
  91
  92     /* New() needs interpreter, so call malloc() instead */
  93     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
  94     PERL_SET_INTERP(my_perl);
  95     return my_perl;
  96 }
  97 #endif /* PERL_IMPLICIT_SYS */
  98 #endif /* PERL_OBJECT */
  99
 100 void
 101 perl_construct(pTHXx)
 102 {
 103 #ifdef USE_THREADS
 104     int i;
 105 #ifndef FAKE_THREADS
 106     struct perl_thread *thr = NULL;
 107 #endif /* FAKE_THREADS */
 108 #endif /* USE_THREADS */
 109
 110 #ifdef MULTIPLICITY
 111     init_interp();
 112     PL_perl_destruct_level = 1;
 113 #else
 114    if (PL_perl_destruct_level > 0)
 115        init_interp();
 116 #endif
 117
 118    /* Init the real globals (and main thread)? */
 119     if (!PL_linestr) {
 120 #ifdef USE_THREADS
 121
 122         INIT_THREADS;
 123 #ifdef ALLOC_THREAD_KEY
 124         ALLOC_THREAD_KEY;
 125 #else
 126         if (pthread_key_create(&PL_thr_key, 0))
 127             Perl_croak(aTHX_ "panic: pthread_key_create");
 128 #endif
 129         MUTEX_INIT(&PL_sv_mutex);
 130         /*
 131          * Safe to use basic SV functions from now on (though
 132          * not things like mortals or tainting yet).
 133          */
 134         MUTEX_INIT(&PL_eval_mutex);
 135         COND_INIT(&PL_eval_cond);
 136         MUTEX_INIT(&PL_threads_mutex);
 137         COND_INIT(&PL_nthreads_cond);
 138 #ifdef EMULATE_ATOMIC_REFCOUNTS
 139         MUTEX_INIT(&PL_svref_mutex);
 140 #endif /* EMULATE_ATOMIC_REFCOUNTS */
 141
 142         MUTEX_INIT(&PL_cred_mutex);
 143
 144         thr = init_main_thread();
 145 #endif /* USE_THREADS */
 146
 147         PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
 148
 149         PL_curcop = &PL_compiling;      /* needed by ckWARN, right away */
 150
 151         PL_linestr = NEWSV(65,79);
 152         sv_upgrade(PL_linestr,SVt_PVIV);
 153
 154         if (!SvREADONLY(&PL_sv_undef)) {
 155             /* set read-only and try to insure than we wont see REFCNT==0
 156                very often */
 157
 158             SvREADONLY_on(&PL_sv_undef);
 159             SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
 160
 161             sv_setpv(&PL_sv_no,PL_No);
 162             SvNV(&PL_sv_no);
 163             SvREADONLY_on(&PL_sv_no);
 164             SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
 165
 166             sv_setpv(&PL_sv_yes,PL_Yes);
 167             SvNV(&PL_sv_yes);
 168             SvREADONLY_on(&PL_sv_yes);
 169             SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
 170         }
 171
 172 #ifdef PERL_OBJECT
 173         /* TODO: */
 174         /* PL_sighandlerp = sighandler; */
 175 #else
 176         PL_sighandlerp = Perl_sighandler;
 177 #endif
 178         PL_pidstatus = newHV();
 179
 180 #ifdef MSDOS
 181         /*
 182          * There is no way we can refer to them from Perl so close them to save
 183          * space.  The other alternative would be to provide STDAUX and STDPRN
 184          * filehandles.
 185          */
 186         (void)fclose(stdaux);
 187         (void)fclose(stdprn);
 188 #endif
 189     }
 190
 191     PL_nrs = newSVpvn("\n", 1);
 192     PL_rs = SvREFCNT_inc(PL_nrs);
 193
 194     init_stacks();
 195
 196     init_ids();
 197     PL_lex_state = LEX_NOTPARSING;
 198
 199     JMPENV_BOOTSTRAP;
 200     STATUS_ALL_SUCCESS;
 201
 202     init_i18nl10n(1);
 203     SET_NUMERIC_STANDARD();
 204
 205 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
 206     sprintf(PL_patchlevel, "%7.5f",   (double) PERL_REVISION
 207                                 + ((double) PERL_VERSION / (double) 1000)
 208                                 + ((double) PERL_SUBVERSION / (double) 100000));
 209 #else
 210     sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
 211                                 ((double) PERL_VERSION / (double) 1000));
 212 #endif
 213
 214 #if defined(LOCAL_PATCH_COUNT)
 215     PL_localpatches = local_patches;    /* For possible -v */
 216 #endif
 217
 218     PerlIO_init();                      /* Hook to IO system */
 219
 220     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
 221     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
 222
 223     ENTER;
 224 }
 225
 226 void
 227 perl_destruct(pTHXx)
 228 {
 229     dTHR;
 230     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 231     I32 last_sv_count;
 232     HV *hv;
 233 #ifdef USE_THREADS
 234     Thread t;
 235     dTHX;
 236 #endif /* USE_THREADS */
 237
 238 #ifdef USE_THREADS
 239 #ifndef FAKE_THREADS
 240     /* Pass 1 on any remaining threads: detach joinables, join zombies */
 241   retry_cleanup:
 242     MUTEX_LOCK(&PL_threads_mutex);
 243     DEBUG_S(PerlIO_printf(Perl_debug_log,
 244                           "perl_destruct: waiting for %d threads...\n",
 245                           PL_nthreads - 1));
 246     for (t = thr->next; t != thr; t = t->next) {
 247         MUTEX_LOCK(&t->mutex);
 248         switch (ThrSTATE(t)) {
 249             AV *av;
 250         case THRf_ZOMBIE:
 251             DEBUG_S(PerlIO_printf(Perl_debug_log,
 252                                   "perl_destruct: joining zombie %p\n", t));
 253             ThrSETSTATE(t, THRf_DEAD);
 254             MUTEX_UNLOCK(&t->mutex);
 255             PL_nthreads--;
 256             /*
 257              * The SvREFCNT_dec below may take a long time (e.g. av
 258              * may contain an object scalar whose destructor gets
 259              * called) so we have to unlock threads_mutex and start
 260              * all over again.
 261              */
 262             MUTEX_UNLOCK(&PL_threads_mutex);
 263             JOIN(t, &av);
 264             SvREFCNT_dec((SV*)av);
 265             DEBUG_S(PerlIO_printf(Perl_debug_log,
 266                                   "perl_destruct: joined zombie %p OK\n", t));
 267             goto retry_cleanup;
 268         case THRf_R_JOINABLE:
 269             DEBUG_S(PerlIO_printf(Perl_debug_log,
 270                                   "perl_destruct: detaching thread %p\n", t));
 271             ThrSETSTATE(t, THRf_R_DETACHED);
 272             /*
 273              * We unlock threads_mutex and t->mutex in the opposite order
 274              * from which we locked them just so that DETACH won't
 275              * deadlock if it panics. It's only a breach of good style
 276              * not a bug since they are unlocks not locks.
 277              */
 278             MUTEX_UNLOCK(&PL_threads_mutex);
 279             DETACH(t);
 280             MUTEX_UNLOCK(&t->mutex);
 281             goto retry_cleanup;
 282         default:
 283             DEBUG_S(PerlIO_printf(Perl_debug_log,
 284                                   "perl_destruct: ignoring %p (state %u)\n",
 285                                   t, ThrSTATE(t)));
 286             MUTEX_UNLOCK(&t->mutex);
 287             /* fall through and out */
 288         }
 289     }
 290     /* We leave the above "Pass 1" loop with threads_mutex still locked */
 291
 292     /* Pass 2 on remaining threads: wait for the thread count to drop to one */
 293     while (PL_nthreads > 1)
 294     {
 295         DEBUG_S(PerlIO_printf(Perl_debug_log,
 296                               "perl_destruct: final wait for %d threads\n",
 297                               PL_nthreads - 1));
 298         COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
 299     }
 300     /* At this point, we're the last thread */
 301     MUTEX_UNLOCK(&PL_threads_mutex);
 302     DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
 303     MUTEX_DESTROY(&PL_threads_mutex);
 304     COND_DESTROY(&PL_nthreads_cond);
 305 #endif /* !defined(FAKE_THREADS) */
 306 #endif /* USE_THREADS */
 307
 308     destruct_level = PL_perl_destruct_level;
 309 #ifdef DEBUGGING
 310     {
 311         char *s;
 312         if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
 313             int i = atoi(s);
 314             if (destruct_level < i)
 315                 destruct_level = i;
 316         }
 317     }
 318 #endif
 319
 320     LEAVE;
 321     FREETMPS;
 322
 323     /* We must account for everything.  */
 324
 325     /* Destroy the main CV and syntax tree */
 326     if (PL_main_root) {
 327         PL_curpad = AvARRAY(PL_comppad);
 328         op_free(PL_main_root);
 329         PL_main_root = Nullop;
 330     }
 331     PL_curcop = &PL_compiling;
 332     PL_main_start = Nullop;
 333     SvREFCNT_dec(PL_main_cv);
 334     PL_main_cv = Nullcv;
 335     PL_dirty = TRUE;
 336
 337     if (PL_sv_objcount) {
 338         /*
 339          * Try to destruct global references.  We do this first so that the
 340          * destructors and destructees still exist.  Some sv's might remain.
 341          * Non-referenced objects are on their own.
 342          */
 343         sv_clean_objs();
 344     }
 345
 346     /* unhook hooks which will soon be, or use, destroyed data */
 347     SvREFCNT_dec(PL_warnhook);
 348     PL_warnhook = Nullsv;
 349     SvREFCNT_dec(PL_diehook);
 350     PL_diehook = Nullsv;
 351
 352     /* call exit list functions */
 353     while (PL_exitlistlen-- > 0)
 354         PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
 355
 356     Safefree(PL_exitlist);
 357
 358     if (destruct_level == 0){
 359
 360         DEBUG_P(debprofdump());
 361
 362         /* The exit() function will do everything that needs doing. */
 363         return;
 364     }
 365
 366     /* loosen bonds of global variables */
 367
 368     if(PL_rsfp) {
 369         (void)PerlIO_close(PL_rsfp);
 370         PL_rsfp = Nullfp;
 371     }
 372
 373     /* Filters for program text */
 374     SvREFCNT_dec(PL_rsfp_filters);
 375     PL_rsfp_filters = Nullav;
 376
 377     /* switches */
 378     PL_preprocess   = FALSE;
 379     PL_minus_n      = FALSE;
 380     PL_minus_p      = FALSE;
 381     PL_minus_l      = FALSE;
 382     PL_minus_a      = FALSE;
 383     PL_minus_F      = FALSE;
 384     PL_doswitches   = FALSE;
 385     PL_dowarn       = G_WARN_OFF;
 386     PL_doextract    = FALSE;
 387     PL_sawampersand = FALSE;    /* must save all match strings */
 388     PL_unsafe       = FALSE;
 389
 390     Safefree(PL_inplace);
 391     PL_inplace = Nullch;
 392
 393     if (PL_e_script) {
 394         SvREFCNT_dec(PL_e_script);
 395         PL_e_script = Nullsv;
 396     }
 397
 398     /* magical thingies */
 399
 400     Safefree(PL_ofs);   /* $, */
 401     PL_ofs = Nullch;
 402
 403     Safefree(PL_ors);   /* $\ */
 404     PL_ors = Nullch;
 405
 406     SvREFCNT_dec(PL_rs);        /* $/ */
 407     PL_rs = Nullsv;
 408
 409     SvREFCNT_dec(PL_nrs);       /* $/ helper */
 410     PL_nrs = Nullsv;
 411
 412     PL_multiline = 0;   /* $* */
 413
 414     SvREFCNT_dec(PL_statname);
 415     PL_statname = Nullsv;
 416     PL_statgv = Nullgv;
 417
 418     /* defgv, aka *_ should be taken care of elsewhere */
 419
 420     /* clean up after study() */
 421     SvREFCNT_dec(PL_lastscream);
 422     PL_lastscream = Nullsv;
 423     Safefree(PL_screamfirst);
 424     PL_screamfirst = 0;
 425     Safefree(PL_screamnext);
 426     PL_screamnext  = 0;
 427
 428     /* float buffer */
 429     Safefree(PL_efloatbuf);
 430     PL_efloatbuf = Nullch;
 431     PL_efloatsize = 0;
 432
 433     /* startup and shutdown function lists */
 434     SvREFCNT_dec(PL_beginav);
 435     SvREFCNT_dec(PL_endav);
 436     SvREFCNT_dec(PL_initav);
 437     PL_beginav = Nullav;
 438     PL_endav = Nullav;
 439     PL_initav = Nullav;
 440
 441     /* shortcuts just get cleared */
 442     PL_envgv = Nullgv;
 443     PL_incgv = Nullgv;
 444     PL_hintgv = Nullgv;
 445     PL_errgv = Nullgv;
 446     PL_argvgv = Nullgv;
 447     PL_argvoutgv = Nullgv;
 448     PL_stdingv = Nullgv;
 449     PL_stderrgv = Nullgv;
 450     PL_last_in_gv = Nullgv;
 451     PL_replgv = Nullgv;
 452
 453     /* reset so print() ends up where we expect */
 454     setdefout(Nullgv);
 455
 456     /* Prepare to destruct main symbol table.  */
 457
 458     hv = PL_defstash;
 459     PL_defstash = 0;
 460     SvREFCNT_dec(hv);
 461
 462     /* clear queued errors */
 463     SvREFCNT_dec(PL_errors);
 464     PL_errors = Nullsv;
 465
 466     FREETMPS;
 467     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 468         if (PL_scopestack_ix != 0)
 469             Perl_warner(aTHX_ WARN_INTERNAL,
 470                  "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 471                  (long)PL_scopestack_ix);
 472         if (PL_savestack_ix != 0)
 473             Perl_warner(aTHX_ WARN_INTERNAL,
 474                  "Unbalanced saves: %ld more saves than restores\n",
 475                  (long)PL_savestack_ix);
 476         if (PL_tmps_floor != -1)
 477             Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
 478                  (long)PL_tmps_floor + 1);
 479         if (cxstack_ix != -1)
 480             Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
 481                  (long)cxstack_ix + 1);
 482     }
 483
 484     /* Now absolutely destruct everything, somehow or other, loops or no. */
 485     last_sv_count = 0;
 486     SvFLAGS(PL_strtab) |= SVTYPEMASK;           /* don't clean out strtab now */
 487     while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
 488         last_sv_count = PL_sv_count;
 489         sv_clean_all();
 490     }
 491     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
 492     SvFLAGS(PL_strtab) |= SVt_PVHV;
 493
 494     /* Destruct the global string table. */
 495     {
 496         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 497          * so that sv_free() won't fail on them.
 498          */
 499         I32 riter;
 500         I32 max;
 501         HE *hent;
 502         HE **array;
 503
 504         riter = 0;
 505         max = HvMAX(PL_strtab);
 506         array = HvARRAY(PL_strtab);
 507         hent = array[0];
 508         for (;;) {
 509             if (hent && ckWARN_d(WARN_INTERNAL)) {
 510                 Perl_warner(aTHX_ WARN_INTERNAL,
 511                      "Unbalanced string table refcount: (%d) for \"%s\"",
 512                      HeVAL(hent) - Nullsv, HeKEY(hent));
 513                 HeVAL(hent) = Nullsv;
 514                 hent = HeNEXT(hent);
 515             }
 516             if (!hent) {
 517                 if (++riter > max)
 518                     break;
 519                 hent = array[riter];
 520             }
 521         }
 522     }
 523     SvREFCNT_dec(PL_strtab);
 524
 525     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 526         Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
 527
 528     sv_free_arenas();
 529
 530     /* No SVs have survived, need to clean out */
 531     PL_linestr = NULL;
 532     PL_pidstatus = Nullhv;
 533     Safefree(PL_origfilename);
 534     Safefree(PL_archpat_auto);
 535     Safefree(PL_reg_start_tmp);
 536     if (PL_reg_curpm)
 537         Safefree(PL_reg_curpm);
 538     Safefree(PL_reg_poscache);
 539     Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
 540     Safefree(PL_op_mask);
 541     nuke_stacks();
 542     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
 543
 544     DEBUG_P(debprofdump());
 545 #ifdef USE_THREADS
 546     MUTEX_DESTROY(&PL_strtab_mutex);
 547     MUTEX_DESTROY(&PL_sv_mutex);
 548     MUTEX_DESTROY(&PL_eval_mutex);
 549     MUTEX_DESTROY(&PL_cred_mutex);
 550     COND_DESTROY(&PL_eval_cond);
 551 #ifdef EMULATE_ATOMIC_REFCOUNTS
 552     MUTEX_DESTROY(&PL_svref_mutex);
 553 #endif /* EMULATE_ATOMIC_REFCOUNTS */
 554
 555     /* As the penultimate thing, free the non-arena SV for thrsv */
 556     Safefree(SvPVX(PL_thrsv));
 557     Safefree(SvANY(PL_thrsv));
 558     Safefree(PL_thrsv);
 559     PL_thrsv = Nullsv;
 560 #endif /* USE_THREADS */
 561
 562     /* As the absolutely last thing, free the non-arena SV for mess() */
 563
 564     if (PL_mess_sv) {
 565         /* it could have accumulated taint magic */
 566         if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
 567             MAGIC* mg;
 568             MAGIC* moremagic;
 569             for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
 570                 moremagic = mg->mg_moremagic;
 571                 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
 572                     Safefree(mg->mg_ptr);
 573                 Safefree(mg);
 574             }
 575         }
 576         /* we know that type >= SVt_PV */
 577         SvOOK_off(PL_mess_sv);
 578         Safefree(SvPVX(PL_mess_sv));
 579         Safefree(SvANY(PL_mess_sv));
 580         Safefree(PL_mess_sv);
 581         PL_mess_sv = Nullsv;
 582     }
 583 }
 584
 585 void
 586 perl_free(pTHXx)
 587 {
 588 #if defined(PERL_OBJECT)
 589     PerlMem_free(this);
 590 #else
 591     PerlMem_free(aTHXx);
 592 #endif
 593 }
 594
 595 void
 596 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
 597 {
 598     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
 599     PL_exitlist[PL_exitlistlen].fn = fn;
 600     PL_exitlist[PL_exitlistlen].ptr = ptr;
 601     ++PL_exitlistlen;
 602 }
 603
 604 int
 605 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
 606 {
 607     dTHR;
 608     I32 oldscope;
 609     int ret;
 610     dJMPENV;
 611 #ifdef USE_THREADS
 612     dTHX;
 613 #endif
 614
 615 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 616 #ifdef IAMSUID
 617 #undef IAMSUID
 618     Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
 619 setuid perl scripts securely.\n");
 620 #endif
 621 #endif
 622
 623 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
 624     _dyld_lookup_and_bind
 625         ("__environ", (unsigned long *) &environ_pointer, NULL);
 626 #endif /* environ */
 627
 628     PL_origargv = argv;
 629     PL_origargc = argc;
 630 #ifndef VMS  /* VMS doesn't have environ array */
 631     PL_origenviron = environ;
 632 #endif
 633
 634     if (PL_do_undump) {
 635
 636         /* Come here if running an undumped a.out. */
 637
 638         PL_origfilename = savepv(argv[0]);
 639         PL_do_undump = FALSE;
 640         cxstack_ix = -1;                /* start label stack again */
 641         init_ids();
 642         init_postdump_symbols(argc,argv,env);
 643         return 0;
 644     }
 645
 646     if (PL_main_root) {
 647         PL_curpad = AvARRAY(PL_comppad);
 648         op_free(PL_main_root);
 649         PL_main_root = Nullop;
 650     }
 651     PL_main_start = Nullop;
 652     SvREFCNT_dec(PL_main_cv);
 653     PL_main_cv = Nullcv;
 654
 655     time(&PL_basetime);
 656     oldscope = PL_scopestack_ix;
 657     PL_dowarn = G_WARN_OFF;
 658
 659     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
 660                 env, xsinit);
 661     switch (ret) {
 662     case 0:
 663         return 0;
 664     case 1:
 665         STATUS_ALL_FAILURE;
 666         /* FALL THROUGH */
 667     case 2:
 668         /* my_exit() was called */
 669         while (PL_scopestack_ix > oldscope)
 670             LEAVE;
 671         FREETMPS;
 672         PL_curstash = PL_defstash;
 673         if (PL_endav && !PL_minus_c)
 674             call_list(oldscope, PL_endav);
 675         return STATUS_NATIVE_EXPORT;
 676     case 3:
 677         PerlIO_printf(Perl_error_log, "panic: top_env\n");
 678         return 1;
 679     }
 680     return 0;
 681 }
 682
 683 STATIC void *
 684 S_parse_body(pTHX_ va_list args)
 685 {
 686     dTHR;
 687     int argc = PL_origargc;
 688     char **argv = PL_origargv;
 689     char **env = va_arg(args, char**);
 690     char *scriptname = NULL;
 691     int fdscript = -1;
 692     VOL bool dosearch = FALSE;
 693     char *validarg = "";
 694     AV* comppadlist;
 695     register SV *sv;
 696     register char *s;
 697     char *cddir = Nullch;
 698
 699     XSINIT_t xsinit = va_arg(args, XSINIT_t);
 700
 701     sv_setpvn(PL_linestr,"",0);
 702     sv = newSVpvn("",0);                /* first used for -I flags */
 703     SAVEFREESV(sv);
 704     init_main_stash();
 705
 706     for (argc--,argv++; argc > 0; argc--,argv++) {
 707         if (argv[0][0] != '-' || !argv[0][1])
 708             break;
 709 #ifdef DOSUID
 710     if (*validarg)
 711         validarg = " PHOOEY ";
 712     else
 713         validarg = argv[0];
 714 #endif
 715         s = argv[0]+1;
 716       reswitch:
 717         switch (*s) {
 718 #ifndef PERL_STRICT_CR
 719         case '\r':
 720 #endif
 721         case ' ':
 722         case '0':
 723         case 'F':
 724         case 'a':
 725         case 'c':
 726         case 'd':
 727         case 'D':
 728         case 'h':
 729         case 'i':
 730         case 'l':
 731         case 'M':
 732         case 'm':
 733         case 'n':
 734         case 'p':
 735         case 's':
 736         case 'u':
 737         case 'U':
 738         case 'v':
 739         case 'W':
 740         case 'X':
 741         case 'w':
 742             if (s = moreswitches(s))
 743                 goto reswitch;
 744             break;
 745
 746         case 'T':
 747             PL_tainting = TRUE;
 748             s++;
 749             goto reswitch;
 750
 751         case 'e':
 752 #ifdef MACOS_TRADITIONAL
 753             /* ignore -e for Dev:Pseudo argument */
 754             if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
 755                 break;
 756 #endif
 757             if (PL_euid != PL_uid || PL_egid != PL_gid)
 758                 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
 759             if (!PL_e_script) {
 760                 PL_e_script = newSVpvn("",0);
 761                 filter_add(read_e_script, NULL);
 762             }
 763             if (*++s)
 764                 sv_catpv(PL_e_script, s);
 765             else if (argv[1]) {
 766                 sv_catpv(PL_e_script, argv[1]);
 767                 argc--,argv++;
 768             }
 769             else
 770                 Perl_croak(aTHX_ "No code specified for -e");
 771             sv_catpv(PL_e_script, "\n");
 772             break;
 773
 774         case 'I':       /* -I handled both here and in moreswitches() */
 775             forbid_setid("-I");
 776             if (!*++s && (s=argv[1]) != Nullch) {
 777                 argc--,argv++;
 778             }
 779             while (s && isSPACE(*s))
 780                 ++s;
 781             if (s && *s) {
 782                 char *e, *p;
 783                 for (e = s; *e && !isSPACE(*e); e++) ;
 784                 p = savepvn(s, e-s);
 785                 incpush(p, TRUE);
 786                 sv_catpv(sv,"-I");
 787                 sv_catpv(sv,p);
 788                 sv_catpv(sv," ");
 789                 Safefree(p);
 790             }   /* XXX else croak? */
 791             break;
 792         case 'P':
 793             forbid_setid("-P");
 794             PL_preprocess = TRUE;
 795             s++;
 796             goto reswitch;
 797         case 'S':
 798             forbid_setid("-S");
 799             dosearch = TRUE;
 800             s++;
 801             goto reswitch;
 802         case 'V':
 803             if (!PL_preambleav)
 804                 PL_preambleav = newAV();
 805             av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
 806             if (*++s != ':')  {
 807                 PL_Sv = newSVpv("print myconfig();",0);
 808 #ifdef VMS
 809                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
 810 #else
 811                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 812 #endif
 813                 sv_catpv(PL_Sv,"\"  Compile-time options:");
 814 #  ifdef DEBUGGING
 815                 sv_catpv(PL_Sv," DEBUGGING");
 816 #  endif
 817 #  ifdef MULTIPLICITY
 818                 sv_catpv(PL_Sv," MULTIPLICITY");
 819 #  endif
 820 #  ifdef USE_THREADS
 821                 sv_catpv(PL_Sv," USE_THREADS");
 822 #  endif
 823 #  ifdef PERL_OBJECT
 824                 sv_catpv(PL_Sv," PERL_OBJECT");
 825 #  endif
 826 #  ifdef PERL_IMPLICIT_CONTEXT
 827                 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
 828 #  endif
 829 #  ifdef PERL_IMPLICIT_SYS
 830                 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
 831 #  endif
 832                 sv_catpv(PL_Sv,"\\n\",");
 833
 834 #if defined(LOCAL_PATCH_COUNT)
 835                 if (LOCAL_PATCH_COUNT > 0) {
 836                     int i;
 837                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
 838                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
 839                         if (PL_localpatches[i])
 840                             Perl_sv_catpvf(aTHX_ PL_Sv,"q\"  \t%s\n\",",PL_localpatches[i]);
 841                     }
 842                 }
 843 #endif
 844                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
 845 #ifdef __DATE__
 846 #  ifdef __TIME__
 847                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 848 #  else
 849                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
 850 #  endif
 851 #endif
 852                 sv_catpv(PL_Sv, "; \
 853 $\"=\"\\n    \"; \
 854 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
 855 print \"  \\%ENV:\\n    @env\\n\" if @env; \
 856 print \"  \\@INC:\\n    @INC\\n\";");
 857             }
 858             else {
 859                 PL_Sv = newSVpv("config_vars(qw(",0);
 860                 sv_catpv(PL_Sv, ++s);
 861                 sv_catpv(PL_Sv, "))");
 862                 s += strlen(s);
 863             }
 864             av_push(PL_preambleav, PL_Sv);
 865             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
 866             goto reswitch;
 867         case 'x':
 868             PL_doextract = TRUE;
 869             s++;
 870             if (*s)
 871                 cddir = s;
 872             break;
 873         case 0:
 874             break;
 875         case '-':
 876             if (!*++s || isSPACE(*s)) {
 877                 argc--,argv++;
 878                 goto switch_end;
 879             }
 880             /* catch use of gnu style long options */
 881             if (strEQ(s, "version")) {
 882                 s = "v";
 883                 goto reswitch;
 884             }
 885             if (strEQ(s, "help")) {
 886                 s = "h";
 887                 goto reswitch;
 888             }
 889             s--;
 890             /* FALL THROUGH */
 891         default:
 892             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
 893         }
 894     }
 895   switch_end:
 896
 897     if (
 898 #ifndef SECURE_INTERNAL_GETENV
 899         !PL_tainting &&
 900 #endif
 901                         (s = PerlEnv_getenv("PERL5OPT"))) {
 902         while (isSPACE(*s))
 903             s++;
 904         if (*s == '-' && *(s+1) == 'T')
 905             PL_tainting = TRUE;
 906         else {
 907             while (s && *s) {
 908                 while (isSPACE(*s))
 909                     s++;
 910                 if (*s == '-') {
 911                     s++;
 912                     if (isSPACE(*s))
 913                         continue;
 914                 }
 915                 if (!*s)
 916                     break;
 917                 if (!strchr("DIMUdmw", *s))
 918                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
 919                 s = moreswitches(s);
 920             }
 921         }
 922     }
 923
 924     if (!scriptname)
 925         scriptname = argv[0];
 926     if (PL_e_script) {
 927         argc++,argv--;
 928         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
 929     }
 930     else if (scriptname == Nullch) {
 931 #ifdef MSDOS
 932         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
 933             moreswitches("h");
 934 #endif
 935         scriptname = "-";
 936     }
 937
 938     init_perllib();
 939
 940     open_script(scriptname,dosearch,sv,&fdscript);
 941
 942     validate_suid(validarg, scriptname,fdscript);
 943
 944 #if defined(SIGCHLD) || defined(SIGCLD)
 945     {
 946 #ifndef SIGCHLD
 947 #  define SIGCHLD SIGCLD
 948 #endif
 949         Sighandler_t sigstate = rsignal_state(SIGCHLD);
 950         if (sigstate == SIG_IGN) {
 951             if (ckWARN(WARN_SIGNAL))
 952                 Perl_warner(aTHX_ WARN_SIGNAL,
 953                             "Can't ignore signal CHLD, forcing to default");
 954             (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
 955         }
 956     }
 957 #endif
 958
 959 #ifdef MACOS_TRADITIONAL
 960     if (PL_doextract || gAlwaysExtract)
 961 #else
 962     if (PL_doextract) {
 963 #endif
 964         find_beginning();
 965         if (cddir && PerlDir_chdir(cddir) < 0)
 966             Perl_croak(aTHX_ "Can't chdir to %s",cddir);
 967     }
 968
 969     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
 970     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
 971     CvUNIQUE_on(PL_compcv);
 972
 973     PL_comppad = newAV();
 974     av_push(PL_comppad, Nullsv);
 975     PL_curpad = AvARRAY(PL_comppad);
 976     PL_comppad_name = newAV();
 977     PL_comppad_name_fill = 0;
 978     PL_min_intro_pending = 0;
 979     PL_padix = 0;
 980 #ifdef USE_THREADS
 981     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
 982     PL_curpad[0] = (SV*)newAV();
 983     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
 984     CvOWNER(PL_compcv) = 0;
 985     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
 986     MUTEX_INIT(CvMUTEXP(PL_compcv));
 987 #endif /* USE_THREADS */
 988
 989     comppadlist = newAV();
 990     AvREAL_off(comppadlist);
 991     av_store(comppadlist, 0, (SV*)PL_comppad_name);
 992     av_store(comppadlist, 1, (SV*)PL_comppad);
 993     CvPADLIST(PL_compcv) = comppadlist;
 994
 995     boot_core_UNIVERSAL();
 996     boot_core_xsutils();
 997
 998     if (xsinit)
 999         (*xsinit)(aTHXo);       /* in case linked C routines want magical variables */
1000 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1001     init_os_extras();
1002 #endif
1003
1004 #ifdef USE_SOCKS
1005     SOCKSinit(argv[0]);
1006 #endif
1007
1008     init_predump_symbols();
1009     /* init_postdump_symbols not currently designed to be called */
1010     /* more than once (ENV isn't cleared first, for example)     */
1011     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
1012     if (!PL_do_undump)
1013         init_postdump_symbols(argc,argv,env);
1014
1015     init_lexer();
1016
1017     /* now parse the script */
1018
1019     SETERRNO(0,SS$_NORMAL);
1020     PL_error_count = 0;
1021 #ifdef MACOS_TRADITIONAL
1022     if (gSyntaxError = (yyparse() || PL_error_count)) {
1023         if (PL_minus_c)
1024             Perl_croak(aTHX_ "%s had compilation errors.\n", MPWFileName(PL_origfilename));
1025         else {
1026             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1027                        MPWFileName(PL_origfilename));
1028         }
1029     }
1030 #else
1031     if (yyparse() || PL_error_count) {
1032         if (PL_minus_c)
1033             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1034         else {
1035             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1036                        PL_origfilename);
1037         }
1038     }
1039 #endif
1040     PL_curcop->cop_line = 0;
1041     PL_curstash = PL_defstash;
1042     PL_preprocess = FALSE;
1043     if (PL_e_script) {
1044         SvREFCNT_dec(PL_e_script);
1045         PL_e_script = Nullsv;
1046     }
1047
1048     /* now that script is parsed, we can modify record separator */
1049     SvREFCNT_dec(PL_rs);
1050     PL_rs = SvREFCNT_inc(PL_nrs);
1051     sv_setsv(get_sv("/", TRUE), PL_rs);
1052     if (PL_do_undump)
1053         my_unexec();
1054
1055     if (isWARN_ONCE)
1056         gv_check(PL_defstash);
1057
1058     LEAVE;
1059     FREETMPS;
1060
1061 #ifdef MYMALLOC
1062     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1063         dump_mstats("after compilation:");
1064 #endif
1065
1066     ENTER;
1067     PL_restartop = 0;
1068     return NULL;
1069 }
1070
1071 int
1072 perl_run(pTHXx)
1073 {
1074     dTHR;
1075     I32 oldscope;
1076     int ret;
1077     dJMPENV;
1078 #ifdef USE_THREADS
1079     dTHX;
1080 #endif
1081
1082     oldscope = PL_scopestack_ix;
1083
1084  redo_body:
1085     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1086     switch (ret) {
1087     case 1:
1088         cxstack_ix = -1;                /* start context stack again */
1089         goto redo_body;
1090     case 0:  /* normal completion */
1091     case 2:  /* my_exit() */
1092         while (PL_scopestack_ix > oldscope)
1093             LEAVE;
1094         FREETMPS;
1095         PL_curstash = PL_defstash;
1096         if (PL_endav && !PL_minus_c)
1097             call_list(oldscope, PL_endav);
1098 #ifdef MYMALLOC
1099         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1100             dump_mstats("after execution:  ");
1101 #endif
1102         return STATUS_NATIVE_EXPORT;
1103     case 3:
1104         if (PL_restartop) {
1105             POPSTACK_TO(PL_mainstack);
1106             goto redo_body;
1107         }
1108         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1109         FREETMPS;
1110         return 1;
1111     }
1112
1113     /* NOTREACHED */
1114     return 0;
1115 }
1116
1117 STATIC void *
1118 S_run_body(pTHX_ va_list args)
1119 {
1120     dTHR;
1121     I32 oldscope = va_arg(args, I32);
1122
1123     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1124                     PL_sawampersand ? "Enabling" : "Omitting"));
1125
1126     if (!PL_restartop) {
1127         DEBUG_x(dump_all());
1128         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1129         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1130                               PTR2UV(thr)));
1131
1132         if (PL_minus_c) {
1133 #ifdef MACOS_TRADITIONAL
1134             PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", MPWFileName(PL_origfilename));
1135 #else
1136             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1137 #endif
1138 my_exit(0);
1139         }
1140         if (PERLDB_SINGLE && PL_DBsingle)
1141             sv_setiv(PL_DBsingle, 1);
1142         if (PL_initav)
1143             call_list(oldscope, PL_initav);
1144     }
1145
1146     /* do it */
1147
1148     if (PL_restartop) {
1149         PL_op = PL_restartop;
1150         PL_restartop = 0;
1151         CALLRUNOPS(aTHX);
1152     }
1153     else if (PL_main_start) {
1154         CvDEPTH(PL_main_cv) = 1;
1155         PL_op = PL_main_start;
1156         CALLRUNOPS(aTHX);
1157     }
1158
1159     my_exit(0);
1160     /* NOTREACHED */
1161     return NULL;
1162 }
1163
1164 SV*
1165 Perl_get_sv(pTHX_ const char *name, I32 create)
1166 {
1167     GV *gv;
1168 #ifdef USE_THREADS
1169     if (name[1] == '\0' && !isALPHA(name[0])) {
1170         PADOFFSET tmp = find_threadsv(name);
1171         if (tmp != NOT_IN_PAD) {
1172             dTHR;
1173             return THREADSV(tmp);
1174         }
1175     }
1176 #endif /* USE_THREADS */
1177     gv = gv_fetchpv(name, create, SVt_PV);
1178     if (gv)
1179         return GvSV(gv);
1180     return Nullsv;
1181 }
1182
1183 AV*
1184 Perl_get_av(pTHX_ const char *name, I32 create)
1185 {
1186     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1187     if (create)
1188         return GvAVn(gv);
1189     if (gv)
1190         return GvAV(gv);
1191     return Nullav;
1192 }
1193
1194 HV*
1195 Perl_get_hv(pTHX_ const char *name, I32 create)
1196 {
1197     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1198     if (create)
1199         return GvHVn(gv);
1200     if (gv)
1201         return GvHV(gv);
1202     return Nullhv;
1203 }
1204
1205 CV*
1206 Perl_get_cv(pTHX_ const char *name, I32 create)
1207 {
1208     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1209     /* XXX unsafe for threads if eval_owner isn't held */
1210     /* XXX this is probably not what they think they're getting.
1211      * It has the same effect as "sub name;", i.e. just a forward
1212      * declaration! */
1213     if (create && !GvCVu(gv))
1214         return newSUB(start_subparse(FALSE, 0),
1215                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1216                       Nullop,
1217                       Nullop);
1218     if (gv)
1219         return GvCVu(gv);
1220     return Nullcv;
1221 }
1222
1223 /* Be sure to refetch the stack pointer after calling these routines. */
1224
1225 I32
1226 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1227
1228                         /* See G_* flags in cop.h */
1229                         /* null terminated arg list */
1230 {
1231     dSP;
1232
1233     PUSHMARK(SP);
1234     if (argv) {
1235         while (*argv) {
1236             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1237             argv++;
1238         }
1239         PUTBACK;
1240     }
1241     return call_pv(sub_name, flags);
1242 }
1243
1244 I32
1245 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1246                         /* name of the subroutine */
1247                         /* See G_* flags in cop.h */
1248 {
1249     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1250 }
1251
1252 I32
1253 Perl_call_method(pTHX_ const char *methname, I32 flags)
1254                         /* name of the subroutine */
1255                         /* See G_* flags in cop.h */
1256 {
1257     dSP;
1258     OP myop;
1259     if (!PL_op)
1260         PL_op = &myop;
1261     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1262     PUTBACK;
1263     pp_method();
1264         if(PL_op == &myop)
1265                 PL_op = Nullop;
1266     return call_sv(*PL_stack_sp--, flags);
1267 }
1268
1269 /* May be called with any of a CV, a GV, or an SV containing the name. */
1270 I32
1271 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1272
1273                         /* See G_* flags in cop.h */
1274 {
1275     dSP;
1276     LOGOP myop;         /* fake syntax tree node */
1277     I32 oldmark;
1278     I32 retval;
1279     I32 oldscope;
1280     bool oldcatch = CATCH_GET;
1281     int ret;
1282     OP* oldop = PL_op;
1283     dJMPENV;
1284
1285     if (flags & G_DISCARD) {
1286         ENTER;
1287         SAVETMPS;
1288     }
1289
1290     Zero(&myop, 1, LOGOP);
1291     myop.op_next = Nullop;
1292     if (!(flags & G_NOARGS))
1293         myop.op_flags |= OPf_STACKED;
1294     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1295                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1296                       OPf_WANT_SCALAR);
1297     SAVEOP();
1298     PL_op = (OP*)&myop;
1299
1300     EXTEND(PL_stack_sp, 1);
1301     *++PL_stack_sp = sv;
1302     oldmark = TOPMARK;
1303     oldscope = PL_scopestack_ix;
1304
1305     if (PERLDB_SUB && PL_curstash != PL_debstash
1306            /* Handle first BEGIN of -d. */
1307           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1308            /* Try harder, since this may have been a sighandler, thus
1309             * curstash may be meaningless. */
1310           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1311           && !(flags & G_NODEBUG))
1312         PL_op->op_private |= OPpENTERSUB_DB;
1313
1314     if (!(flags & G_EVAL)) {
1315         CATCH_SET(TRUE);
1316         call_xbody((OP*)&myop, FALSE);
1317         retval = PL_stack_sp - (PL_stack_base + oldmark);
1318         CATCH_SET(oldcatch);
1319     }
1320     else {
1321         cLOGOP->op_other = PL_op;
1322         PL_markstack_ptr--;
1323         /* we're trying to emulate pp_entertry() here */
1324         {
1325             register PERL_CONTEXT *cx;
1326             I32 gimme = GIMME_V;
1327
1328             ENTER;
1329             SAVETMPS;
1330
1331             push_return(PL_op->op_next);
1332             PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1333             PUSHEVAL(cx, 0, 0);
1334             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
1335
1336             PL_in_eval = EVAL_INEVAL;
1337             if (flags & G_KEEPERR)
1338                 PL_in_eval |= EVAL_KEEPERR;
1339             else
1340                 sv_setpv(ERRSV,"");
1341         }
1342         PL_markstack_ptr++;
1343
1344   redo_body:
1345         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1346                     (OP*)&myop, FALSE);
1347         switch (ret) {
1348         case 0:
1349             retval = PL_stack_sp - (PL_stack_base + oldmark);
1350             if (!(flags & G_KEEPERR))
1351                 sv_setpv(ERRSV,"");
1352             break;
1353         case 1:
1354             STATUS_ALL_FAILURE;
1355             /* FALL THROUGH */
1356         case 2:
1357             /* my_exit() was called */
1358             PL_curstash = PL_defstash;
1359             FREETMPS;
1360             if (PL_statusvalue)
1361                 Perl_croak(aTHX_ "Callback called exit");
1362             my_exit_jump();
1363             /* NOTREACHED */
1364         case 3:
1365             if (PL_restartop) {
1366                 PL_op = PL_restartop;
1367                 PL_restartop = 0;
1368                 goto redo_body;
1369             }
1370             PL_stack_sp = PL_stack_base + oldmark;
1371             if (flags & G_ARRAY)
1372                 retval = 0;
1373             else {
1374                 retval = 1;
1375                 *++PL_stack_sp = &PL_sv_undef;
1376             }
1377             break;
1378         }
1379
1380         if (PL_scopestack_ix > oldscope) {
1381             SV **newsp;
1382             PMOP *newpm;
1383             I32 gimme;
1384             register PERL_CONTEXT *cx;
1385             I32 optype;
1386
1387             POPBLOCK(cx,newpm);
1388             POPEVAL(cx);
1389             pop_return();
1390             PL_curpm = newpm;
1391             LEAVE;
1392         }
1393     }
1394
1395     if (flags & G_DISCARD) {
1396         PL_stack_sp = PL_stack_base + oldmark;
1397         retval = 0;
1398         FREETMPS;
1399         LEAVE;
1400     }
1401     PL_op = oldop;
1402     return retval;
1403 }
1404
1405 STATIC void *
1406 S_call_body(pTHX_ va_list args)
1407 {
1408     OP *myop = va_arg(args, OP*);
1409     int is_eval = va_arg(args, int);
1410
1411     call_xbody(myop, is_eval);
1412     return NULL;
1413 }
1414
1415 STATIC void
1416 S_call_xbody(pTHX_ OP *myop, int is_eval)
1417 {
1418     dTHR;
1419
1420     if (PL_op == myop) {
1421         if (is_eval)
1422             PL_op = Perl_pp_entereval(aTHX);
1423         else
1424             PL_op = Perl_pp_entersub(aTHX);
1425     }
1426     if (PL_op)
1427         CALLRUNOPS(aTHX);
1428 }
1429
1430 /* Eval a string. The G_EVAL flag is always assumed. */
1431
1432 I32
1433 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1434
1435                         /* See G_* flags in cop.h */
1436 {
1437     dSP;
1438     UNOP myop;          /* fake syntax tree node */
1439     I32 oldmark = SP - PL_stack_base;
1440     I32 retval;
1441     I32 oldscope;
1442     int ret;
1443     OP* oldop = PL_op;
1444     dJMPENV;
1445
1446     if (flags & G_DISCARD) {
1447         ENTER;
1448         SAVETMPS;
1449     }
1450
1451     SAVEOP();
1452     PL_op = (OP*)&myop;
1453     Zero(PL_op, 1, UNOP);
1454     EXTEND(PL_stack_sp, 1);
1455     *++PL_stack_sp = sv;
1456     oldscope = PL_scopestack_ix;
1457
1458     if (!(flags & G_NOARGS))
1459         myop.op_flags = OPf_STACKED;
1460     myop.op_next = Nullop;
1461     myop.op_type = OP_ENTEREVAL;
1462     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1463                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1464                       OPf_WANT_SCALAR);
1465     if (flags & G_KEEPERR)
1466         myop.op_flags |= OPf_SPECIAL;
1467
1468  redo_body:
1469     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1470                 (OP*)&myop, TRUE);
1471     switch (ret) {
1472     case 0:
1473         retval = PL_stack_sp - (PL_stack_base + oldmark);
1474         if (!(flags & G_KEEPERR))
1475             sv_setpv(ERRSV,"");
1476         break;
1477     case 1:
1478         STATUS_ALL_FAILURE;
1479         /* FALL THROUGH */
1480     case 2:
1481         /* my_exit() was called */
1482         PL_curstash = PL_defstash;
1483         FREETMPS;
1484         if (PL_statusvalue)
1485             Perl_croak(aTHX_ "Callback called exit");
1486         my_exit_jump();
1487         /* NOTREACHED */
1488     case 3:
1489         if (PL_restartop) {
1490             PL_op = PL_restartop;
1491             PL_restartop = 0;
1492             goto redo_body;
1493         }
1494         PL_stack_sp = PL_stack_base + oldmark;
1495         if (flags & G_ARRAY)
1496             retval = 0;
1497         else {
1498             retval = 1;
1499             *++PL_stack_sp = &PL_sv_undef;
1500         }
1501         break;
1502     }
1503
1504     if (flags & G_DISCARD) {
1505         PL_stack_sp = PL_stack_base + oldmark;
1506         retval = 0;
1507         FREETMPS;
1508         LEAVE;
1509     }
1510     PL_op = oldop;
1511     return retval;
1512 }
1513
1514 SV*
1515 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1516 {
1517     dSP;
1518     SV* sv = newSVpv(p, 0);
1519
1520     PUSHMARK(SP);
1521     eval_sv(sv, G_SCALAR);
1522     SvREFCNT_dec(sv);
1523
1524     SPAGAIN;
1525     sv = POPs;
1526     PUTBACK;
1527
1528     if (croak_on_error && SvTRUE(ERRSV)) {
1529         STRLEN n_a;
1530         Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1531     }
1532
1533     return sv;
1534 }
1535
1536 /* Require a module. */
1537
1538 void
1539 Perl_require_pv(pTHX_ const char *pv)
1540 {
1541     SV* sv;
1542     dSP;
1543     PUSHSTACKi(PERLSI_REQUIRE);
1544     PUTBACK;
1545     sv = sv_newmortal();
1546     sv_setpv(sv, "require '");
1547     sv_catpv(sv, pv);
1548     sv_catpv(sv, "'");
1549     eval_sv(sv, G_DISCARD);
1550     SPAGAIN;
1551     POPSTACK;
1552 }
1553
1554 void
1555 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1556 {
1557     register GV *gv;
1558
1559     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1560         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1561 }
1562
1563 STATIC void
1564 S_usage(pTHX_ char *name)               /* XXX move this out into a module ? */
1565 {
1566     /* This message really ought to be max 23 lines.
1567      * Removed -h because the user already knows that opton. Others? */
1568
1569     static char *usage_msg[] = {
1570 "-0[octal]       specify record separator (\\0, if no argument)",
1571 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1572 "-c              check syntax only (runs BEGIN and END blocks)",
1573 "-d[:debugger]   run program under debugger",
1574 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1575 "-e 'command'    one line of program (several -e's allowed, omit programfile)",
1576 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
1577 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
1578 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
1579 "-l[octal]       enable line ending processing, specifies line terminator",
1580 "-[mM][-]module  execute `use/no module...' before executing program",
1581 "-n              assume 'while (<>) { ... }' loop around program",
1582 "-p              assume loop like -n but print line also, like sed",
1583 "-P              run program through C preprocessor before compilation",
1584 "-s              enable rudimentary parsing for switches after programfile",
1585 "-S              look for programfile using PATH environment variable",
1586 "-T              enable tainting checks",
1587 "-u              dump core after parsing program",
1588 "-U              allow unsafe operations",
1589 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
1590 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
1591 "-w              enable many useful warnings (RECOMMENDED)",
1592 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1593 "\n",
1594 NULL
1595 };
1596     char **p = usage_msg;
1597
1598     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1599     while (*p)
1600         printf("\n  %s", *p++);
1601 }
1602
1603 /* This routine handles any switches that can be given during run */
1604
1605 char *
1606 Perl_moreswitches(pTHX_ char *s)
1607 {
1608     I32 numlen;
1609     U32 rschar;
1610
1611     switch (*s) {
1612     case '0':
1613     {
1614         dTHR;
1615         rschar = (U32)scan_oct(s, 4, &numlen);
1616         SvREFCNT_dec(PL_nrs);
1617         if (rschar & ~((U8)~0))
1618             PL_nrs = &PL_sv_undef;
1619         else if (!rschar && numlen >= 2)
1620             PL_nrs = newSVpvn("", 0);
1621         else {
1622             char ch = rschar;
1623             PL_nrs = newSVpvn(&ch, 1);
1624         }
1625         return s + numlen;
1626     }
1627     case 'F':
1628         PL_minus_F = TRUE;
1629         PL_splitstr = savepv(s + 1);
1630         s += strlen(s);
1631         return s;
1632     case 'a':
1633         PL_minus_a = TRUE;
1634         s++;
1635         return s;
1636     case 'c':
1637         PL_minus_c = TRUE;
1638         s++;
1639         return s;
1640     case 'd':
1641         forbid_setid("-d");
1642         s++;
1643         if (*s == ':' || *s == '=')  {
1644             my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1645             s += strlen(s);
1646         }
1647         if (!PL_perldb) {
1648             PL_perldb = PERLDB_ALL;
1649             init_debugger();
1650         }
1651         return s;
1652     case 'D':
1653     {
1654 #ifdef DEBUGGING
1655         forbid_setid("-D");
1656         if (isALPHA(s[1])) {
1657             static char debopts[] = "psltocPmfrxuLHXDS";
1658             char *d;
1659
1660             for (s++; *s && (d = strchr(debopts,*s)); s++)
1661                 PL_debug |= 1 << (d - debopts);
1662         }
1663         else {
1664             PL_debug = atoi(s+1);
1665             for (s++; isDIGIT(*s); s++) ;
1666         }
1667         PL_debug |= 0x80000000;
1668 #else
1669         dTHR;
1670         if (ckWARN_d(WARN_DEBUGGING))
1671             Perl_warner(aTHX_ WARN_DEBUGGING,
1672                    "Recompile perl with -DDEBUGGING to use -D switch\n");
1673         for (s++; isALNUM(*s); s++) ;
1674 #endif
1675         /*SUPPRESS 530*/
1676         return s;
1677     }
1678     case 'h':
1679         usage(PL_origargv[0]);
1680         PerlProc_exit(0);
1681     case 'i':
1682         if (PL_inplace)
1683             Safefree(PL_inplace);
1684         PL_inplace = savepv(s+1);
1685         /*SUPPRESS 530*/
1686         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1687         if (*s) {
1688             *s++ = '\0';
1689             if (*s == '-')      /* Additional switches on #! line. */
1690                 s++;
1691         }
1692         return s;
1693     case 'I':   /* -I handled both here and in parse_perl() */
1694         forbid_setid("-I");
1695         ++s;
1696         while (*s && isSPACE(*s))
1697             ++s;
1698         if (*s) {
1699             char *e, *p;
1700             for (e = s; *e && !isSPACE(*e); e++) ;
1701             p = savepvn(s, e-s);
1702             incpush(p, TRUE);
1703             Safefree(p);
1704             s = e;
1705         }
1706         else
1707             Perl_croak(aTHX_ "No space allowed after -I");
1708         return s;
1709     case 'l':
1710         PL_minus_l = TRUE;
1711         s++;
1712         if (PL_ors)
1713             Safefree(PL_ors);
1714         if (isDIGIT(*s)) {
1715             PL_ors = savepv("\n");
1716             PL_orslen = 1;
1717             *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1718             s += numlen;
1719         }
1720         else {
1721             dTHR;
1722             if (RsPARA(PL_nrs)) {
1723                 PL_ors = "\n\n";
1724                 PL_orslen = 2;
1725             }
1726             else
1727                 PL_ors = SvPV(PL_nrs, PL_orslen);
1728             PL_ors = savepvn(PL_ors, PL_orslen);
1729         }
1730         return s;
1731     case 'M':
1732         forbid_setid("-M");     /* XXX ? */
1733         /* FALL THROUGH */
1734     case 'm':
1735         forbid_setid("-m");     /* XXX ? */
1736         if (*++s) {
1737             char *start;
1738             SV *sv;
1739             char *use = "use ";
1740             /* -M-foo == 'no foo'       */
1741             if (*s == '-') { use = "no "; ++s; }
1742             sv = newSVpv(use,0);
1743             start = s;
1744             /* We allow -M'Module qw(Foo Bar)'  */
1745             while(isALNUM(*s) || *s==':') ++s;
1746             if (*s != '=') {
1747                 sv_catpv(sv, start);
1748                 if (*(start-1) == 'm') {
1749                     if (*s != '\0')
1750                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1751                     sv_catpv( sv, " ()");
1752                 }
1753             } else {
1754                 sv_catpvn(sv, start, s-start);
1755                 sv_catpv(sv, " split(/,/,q{");
1756                 sv_catpv(sv, ++s);
1757                 sv_catpv(sv,    "})");
1758             }
1759             s += strlen(s);
1760             if (PL_preambleav == NULL)
1761                 PL_preambleav = newAV();
1762             av_push(PL_preambleav, sv);
1763         }
1764         else
1765             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1766         return s;
1767     case 'n':
1768         PL_minus_n = TRUE;
1769         s++;
1770         return s;
1771     case 'p':
1772         PL_minus_p = TRUE;
1773         s++;
1774         return s;
1775     case 's':
1776         forbid_setid("-s");
1777         PL_doswitches = TRUE;
1778         s++;
1779         return s;
1780     case 'T':
1781         if (!PL_tainting)
1782             Perl_croak(aTHX_ "Too late for \"-T\" option");
1783         s++;
1784         return s;
1785     case 'u':
1786 #ifdef MACOS_TRADITIONAL
1787         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
1788 #endif
1789         PL_do_undump = TRUE;
1790         s++;
1791         return s;
1792     case 'U':
1793         PL_unsafe = TRUE;
1794         s++;
1795         return s;
1796     case 'v':
1797 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1798         printf("\nThis is perl, version %d.%03d_%02d built for %s",
1799             PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1800 #else
1801         printf("\nThis is perl, version %s built for %s",
1802                 PL_patchlevel, ARCHNAME);
1803 #endif
1804 #if defined(LOCAL_PATCH_COUNT)
1805         if (LOCAL_PATCH_COUNT > 0)
1806             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1807                 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1808 #endif
1809
1810         printf("\n\nCopyright 1987-1999, Larry Wall\n");
1811 #ifdef MACOS_TRADITIONAL
1812         fputs("Macintosh port Copyright 1991-1999, Matthias Neeracher\n", stdout);
1813 #endif
1814 #ifdef MSDOS
1815         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1816 #endif
1817 #ifdef DJGPP
1818         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1819         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1820 #endif
1821 #ifdef OS2
1822         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1823             "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1824 #endif
1825 #ifdef atarist
1826         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1827 #endif
1828 #ifdef __BEOS__
1829         printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1830 #endif
1831 #ifdef MPE
1832         printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1833 #endif
1834 #ifdef OEMVS
1835         printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1836 #endif
1837 #ifdef __VOS__
1838         printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1839 #endif
1840 #ifdef __OPEN_VM
1841         printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1842 #endif
1843 #ifdef POSIX_BC
1844         printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1845 #endif
1846 #ifdef __MINT__
1847         printf("MiNT port by Guido Flohr, 1997-1999\n");
1848 #endif
1849 #ifdef BINARY_BUILD_NOTICE
1850         BINARY_BUILD_NOTICE;
1851 #endif
1852         printf("\n\
1853 Perl may be copied only under the terms of either the Artistic License or the\n\
1854 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1855 Complete documentation for Perl, including FAQ lists, should be found on\n\
1856 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
1857 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1858         PerlProc_exit(0);
1859     case 'w':
1860         if (! (PL_dowarn & G_WARN_ALL_MASK))
1861             PL_dowarn |= G_WARN_ON;
1862         s++;
1863         return s;
1864     case 'W':
1865         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1866         PL_compiling.cop_warnings = WARN_ALL ;
1867         s++;
1868         return s;
1869     case 'X':
1870         PL_dowarn = G_WARN_ALL_OFF;
1871         PL_compiling.cop_warnings = WARN_NONE ;
1872         s++;
1873         return s;
1874     case '*':
1875     case ' ':
1876         if (s[1] == '-')        /* Additional switches on #! line. */
1877             return s+2;
1878         break;
1879     case '-':
1880     case 0:
1881 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1882     case '\r':
1883 #endif
1884     case '\n':
1885     case '\t':
1886         break;
1887 #ifdef ALTERNATE_SHEBANG
1888     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1889         break;
1890 #endif
1891     case 'P':
1892         if (PL_preprocess)
1893             return s+1;
1894         /* FALL THROUGH */
1895     default:
1896         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1897     }
1898     return Nullch;
1899 }
1900
1901 /* compliments of Tom Christiansen */
1902
1903 /* unexec() can be found in the Gnu emacs distribution */
1904 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1905
1906 void
1907 Perl_my_unexec(pTHX)
1908 {
1909 #ifdef UNEXEC
1910     SV*    prog;
1911     SV*    file;
1912     int    status = 1;
1913     extern int etext;
1914
1915     prog = newSVpv(BIN_EXP, 0);
1916     sv_catpv(prog, "/perl");
1917     file = newSVpv(PL_origfilename, 0);
1918     sv_catpv(file, ".perldump");
1919
1920     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1921     /* unexec prints msg to stderr in case of failure */
1922     PerlProc_exit(status);
1923 #else
1924 #  ifdef VMS
1925 #    include <lib$routines.h>
1926      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1927 #  else
1928     ABORT();            /* for use with undump */
1929 #  endif
1930 #endif
1931 }
1932
1933 /* initialize curinterp */
1934 STATIC void
1935 S_init_interp(pTHX)
1936 {
1937
1938 #ifdef PERL_OBJECT              /* XXX kludge */
1939 #define I_REINIT \
1940   STMT_START {                          \
1941     PL_chopset          = " \n-";       \
1942     PL_copline          = NOLINE;       \
1943     PL_curcop           = &PL_compiling;\
1944     PL_curcopdb         = NULL;         \
1945     PL_dbargs           = 0;            \
1946     PL_dumpindent       = 4;            \
1947     PL_laststatval      = -1;           \
1948     PL_laststype        = OP_STAT;      \
1949     PL_maxscream        = -1;           \
1950     PL_maxsysfd         = MAXSYSFD;     \
1951     PL_statname         = Nullsv;       \
1952     PL_tmps_floor       = -1;           \
1953     PL_tmps_ix          = -1;           \
1954     PL_op_mask          = NULL;         \
1955     PL_laststatval      = -1;           \
1956     PL_laststype        = OP_STAT;      \
1957     PL_mess_sv          = Nullsv;       \
1958     PL_splitstr         = " ";          \
1959     PL_generation       = 100;          \
1960     PL_exitlist         = NULL;         \
1961     PL_exitlistlen      = 0;            \
1962     PL_regindent        = 0;            \
1963     PL_in_clean_objs    = FALSE;        \
1964     PL_in_clean_all     = FALSE;        \
1965     PL_profiledata      = NULL;         \
1966     PL_rsfp             = Nullfp;       \
1967     PL_rsfp_filters     = Nullav;       \
1968     PL_dirty            = FALSE;        \
1969   } STMT_END
1970     I_REINIT;
1971 #else
1972 #  ifdef MULTIPLICITY
1973 #    define PERLVAR(var,type)
1974 #    define PERLVARA(var,n,type)
1975 #    if defined(PERL_IMPLICIT_CONTEXT)
1976 #      if defined(USE_THREADS)
1977 #        define PERLVARI(var,type,init)         PERL_GET_INTERP->var = init;
1978 #        define PERLVARIC(var,type,init)        PERL_GET_INTERP->var = init;
1979 #      else /* !USE_THREADS */
1980 #        define PERLVARI(var,type,init)         aTHX->var = init;
1981 #        define PERLVARIC(var,type,init)        aTHX->var = init;
1982 #      endif /* USE_THREADS */
1983 #    else
1984 #      define PERLVARI(var,type,init)   PERL_GET_INTERP->var = init;
1985 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
1986 #    endif
1987 #    include "intrpvar.h"
1988 #    ifndef USE_THREADS
1989 #      include "thrdvar.h"
1990 #    endif
1991 #    undef PERLVAR
1992 #    undef PERLVARA
1993 #    undef PERLVARI
1994 #    undef PERLVARIC
1995 #  else
1996 #    define PERLVAR(var,type)
1997 #    define PERLVARA(var,n,type)
1998 #    define PERLVARI(var,type,init)     PL_##var = init;
1999 #    define PERLVARIC(var,type,init)    PL_##var = init;
2000 #    include "intrpvar.h"
2001 #    ifndef USE_THREADS
2002 #      include "thrdvar.h"
2003 #    endif
2004 #    undef PERLVAR
2005 #    undef PERLVARA
2006 #    undef PERLVARI
2007 #    undef PERLVARIC
2008 #  endif
2009 #endif
2010
2011 #ifdef MACOS_TRADITIONAL
2012   /* In MacOS time() already returns values in excess of 2**31-1,
2013    * therefore we patch the integerness away. */
2014   PL_opargs[OP_TIME] &= ~OA_RETINTEGER;
2015 #endif
2016
2017 }
2018
2019 STATIC void
2020 S_init_main_stash(pTHX)
2021 {
2022     dTHR;
2023     GV *gv;
2024
2025     /* Note that strtab is a rather special HV.  Assumptions are made
2026        about not iterating on it, and not adding tie magic to it.
2027        It is properly deallocated in perl_destruct() */
2028     PL_strtab = newHV();
2029 #ifdef USE_THREADS
2030     MUTEX_INIT(&PL_strtab_mutex);
2031 #endif
2032     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
2033     hv_ksplit(PL_strtab, 512);
2034
2035     PL_curstash = PL_defstash = newHV();
2036     PL_curstname = newSVpvn("main",4);
2037     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2038     SvREFCNT_dec(GvHV(gv));
2039     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2040     SvREADONLY_on(gv);
2041     HvNAME(PL_defstash) = savepv("main");
2042     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2043     GvMULTI_on(PL_incgv);
2044     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2045     GvMULTI_on(PL_hintgv);
2046     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2047     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2048     GvMULTI_on(PL_errgv);
2049     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2050     GvMULTI_on(PL_replgv);
2051     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2052     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2053     sv_setpvn(ERRSV, "", 0);
2054     PL_curstash = PL_defstash;
2055     PL_compiling.cop_stash = PL_defstash;
2056     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2057     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2058     /* We must init $/ before switches are processed. */
2059     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2060 }
2061
2062 STATIC void
2063 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2064 {
2065     dTHR;
2066     register char *s;
2067
2068     *fdscript = -1;
2069
2070     if (PL_e_script) {
2071         PL_origfilename = savepv("-e");
2072     }
2073     else {
2074         /* if find_script() returns, it returns a malloc()-ed value */
2075         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2076
2077         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2078             char *s = scriptname + 8;
2079             *fdscript = atoi(s);
2080             while (isDIGIT(*s))
2081                 s++;
2082             if (*s) {
2083                 scriptname = savepv(s + 1);
2084                 Safefree(PL_origfilename);
2085                 PL_origfilename = scriptname;
2086             }
2087         }
2088     }
2089
2090     PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2091     if (strEQ(PL_origfilename,"-"))
2092         scriptname = "";
2093     if (*fdscript >= 0) {
2094         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2095 #if defined(HAS_FCNTL) && defined(F_SETFD)
2096         if (PL_rsfp)
2097             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2098 #endif
2099     }
2100     else if (PL_preprocess) {
2101         char *cpp_cfg = CPPSTDIN;
2102         SV *cpp = newSVpvn("",0);
2103         SV *cmd = NEWSV(0,0);
2104
2105         if (strEQ(cpp_cfg, "cppstdin"))
2106             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2107         sv_catpv(cpp, cpp_cfg);
2108
2109         sv_catpv(sv,"-I");
2110         sv_catpv(sv,PRIVLIB_EXP);
2111
2112 #ifdef MSDOS
2113         Perl_sv_setpvf(aTHX_ cmd, "\
2114 sed %s -e \"/^[^#]/b\" \
2115  -e \"/^#[      ]*include[      ]/b\" \
2116  -e \"/^#[      ]*define[       ]/b\" \
2117  -e \"/^#[      ]*if[   ]/b\" \
2118  -e \"/^#[      ]*ifdef[        ]/b\" \
2119  -e \"/^#[      ]*ifndef[       ]/b\" \
2120  -e \"/^#[      ]*else/b\" \
2121  -e \"/^#[      ]*elif[         ]/b\" \
2122  -e \"/^#[      ]*undef[        ]/b\" \
2123  -e \"/^#[      ]*endif/b\" \
2124  -e \"s/^#.*//\" \
2125  %s | %_ -C %_ %s",
2126           (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2127 #else
2128 #  ifdef __OPEN_VM
2129         Perl_sv_setpvf(aTHX_ cmd, "\
2130 %s %s -e '/^[^#]/b' \
2131  -e '/^#[       ]*include[      ]/b' \
2132  -e '/^#[       ]*define[       ]/b' \
2133  -e '/^#[       ]*if[   ]/b' \
2134  -e '/^#[       ]*ifdef[        ]/b' \
2135  -e '/^#[       ]*ifndef[       ]/b' \
2136  -e '/^#[       ]*else/b' \
2137  -e '/^#[       ]*elif[         ]/b' \
2138  -e '/^#[       ]*undef[        ]/b' \
2139  -e '/^#[       ]*endif/b' \
2140  -e 's/^[       ]*#.*//' \
2141  %s | %_ %_ %s",
2142 #  else
2143         Perl_sv_setpvf(aTHX_ cmd, "\
2144 %s %s -e '/^[^#]/b' \
2145  -e '/^#[       ]*include[      ]/b' \
2146  -e '/^#[       ]*define[       ]/b' \
2147  -e '/^#[       ]*if[   ]/b' \
2148  -e '/^#[       ]*ifdef[        ]/b' \
2149  -e '/^#[       ]*ifndef[       ]/b' \
2150  -e '/^#[       ]*else/b' \
2151  -e '/^#[       ]*elif[         ]/b' \
2152  -e '/^#[       ]*undef[        ]/b' \
2153  -e '/^#[       ]*endif/b' \
2154  -e 's/^[       ]*#.*//' \
2155  %s | %_ -C %_ %s",
2156 #  endif
2157 #ifdef LOC_SED
2158           LOC_SED,
2159 #else
2160           "sed",
2161 #endif
2162           (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2163 #endif
2164           scriptname, cpp, sv, CPPMINUS);
2165         PL_doextract = FALSE;
2166 #ifdef IAMSUID                          /* actually, this is caught earlier */
2167         if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
2168 #ifdef HAS_SETEUID
2169             (void)seteuid(PL_uid);              /* musn't stay setuid root */
2170 #else
2171 #ifdef HAS_SETREUID
2172             (void)setreuid((Uid_t)-1, PL_uid);
2173 #else
2174 #ifdef HAS_SETRESUID
2175             (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2176 #else
2177             PerlProc_setuid(PL_uid);
2178 #endif
2179 #endif
2180 #endif
2181             if (PerlProc_geteuid() != PL_uid)
2182                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2183         }
2184 #endif /* IAMSUID */
2185         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2186         SvREFCNT_dec(cmd);
2187         SvREFCNT_dec(cpp);
2188     }
2189     else if (!*scriptname) {
2190         forbid_setid("program input from stdin");
2191         PL_rsfp = PerlIO_stdin();
2192     }
2193     else {
2194         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2195 #if defined(HAS_FCNTL) && defined(F_SETFD)
2196         if (PL_rsfp)
2197             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2198 #endif
2199     }
2200     if (!PL_rsfp) {
2201 #ifdef DOSUID
2202 #ifndef IAMSUID         /* in case script is not readable before setuid */
2203         if (PL_euid &&
2204             PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2205             PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2206         {
2207             /* try again */
2208             PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2209             Perl_croak(aTHX_ "Can't do setuid\n");
2210         }
2211 #endif
2212 #endif
2213         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2214           SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2215     }
2216 }
2217
2218 /* Mention
2219  * I_SYSSTATVFS HAS_FSTATVFS
2220  * I_SYSMOUNT
2221  * I_STATFS     HAS_FSTATFS
2222  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2223  * here so that metaconfig picks them up. */
2224
2225 #ifdef IAMSUID
2226 STATIC int
2227 S_fd_on_nosuid_fs(pTHX_ int fd)
2228 {
2229     int check_okay = 0; /* able to do all the required sys/libcalls */
2230     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2231 /*
2232  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2233  * fstatvfs() is UNIX98.
2234  * fstatfs() is 4.3 BSD.
2235  * ustat()+getmnt() is pre-4.3 BSD.
2236  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2237  * an irrelevant filesystem while trying to reach the right one.
2238  */
2239
2240 #   ifdef HAS_FSTATVFS
2241     struct statvfs stfs;
2242     check_okay = fstatvfs(fd, &stfs) == 0;
2243     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2244 #   else
2245 #       ifdef PERL_MOUNT_NOSUID
2246 #           if defined(HAS_FSTATFS) && \
2247                defined(HAS_STRUCT_STATFS) && \
2248                defined(HAS_STRUCT_STATFS_F_FLAGS)
2249     struct statfs  stfs;
2250     check_okay = fstatfs(fd, &stfs)  == 0;
2251     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2252 #           else
2253 #               if defined(HAS_FSTAT) && \
2254                    defined(HAS_USTAT) && \
2255                    defined(HAS_GETMNT) && \
2256                    defined(HAS_STRUCT_FS_DATA) &&
2257                    defined(NOSTAT_ONE)
2258     struct stat fdst;
2259     if (fstat(fd, &fdst) == 0) {
2260         struct ustat us;
2261         if (ustat(fdst.st_dev, &us) == 0) {
2262             struct fs_data fsd;
2263             /* NOSTAT_ONE here because we're not examining fields which
2264              * vary between that case and STAT_ONE. */
2265             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2266                 size_t cmplen = sizeof(us.f_fname);
2267                 if (sizeof(fsd.fd_req.path) < cmplen)
2268                     cmplen = sizeof(fsd.fd_req.path);
2269                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2270                     fdst.st_dev == fsd.fd_req.dev) {
2271                         check_okay = 1;
2272                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2273                     }
2274                 }
2275             }
2276         }
2277     }
2278 #               endif /* fstat+ustat+getmnt */
2279 #           endif /* fstatfs */
2280 #       else
2281 #           if defined(HAS_GETMNTENT) && \
2282                defined(HAS_HASMNTOPT) && \
2283                defined(MNTOPT_NOSUID)
2284     FILE                *mtab = fopen("/etc/mtab", "r");
2285     struct mntent       *entry;
2286     struct stat         stb, fsb;
2287
2288     if (mtab && (fstat(fd, &stb) == 0)) {
2289         while (entry = getmntent(mtab)) {
2290             if (stat(entry->mnt_dir, &fsb) == 0
2291                 && fsb.st_dev == stb.st_dev)
2292             {
2293                 /* found the filesystem */
2294                 check_okay = 1;
2295                 if (hasmntopt(entry, MNTOPT_NOSUID))
2296                     on_nosuid = 1;
2297                 break;
2298             } /* A single fs may well fail its stat(). */
2299         }
2300     }
2301     if (mtab)
2302         fclose(mtab);
2303 #           endif /* getmntent+hasmntopt */
2304 #       endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2305 #   endif /* statvfs */
2306
2307     if (!check_okay)
2308         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2309     return on_nosuid;
2310 }
2311 #endif /* IAMSUID */
2312
2313 STATIC void
2314 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2315 {
2316     int which;
2317
2318     /* do we need to emulate setuid on scripts? */
2319
2320     /* This code is for those BSD systems that have setuid #! scripts disabled
2321      * in the kernel because of a security problem.  Merely defining DOSUID
2322      * in perl will not fix that problem, but if you have disabled setuid
2323      * scripts in the kernel, this will attempt to emulate setuid and setgid
2324      * on scripts that have those now-otherwise-useless bits set.  The setuid
2325      * root version must be called suidperl or sperlN.NNN.  If regular perl
2326      * discovers that it has opened a setuid script, it calls suidperl with
2327      * the same argv that it had.  If suidperl finds that the script it has
2328      * just opened is NOT setuid root, it sets the effective uid back to the
2329      * uid.  We don't just make perl setuid root because that loses the
2330      * effective uid we had before invoking perl, if it was different from the
2331      * uid.
2332      *
2333      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2334      * be defined in suidperl only.  suidperl must be setuid root.  The
2335      * Configure script will set this up for you if you want it.
2336      */
2337
2338 #ifdef DOSUID
2339     dTHR;
2340     char *s, *s2;
2341
2342     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2343         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2344     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2345         I32 len;
2346         STRLEN n_a;
2347
2348 #ifdef IAMSUID
2349 #ifndef HAS_SETREUID
2350         /* On this access check to make sure the directories are readable,
2351          * there is actually a small window that the user could use to make
2352          * filename point to an accessible directory.  So there is a faint
2353          * chance that someone could execute a setuid script down in a
2354          * non-accessible directory.  I don't know what to do about that.
2355          * But I don't think it's too important.  The manual lies when
2356          * it says access() is useful in setuid programs.
2357          */
2358         if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2359             Perl_croak(aTHX_ "Permission denied");
2360 #else
2361         /* If we can swap euid and uid, then we can determine access rights
2362          * with a simple stat of the file, and then compare device and
2363          * inode to make sure we did stat() on the same file we opened.
2364          * Then we just have to make sure he or she can execute it.
2365          */
2366         {
2367             struct stat tmpstatbuf;
2368
2369             if (
2370 #ifdef HAS_SETREUID
2371                 setreuid(PL_euid,PL_uid) < 0
2372 #else
2373 # if HAS_SETRESUID
2374                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2375 # endif
2376 #endif
2377                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2378                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
2379             if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2380                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
2381 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2382             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2383                 Perl_croak(aTHX_ "Permission denied");
2384 #endif
2385             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2386                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2387                 (void)PerlIO_close(PL_rsfp);
2388                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2389                     PerlIO_printf(PL_rsfp,
2390 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2391 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2392                         PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2393                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2394                         SvPVX(GvSV(PL_curcop->cop_filegv)),
2395                         PL_statbuf.st_uid, PL_statbuf.st_gid);
2396                     (void)PerlProc_pclose(PL_rsfp);
2397                 }
2398                 Perl_croak(aTHX_ "Permission denied\n");
2399             }
2400             if (
2401 #ifdef HAS_SETREUID
2402               setreuid(PL_uid,PL_euid) < 0
2403 #else
2404 # if defined(HAS_SETRESUID)
2405               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2406 # endif
2407 #endif
2408               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2409                 Perl_croak(aTHX_ "Can't reswap uid and euid");
2410             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2411                 Perl_croak(aTHX_ "Permission denied\n");
2412         }
2413 #endif /* HAS_SETREUID */
2414 #endif /* IAMSUID */
2415
2416         if (!S_ISREG(PL_statbuf.st_mode))
2417             Perl_croak(aTHX_ "Permission denied");
2418         if (PL_statbuf.st_mode & S_IWOTH)
2419             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2420         PL_doswitches = FALSE;          /* -s is insecure in suid */
2421         PL_curcop->cop_line++;
2422         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2423           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2424             Perl_croak(aTHX_ "No #! line");
2425         s = SvPV(PL_linestr,n_a)+2;
2426         if (*s == ' ') s++;
2427         while (!isSPACE(*s)) s++;
2428         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
2429                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2430         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2431             Perl_croak(aTHX_ "Not a perl script");
2432         while (*s == ' ' || *s == '\t') s++;
2433         /*
2434          * #! arg must be what we saw above.  They can invoke it by
2435          * mentioning suidperl explicitly, but they may not add any strange
2436          * arguments beyond what #! says if they do invoke suidperl that way.
2437          */
2438         len = strlen(validarg);
2439         if (strEQ(validarg," PHOOEY ") ||
2440             strnNE(s,validarg,len) || !isSPACE(s[len]))
2441             Perl_croak(aTHX_ "Args must match #! line");
2442
2443 #ifndef IAMSUID
2444         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2445             PL_euid == PL_statbuf.st_uid)
2446             if (!PL_do_undump)
2447                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2448 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2449 #endif /* IAMSUID */
2450
2451         if (PL_euid) {  /* oops, we're not the setuid root perl */
2452             (void)PerlIO_close(PL_rsfp);
2453 #ifndef IAMSUID
2454             /* try again */
2455             PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2456 #endif
2457             Perl_croak(aTHX_ "Can't do setuid\n");
2458         }
2459
2460         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2461 #ifdef HAS_SETEGID
2462             (void)setegid(PL_statbuf.st_gid);
2463 #else
2464 #ifdef HAS_SETREGID
2465            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2466 #else
2467 #ifdef HAS_SETRESGID
2468            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2469 #else
2470             PerlProc_setgid(PL_statbuf.st_gid);
2471 #endif
2472 #endif
2473 #endif
2474             if (PerlProc_getegid() != PL_statbuf.st_gid)
2475                 Perl_croak(aTHX_ "Can't do setegid!\n");
2476         }
2477         if (PL_statbuf.st_mode & S_ISUID) {
2478             if (PL_statbuf.st_uid != PL_euid)
2479 #ifdef HAS_SETEUID
2480                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2481 #else
2482 #ifdef HAS_SETREUID
2483                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2484 #else
2485 #ifdef HAS_SETRESUID
2486                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2487 #else
2488                 PerlProc_setuid(PL_statbuf.st_uid);
2489 #endif
2490 #endif
2491 #endif
2492             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2493                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2494         }
2495         else if (PL_uid) {                      /* oops, mustn't run as root */
2496 #ifdef HAS_SETEUID
2497           (void)seteuid((Uid_t)PL_uid);
2498 #else
2499 #ifdef HAS_SETREUID
2500           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2501 #else
2502 #ifdef HAS_SETRESUID
2503           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2504 #else
2505           PerlProc_setuid((Uid_t)PL_uid);
2506 #endif
2507 #endif
2508 #endif
2509             if (PerlProc_geteuid() != PL_uid)
2510                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2511         }
2512         init_ids();
2513         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2514             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
2515     }
2516 #ifdef IAMSUID
2517     else if (PL_preprocess)
2518         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2519     else if (fdscript >= 0)
2520         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2521     else
2522         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2523
2524     /* We absolutely must clear out any saved ids here, so we */
2525     /* exec the real perl, substituting fd script for scriptname. */
2526     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2527     PerlIO_rewind(PL_rsfp);
2528     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2529     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2530     if (!PL_origargv[which])
2531         Perl_croak(aTHX_ "Permission denied");
2532     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2533                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2534 #if defined(HAS_FCNTL) && defined(F_SETFD)
2535     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
2536 #endif
2537     PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2538     Perl_croak(aTHX_ "Can't do setuid\n");
2539 #endif /* IAMSUID */
2540 #else /* !DOSUID */
2541     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
2542 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2543         dTHR;
2544         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
2545         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2546             ||
2547             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2548            )
2549             if (!PL_do_undump)
2550                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2551 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2552 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2553         /* not set-id, must be wrapped */
2554     }
2555 #endif /* DOSUID */
2556 }
2557
2558 STATIC void
2559 S_find_beginning(pTHX)
2560 {
2561     register char *s, *s2;
2562
2563     /* skip forward in input to the real script? */
2564
2565     forbid_setid("-x");
2566 #ifdef MACOS_TRADITIONAL
2567     /* Since the Mac OS does not honor !# arguments for us,
2568      * we do it ourselves. */
2569     while (PL_doextract || gAlwaysExtract) {
2570         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2571             if (!gAlwaysExtract)
2572                 Perl_croak(aTHX_ "No Perl script found in input\n");
2573
2574             if (PL_doextract)           /* require explicit override ? */
2575                 if (!OverrideExtract(PL_origfilename))
2576                     Perl_croak(aTHX_ "User aborted script\n");
2577                 else
2578                     PL_doextract = FALSE;
2579
2580             /* Pater peccavi, file does not have #! */
2581             PerlIO_rewind(PL_rsfp);
2582
2583             break;
2584         }
2585 #else
2586     while (PL_doextract) {
2587         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2588             Perl_croak(aTHX_ "No Perl script found in input\n");
2589 #endif
2590         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2591             PerlIO_ungetc(PL_rsfp, '\n');       /* to keep line count right */
2592             PL_doextract = FALSE;
2593             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2594             s2 = s;
2595             while (*s == ' ' || *s == '\t') s++;
2596             if (*s++ == '-') {
2597                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2598                 if (strnEQ(s2-4,"perl",4))
2599                     /*SUPPRESS 530*/
2600                     while (s = moreswitches(s)) ;
2601             }
2602         }
2603     }
2604 }
2605
2606
2607 STATIC void
2608 S_init_ids(pTHX)
2609 {
2610     PL_uid = PerlProc_getuid();
2611     PL_euid = PerlProc_geteuid();
2612     PL_gid = PerlProc_getgid();
2613     PL_egid = PerlProc_getegid();
2614 #ifdef VMS
2615     PL_uid |= PL_gid << 16;
2616     PL_euid |= PL_egid << 16;
2617 #endif
2618     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2619 }
2620
2621 STATIC void
2622 S_forbid_setid(pTHX_ char *s)
2623 {
2624     if (PL_euid != PL_uid)
2625         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2626     if (PL_egid != PL_gid)
2627         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2628 }
2629
2630 void
2631 Perl_init_debugger(pTHX)
2632 {
2633     dTHR;
2634     HV *ostash = PL_curstash;
2635
2636     PL_curstash = PL_debstash;
2637     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2638     AvREAL_off(PL_dbargs);
2639     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2640     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2641     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2642     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2643     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2644     sv_setiv(PL_DBsingle, 0);
2645     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2646     sv_setiv(PL_DBtrace, 0);
2647     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2648     sv_setiv(PL_DBsignal, 0);
2649     PL_curstash = ostash;
2650 }
2651
2652 #ifndef STRESS_REALLOC
2653 #define REASONABLE(size) (size)
2654 #else
2655 #define REASONABLE(size) (1) /* unreasonable */
2656 #endif
2657
2658 void
2659 Perl_init_stacks(pTHX)
2660 {
2661     /* start with 128-item stack and 8K cxstack */
2662     PL_curstackinfo = new_stackinfo(REASONABLE(128),
2663                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2664     PL_curstackinfo->si_type = PERLSI_MAIN;
2665     PL_curstack = PL_curstackinfo->si_stack;
2666     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
2667
2668     PL_stack_base = AvARRAY(PL_curstack);
2669     PL_stack_sp = PL_stack_base;
2670     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2671
2672     New(50,PL_tmps_stack,REASONABLE(128),SV*);
2673     PL_tmps_floor = -1;
2674     PL_tmps_ix = -1;
2675     PL_tmps_max = REASONABLE(128);
2676
2677     New(54,PL_markstack,REASONABLE(32),I32);
2678     PL_markstack_ptr = PL_markstack;
2679     PL_markstack_max = PL_markstack + REASONABLE(32);
2680
2681     SET_MARKBASE;
2682
2683     New(54,PL_scopestack,REASONABLE(32),I32);
2684     PL_scopestack_ix = 0;
2685     PL_scopestack_max = REASONABLE(32);
2686
2687     New(54,PL_savestack,REASONABLE(128),ANY);
2688     PL_savestack_ix = 0;
2689     PL_savestack_max = REASONABLE(128);
2690
2691     New(54,PL_retstack,REASONABLE(16),OP*);
2692     PL_retstack_ix = 0;
2693     PL_retstack_max = REASONABLE(16);
2694 }
2695
2696 #undef REASONABLE
2697
2698 STATIC void
2699 S_nuke_stacks(pTHX)
2700 {
2701     dTHR;
2702     while (PL_curstackinfo->si_next)
2703         PL_curstackinfo = PL_curstackinfo->si_next;
2704     while (PL_curstackinfo) {
2705         PERL_SI *p = PL_curstackinfo->si_prev;
2706         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2707         Safefree(PL_curstackinfo->si_cxstack);
2708         Safefree(PL_curstackinfo);
2709         PL_curstackinfo = p;
2710     }
2711     Safefree(PL_tmps_stack);
2712     Safefree(PL_markstack);
2713     Safefree(PL_scopestack);
2714     Safefree(PL_savestack);
2715     Safefree(PL_retstack);
2716 }
2717
2718 #ifndef PERL_OBJECT
2719 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2720 #endif
2721
2722 STATIC void
2723 S_init_lexer(pTHX)
2724 {
2725 #ifdef PERL_OBJECT
2726         PerlIO *tmpfp;
2727 #endif
2728     tmpfp = PL_rsfp;
2729     PL_rsfp = Nullfp;
2730     lex_start(PL_linestr);
2731     PL_rsfp = tmpfp;
2732     PL_subname = newSVpvn("main",4);
2733 }
2734
2735 STATIC void
2736 S_init_predump_symbols(pTHX)
2737 {
2738     dTHR;
2739     GV *tmpgv;
2740     GV *othergv;
2741     IO *io;
2742
2743     sv_setpvn(get_sv("\"", TRUE), " ", 1);
2744     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2745     GvMULTI_on(PL_stdingv);
2746     io = GvIOp(PL_stdingv);
2747     IoIFP(io) = PerlIO_stdin();
2748     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2749     GvMULTI_on(tmpgv);
2750     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2751
2752     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2753     GvMULTI_on(tmpgv);
2754     io = GvIOp(tmpgv);
2755     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2756     setdefout(tmpgv);
2757     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2758     GvMULTI_on(tmpgv);
2759     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2760
2761     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2762     GvMULTI_on(PL_stderrgv);
2763     io = GvIOp(PL_stderrgv);
2764     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2765     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2766     GvMULTI_on(tmpgv);
2767     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2768
2769     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
2770
2771     if (PL_osname)
2772         Safefree(PL_osname);
2773     PL_osname = savepv(OSNAME);
2774 }
2775
2776 STATIC void
2777 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2778 {
2779     dTHR;
2780     char *s;
2781     SV *sv;
2782     GV* tmpgv;
2783
2784     argc--,argv++;      /* skip name of script */
2785     if (PL_doswitches) {
2786         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2787             if (!argv[0][1])
2788                 break;
2789             if (argv[0][1] == '-') {
2790                 argc--,argv++;
2791                 break;
2792             }
2793             if (s = strchr(argv[0], '=')) {
2794                 *s++ = '\0';
2795                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2796             }
2797             else
2798                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2799         }
2800     }
2801     PL_toptarget = NEWSV(0,0);
2802     sv_upgrade(PL_toptarget, SVt_PVFM);
2803     sv_setpvn(PL_toptarget, "", 0);
2804     PL_bodytarget = NEWSV(0,0);
2805     sv_upgrade(PL_bodytarget, SVt_PVFM);
2806     sv_setpvn(PL_bodytarget, "", 0);
2807     PL_formtarget = PL_bodytarget;
2808
2809     TAINT;
2810     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2811 #ifdef MACOS_TRADITIONAL
2812         sv_setpv(GvSV(tmpgv),MPWFileName(PL_origfilename));
2813         /* $0 is not majick on a Mac */
2814 #else
2815         sv_setpv(GvSV(tmpgv),PL_origfilename);
2816         magicname("0", "0", 1);
2817 #endif
2818     }
2819     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2820 #ifdef OS2
2821         sv_setpv(GvSV(tmpgv), os2_execname());
2822 #else
2823         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2824 #endif
2825     if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2826         GvMULTI_on(PL_argvgv);
2827         (void)gv_AVadd(PL_argvgv);
2828         av_clear(GvAVn(PL_argvgv));
2829         for (; argc > 0; argc--,argv++) {
2830             av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2831         }
2832     }
2833     if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2834         HV *hv;
2835         GvMULTI_on(PL_envgv);
2836         hv = GvHVn(PL_envgv);
2837         hv_magic(hv, PL_envgv, 'E');
2838 #if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
2839         /* Note that if the supplied env parameter is actually a copy
2840            of the global environ then it may now point to free'd memory
2841            if the environment has been modified since. To avoid this
2842            problem we treat env==NULL as meaning 'use the default'
2843         */
2844         if (!env)
2845             env = environ;
2846         if (env != environ)
2847             environ[0] = Nullch;
2848         for (; *env; env++) {
2849             if (!(s = strchr(*env,'=')))
2850                 continue;
2851             *s++ = '\0';
2852 #if defined(MSDOS)
2853             (void)strupr(*env);
2854 #endif
2855             sv = newSVpv(s--,0);
2856             (void)hv_store(hv, *env, s - *env, sv, 0);
2857             *s = '=';
2858 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2859             /* Sins of the RTL. See note in my_setenv(). */
2860             (void)PerlEnv_putenv(savepv(*env));
2861 #endif
2862         }
2863 #endif
2864 #ifdef DYNAMIC_ENV_FETCH
2865         HvNAME(hv) = savepv(ENV_HV_NAME);
2866 #endif
2867     }
2868     TAINT_NOT;
2869     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2870         sv_setiv(GvSV(tmpgv), (IV)getpid());
2871 }
2872
2873 STATIC void
2874 S_init_perllib(pTHX)
2875 {
2876     char *s;
2877     if (!PL_tainting) {
2878 #ifndef VMS
2879         s = PerlEnv_getenv("PERL5LIB");
2880         if (s)
2881             incpush(s, TRUE);
2882         else
2883             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2884 #else /* VMS */
2885         /* Treat PERL5?LIB as a possible search list logical name -- the
2886          * "natural" VMS idiom for a Unix path string.  We allow each
2887          * element to be a set of |-separated directories for compatibility.
2888          */
2889         char buf[256];
2890         int idx = 0;
2891         if (my_trnlnm("PERL5LIB",buf,0))
2892             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2893         else
2894             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2895 #endif /* VMS */
2896     }
2897
2898 /* Use the ~-expanded versions of APPLLIB (undocumented),
2899     ARCHLIB PRIVLIB SITEARCH and SITELIB
2900 */
2901 #ifdef APPLLIB_EXP
2902     incpush(APPLLIB_EXP, TRUE);
2903 #endif
2904
2905 #ifdef ARCHLIB_EXP
2906     incpush(ARCHLIB_EXP, FALSE);
2907 #endif
2908 #ifdef MACOS_TRADITIONAL
2909     {
2910         struct stat tmpstatbuf;
2911         SV * privdir = NEWSV(55, 0);
2912         char * macperl = getenv("MACPERL") || "";
2913
2914         Perl_sv_setpvf(privdir, "%slib:", macperl);
2915         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
2916             incpush(SvPVX(privdir), TRUE);
2917         Perl_sv_setpvf(privdir, "%ssite_perl:", macperl);
2918         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
2919             incpush(SvPVX(privdir), TRUE);
2920
2921         SvREFCNT_dec(privdir);
2922     }
2923     if (!PL_tainting)
2924         incpush(":", FALSE);
2925 #else
2926 #ifndef PRIVLIB_EXP
2927 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2928 #endif
2929 #if defined(WIN32)
2930     incpush(PRIVLIB_EXP, TRUE);
2931 #else
2932     incpush(PRIVLIB_EXP, FALSE);
2933 #endif
2934
2935 #ifdef SITEARCH_EXP
2936     incpush(SITEARCH_EXP, FALSE);
2937 #endif
2938 #ifdef SITELIB_EXP
2939 #if defined(WIN32)
2940     incpush(SITELIB_EXP, TRUE);
2941 #else
2942     incpush(SITELIB_EXP, FALSE);
2943 #endif
2944 #endif
2945 #if defined(PERL_VENDORLIB_EXP)
2946 #if defined(WIN32)
2947     incpush(PERL_VENDORLIB_EXP, TRUE);
2948 #else
2949     incpush(PERL_VENDORLIB_EXP, FALSE);
2950 #endif
2951 #endif
2952     if (!PL_tainting)
2953         incpush(".", FALSE);
2954 #endif /* MACOS_TRADITIONAL */
2955 }
2956
2957 #if defined(MACOS_TRADITIONAL)
2958 #      define PERLLIB_SEP ','
2959 #else
2960 #  if defined(DOSISH)
2961 #      define PERLLIB_SEP ';'
2962 #  else
2963 #    if defined(VMS)
2964 #      define PERLLIB_SEP '|'
2965 #    else
2966 #      define PERLLIB_SEP ':'
2967 #    endif
2968 #  endif
2969 #endif
2970 #ifndef PERLLIB_MANGLE
2971 #    define PERLLIB_MANGLE(s,n) (s)
2972 #endif
2973
2974 STATIC void
2975 S_incpush(pTHX_ char *p, int addsubdirs)
2976 {
2977     SV *subdir = Nullsv;
2978
2979     if (!p)
2980         return;
2981
2982     if (addsubdirs) {
2983         subdir = sv_newmortal();
2984         if (!PL_archpat_auto) {
2985             STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2986                           + sizeof("//auto"));
2987             New(55, PL_archpat_auto, len, char);
2988 #ifdef MACOS_TRADITIONAL
2989             sprintf(PL_archpat_auto, "%s:%s:auto:", ARCHNAME, PL_patchlevel);
2990 #else
2991             sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2992 #endif
2993 #ifdef VMS
2994         for (len = sizeof(ARCHNAME) + 2;
2995              PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2996                 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2997 #endif
2998         }
2999     }
3000
3001     /* Break at all separators */
3002     while (p && *p) {
3003         SV *libdir = NEWSV(55,0);
3004         char *s;
3005
3006         /* skip any consecutive separators */
3007         while ( *p == PERLLIB_SEP ) {
3008             /* Uncomment the next line for PATH semantics */
3009             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3010             p++;
3011         }
3012
3013         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3014             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3015                       (STRLEN)(s - p));
3016             p = s + 1;
3017         }
3018         else {
3019             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3020             p = Nullch; /* break out */
3021         }
3022 #ifdef MACOS_TRADITIONAL
3023         if (!strchr(SvPVX(libdir), ':'))
3024             sv_insert(libdir, 0, 0, ":", 1);
3025         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3026             sv_catpv(libdir, ":");
3027 #endif
3028
3029         /*
3030          * BEFORE pushing libdir onto @INC we may first push version- and
3031          * archname-specific sub-directories.
3032          */
3033         if (addsubdirs) {
3034             struct stat tmpstatbuf;
3035 #ifdef VMS
3036             char *unix;
3037             STRLEN len;
3038
3039             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3040                 len = strlen(unix);
3041                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3042                 sv_usepvn(libdir,unix,len);
3043             }
3044             else
3045                 PerlIO_printf(Perl_error_log,
3046                               "Failed to unixify @INC element \"%s\"\n",
3047                               SvPV(libdir,len));
3048 #endif
3049             /* .../archname/version if -d .../archname/version/auto */
3050             sv_setsv(subdir, libdir);
3051             sv_catpv(subdir, PL_archpat_auto);
3052             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3053                   S_ISDIR(tmpstatbuf.st_mode))
3054                 av_push(GvAVn(PL_incgv),
3055                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3056
3057             /* .../archname if -d .../archname/auto */
3058             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3059                       strlen(PL_patchlevel) + 1, "", 0);
3060             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3061                   S_ISDIR(tmpstatbuf.st_mode))
3062                 av_push(GvAVn(PL_incgv),
3063                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3064         }
3065
3066         /* finally push this lib directory on the end of @INC */
3067         av_push(GvAVn(PL_incgv), libdir);
3068     }
3069 }
3070
3071 #ifdef USE_THREADS
3072 STATIC struct perl_thread *
3073 S_init_main_thread(pTHX)
3074 {
3075 #if !defined(PERL_IMPLICIT_CONTEXT)
3076     struct perl_thread *thr;
3077 #endif
3078     XPV *xpv;
3079
3080     Newz(53, thr, 1, struct perl_thread);
3081     PL_curcop = &PL_compiling;
3082     thr->interp = PERL_GET_INTERP;
3083     thr->cvcache = newHV();
3084     thr->threadsv = newAV();
3085     /* thr->threadsvp is set when find_threadsv is called */
3086     thr->specific = newAV();
3087     thr->flags = THRf_R_JOINABLE;
3088     MUTEX_INIT(&thr->mutex);
3089     /* Handcraft thrsv similarly to mess_sv */
3090     New(53, PL_thrsv, 1, SV);
3091     Newz(53, xpv, 1, XPV);
3092     SvFLAGS(PL_thrsv) = SVt_PV;
3093     SvANY(PL_thrsv) = (void*)xpv;
3094     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3095     SvPVX(PL_thrsv) = (char*)thr;
3096     SvCUR_set(PL_thrsv, sizeof(thr));
3097     SvLEN_set(PL_thrsv, sizeof(thr));
3098     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3099     thr->oursv = PL_thrsv;
3100     PL_chopset = " \n-";
3101     PL_dumpindent = 4;
3102
3103     MUTEX_LOCK(&PL_threads_mutex);
3104     PL_nthreads++;
3105     thr->tid = 0;
3106     thr->next = thr;
3107     thr->prev = thr;
3108     MUTEX_UNLOCK(&PL_threads_mutex);
3109
3110 #ifdef HAVE_THREAD_INTERN
3111     Perl_init_thread_intern(thr);
3112 #endif
3113
3114 #ifdef SET_THREAD_SELF
3115     SET_THREAD_SELF(thr);
3116 #else
3117     thr->self = pthread_self();
3118 #endif /* SET_THREAD_SELF */
3119     SET_THR(thr);
3120
3121     /*
3122      * These must come after the SET_THR because sv_setpvn does
3123      * SvTAINT and the taint fields require dTHR.
3124      */
3125     PL_toptarget = NEWSV(0,0);
3126     sv_upgrade(PL_toptarget, SVt_PVFM);
3127     sv_setpvn(PL_toptarget, "", 0);
3128     PL_bodytarget = NEWSV(0,0);
3129     sv_upgrade(PL_bodytarget, SVt_PVFM);
3130     sv_setpvn(PL_bodytarget, "", 0);
3131     PL_formtarget = PL_bodytarget;
3132     thr->errsv = newSVpvn("", 0);
3133     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3134
3135     PL_maxscream = -1;
3136     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3137     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3138     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3139     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3140     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3141     PL_regindent = 0;
3142     PL_reginterp_cnt = 0;
3143
3144     return thr;
3145 }
3146 #endif /* USE_THREADS */
3147
3148 void
3149 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3150 {
3151     dTHR;
3152     SV *atsv = ERRSV;
3153     line_t oldline = PL_curcop->cop_line;
3154     CV *cv;
3155     STRLEN len;
3156     int ret;
3157     dJMPENV;
3158
3159     while (AvFILL(paramList) >= 0) {
3160         cv = (CV*)av_shift(paramList);
3161         SAVEFREESV(cv);
3162         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3163         switch (ret) {
3164         case 0:
3165             (void)SvPV(atsv, len);
3166             if (len) {
3167                 PL_curcop = &PL_compiling;
3168                 PL_curcop->cop_line = oldline;
3169                 if (paramList == PL_beginav)
3170                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3171                 else
3172                     sv_catpv(atsv, "END failed--cleanup aborted");
3173                 while (PL_scopestack_ix > oldscope)
3174                     LEAVE;
3175                 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3176             }
3177             break;
3178         case 1:
3179             STATUS_ALL_FAILURE;
3180             /* FALL THROUGH */
3181         case 2:
3182             /* my_exit() was called */
3183             while (PL_scopestack_ix > oldscope)
3184                 LEAVE;
3185             FREETMPS;
3186             PL_curstash = PL_defstash;
3187             if (PL_endav && !PL_minus_c)
3188                 call_list(oldscope, PL_endav);
3189             PL_curcop = &PL_compiling;
3190             PL_curcop->cop_line = oldline;
3191             if (PL_statusvalue) {
3192                 if (paramList == PL_beginav)
3193                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3194                 else
3195                     Perl_croak(aTHX_ "END failed--cleanup aborted");
3196             }
3197             my_exit_jump();
3198             /* NOTREACHED */
3199         case 3:
3200             if (PL_restartop) {
3201                 PL_curcop = &PL_compiling;
3202                 PL_curcop->cop_line = oldline;
3203                 JMPENV_JUMP(3);
3204             }
3205             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3206             FREETMPS;
3207             break;
3208         }
3209     }
3210 }
3211
3212 STATIC void *
3213 S_call_list_body(pTHX_ va_list args)
3214 {
3215     dTHR;
3216     CV *cv = va_arg(args, CV*);
3217
3218     PUSHMARK(PL_stack_sp);
3219     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3220     return NULL;
3221 }
3222
3223 void
3224 Perl_my_exit(pTHX_ U32 status)
3225 {
3226     dTHR;
3227
3228     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3229                           thr, (unsigned long) status));
3230     switch (status) {
3231     case 0:
3232         STATUS_ALL_SUCCESS;
3233         break;
3234     case 1:
3235         STATUS_ALL_FAILURE;
3236         break;
3237     default:
3238         STATUS_NATIVE_SET(status);
3239         break;
3240     }
3241     my_exit_jump();
3242 }
3243
3244 void
3245 Perl_my_failure_exit(pTHX)
3246 {
3247 #ifdef VMS
3248     if (vaxc$errno & 1) {
3249         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3250             STATUS_NATIVE_SET(44);
3251     }
3252     else {
3253         if (!vaxc$errno && errno)       /* unlikely */
3254             STATUS_NATIVE_SET(44);
3255         else
3256             STATUS_NATIVE_SET(vaxc$errno);
3257     }
3258 #else
3259     int exitstatus;
3260     if (errno & 255)
3261         STATUS_POSIX_SET(errno);
3262     else {
3263         exitstatus = STATUS_POSIX >> 8;
3264         if (exitstatus & 255)
3265             STATUS_POSIX_SET(exitstatus);
3266         else
3267             STATUS_POSIX_SET(255);
3268     }
3269 #endif
3270     my_exit_jump();
3271 }
3272
3273 STATIC void
3274 S_my_exit_jump(pTHX)
3275 {
3276     dTHR;
3277     register PERL_CONTEXT *cx;
3278     I32 gimme;
3279     SV **newsp;
3280
3281     if (PL_e_script) {
3282         SvREFCNT_dec(PL_e_script);
3283         PL_e_script = Nullsv;
3284     }
3285
3286     POPSTACK_TO(PL_mainstack);
3287     if (cxstack_ix >= 0) {
3288         if (cxstack_ix > 0)
3289             dounwind(0);
3290         POPBLOCK(cx,PL_curpm);
3291         LEAVE;
3292     }
3293
3294     JMPENV_JUMP(2);
3295 }
3296
3297 #ifdef PERL_OBJECT
3298 #define NO_XSLOCKS
3299 #include "XSUB.h"
3300 #endif
3301
3302 static I32
3303 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3304 {
3305     char *p, *nl;
3306     p  = SvPVX(PL_e_script);
3307     nl = strchr(p, '\n');
3308     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3309     if (nl-p == 0) {
3310         filter_del(read_e_script);
3311         return 0;
3312     }
3313     sv_catpvn(buf_sv, p, nl-p);
3314     sv_chop(PL_e_script, nl);
3315     return 1;
3316 }
3317