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 #ifdef MACOS_TRADITIONAL
 224     /* In MacOS time() already returns values in excess of 2**31-1,
 225      * therefore we patch the integerness away. */
 226     PL_opargs[OP_TIME] &= ~OA_RETINTEGER;
 227 #endif
 228
 229     ENTER;
 230 }
 231
 232 void
 233 perl_destruct(pTHXx)
 234 {
 235     dTHR;
 236     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 237     I32 last_sv_count;
 238     HV *hv;
 239 #ifdef USE_THREADS
 240     Thread t;
 241     dTHX;
 242 #endif /* USE_THREADS */
 243
 244 #ifdef USE_THREADS
 245 #ifndef FAKE_THREADS
 246     /* Pass 1 on any remaining threads: detach joinables, join zombies */
 247   retry_cleanup:
 248     MUTEX_LOCK(&PL_threads_mutex);
 249     DEBUG_S(PerlIO_printf(Perl_debug_log,
 250                           "perl_destruct: waiting for %d threads...\n",
 251                           PL_nthreads - 1));
 252     for (t = thr->next; t != thr; t = t->next) {
 253         MUTEX_LOCK(&t->mutex);
 254         switch (ThrSTATE(t)) {
 255             AV *av;
 256         case THRf_ZOMBIE:
 257             DEBUG_S(PerlIO_printf(Perl_debug_log,
 258                                   "perl_destruct: joining zombie %p\n", t));
 259             ThrSETSTATE(t, THRf_DEAD);
 260             MUTEX_UNLOCK(&t->mutex);
 261             PL_nthreads--;
 262             /*
 263              * The SvREFCNT_dec below may take a long time (e.g. av
 264              * may contain an object scalar whose destructor gets
 265              * called) so we have to unlock threads_mutex and start
 266              * all over again.
 267              */
 268             MUTEX_UNLOCK(&PL_threads_mutex);
 269             JOIN(t, &av);
 270             SvREFCNT_dec((SV*)av);
 271             DEBUG_S(PerlIO_printf(Perl_debug_log,
 272                                   "perl_destruct: joined zombie %p OK\n", t));
 273             goto retry_cleanup;
 274         case THRf_R_JOINABLE:
 275             DEBUG_S(PerlIO_printf(Perl_debug_log,
 276                                   "perl_destruct: detaching thread %p\n", t));
 277             ThrSETSTATE(t, THRf_R_DETACHED);
 278             /*
 279              * We unlock threads_mutex and t->mutex in the opposite order
 280              * from which we locked them just so that DETACH won't
 281              * deadlock if it panics. It's only a breach of good style
 282              * not a bug since they are unlocks not locks.
 283              */
 284             MUTEX_UNLOCK(&PL_threads_mutex);
 285             DETACH(t);
 286             MUTEX_UNLOCK(&t->mutex);
 287             goto retry_cleanup;
 288         default:
 289             DEBUG_S(PerlIO_printf(Perl_debug_log,
 290                                   "perl_destruct: ignoring %p (state %u)\n",
 291                                   t, ThrSTATE(t)));
 292             MUTEX_UNLOCK(&t->mutex);
 293             /* fall through and out */
 294         }
 295     }
 296     /* We leave the above "Pass 1" loop with threads_mutex still locked */
 297
 298     /* Pass 2 on remaining threads: wait for the thread count to drop to one */
 299     while (PL_nthreads > 1)
 300     {
 301         DEBUG_S(PerlIO_printf(Perl_debug_log,
 302                               "perl_destruct: final wait for %d threads\n",
 303                               PL_nthreads - 1));
 304         COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
 305     }
 306     /* At this point, we're the last thread */
 307     MUTEX_UNLOCK(&PL_threads_mutex);
 308     DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
 309     MUTEX_DESTROY(&PL_threads_mutex);
 310     COND_DESTROY(&PL_nthreads_cond);
 311 #endif /* !defined(FAKE_THREADS) */
 312 #endif /* USE_THREADS */
 313
 314     destruct_level = PL_perl_destruct_level;
 315 #ifdef DEBUGGING
 316     {
 317         char *s;
 318         if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
 319             int i = atoi(s);
 320             if (destruct_level < i)
 321                 destruct_level = i;
 322         }
 323     }
 324 #endif
 325
 326     LEAVE;
 327     FREETMPS;
 328
 329     /* We must account for everything.  */
 330
 331     /* Destroy the main CV and syntax tree */
 332     if (PL_main_root) {
 333         PL_curpad = AvARRAY(PL_comppad);
 334         op_free(PL_main_root);
 335         PL_main_root = Nullop;
 336     }
 337     PL_curcop = &PL_compiling;
 338     PL_main_start = Nullop;
 339     SvREFCNT_dec(PL_main_cv);
 340     PL_main_cv = Nullcv;
 341     PL_dirty = TRUE;
 342
 343     if (PL_sv_objcount) {
 344         /*
 345          * Try to destruct global references.  We do this first so that the
 346          * destructors and destructees still exist.  Some sv's might remain.
 347          * Non-referenced objects are on their own.
 348          */
 349         sv_clean_objs();
 350     }
 351
 352     /* unhook hooks which will soon be, or use, destroyed data */
 353     SvREFCNT_dec(PL_warnhook);
 354     PL_warnhook = Nullsv;
 355     SvREFCNT_dec(PL_diehook);
 356     PL_diehook = Nullsv;
 357
 358     /* call exit list functions */
 359     while (PL_exitlistlen-- > 0)
 360         PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
 361
 362     Safefree(PL_exitlist);
 363
 364     if (destruct_level == 0){
 365
 366         DEBUG_P(debprofdump());
 367
 368         /* The exit() function will do everything that needs doing. */
 369         return;
 370     }
 371
 372     /* loosen bonds of global variables */
 373
 374     if(PL_rsfp) {
 375         (void)PerlIO_close(PL_rsfp);
 376         PL_rsfp = Nullfp;
 377     }
 378
 379     /* Filters for program text */
 380     SvREFCNT_dec(PL_rsfp_filters);
 381     PL_rsfp_filters = Nullav;
 382
 383     /* switches */
 384     PL_preprocess   = FALSE;
 385     PL_minus_n      = FALSE;
 386     PL_minus_p      = FALSE;
 387     PL_minus_l      = FALSE;
 388     PL_minus_a      = FALSE;
 389     PL_minus_F      = FALSE;
 390     PL_doswitches   = FALSE;
 391     PL_dowarn       = G_WARN_OFF;
 392     PL_doextract    = FALSE;
 393     PL_sawampersand = FALSE;    /* must save all match strings */
 394     PL_unsafe       = FALSE;
 395
 396     Safefree(PL_inplace);
 397     PL_inplace = Nullch;
 398
 399     if (PL_e_script) {
 400         SvREFCNT_dec(PL_e_script);
 401         PL_e_script = Nullsv;
 402     }
 403
 404     /* magical thingies */
 405
 406     Safefree(PL_ofs);   /* $, */
 407     PL_ofs = Nullch;
 408
 409     Safefree(PL_ors);   /* $\ */
 410     PL_ors = Nullch;
 411
 412     SvREFCNT_dec(PL_rs);        /* $/ */
 413     PL_rs = Nullsv;
 414
 415     SvREFCNT_dec(PL_nrs);       /* $/ helper */
 416     PL_nrs = Nullsv;
 417
 418     PL_multiline = 0;   /* $* */
 419
 420     SvREFCNT_dec(PL_statname);
 421     PL_statname = Nullsv;
 422     PL_statgv = Nullgv;
 423
 424     /* defgv, aka *_ should be taken care of elsewhere */
 425
 426     /* clean up after study() */
 427     SvREFCNT_dec(PL_lastscream);
 428     PL_lastscream = Nullsv;
 429     Safefree(PL_screamfirst);
 430     PL_screamfirst = 0;
 431     Safefree(PL_screamnext);
 432     PL_screamnext  = 0;
 433
 434     /* float buffer */
 435     Safefree(PL_efloatbuf);
 436     PL_efloatbuf = Nullch;
 437     PL_efloatsize = 0;
 438
 439     /* startup and shutdown function lists */
 440     SvREFCNT_dec(PL_beginav);
 441     SvREFCNT_dec(PL_endav);
 442     SvREFCNT_dec(PL_initav);
 443     PL_beginav = Nullav;
 444     PL_endav = Nullav;
 445     PL_initav = Nullav;
 446
 447     /* shortcuts just get cleared */
 448     PL_envgv = Nullgv;
 449     PL_incgv = Nullgv;
 450     PL_hintgv = Nullgv;
 451     PL_errgv = Nullgv;
 452     PL_argvgv = Nullgv;
 453     PL_argvoutgv = Nullgv;
 454     PL_stdingv = Nullgv;
 455     PL_stderrgv = Nullgv;
 456     PL_last_in_gv = Nullgv;
 457     PL_replgv = Nullgv;
 458
 459     /* reset so print() ends up where we expect */
 460     setdefout(Nullgv);
 461
 462     /* Prepare to destruct main symbol table.  */
 463
 464     hv = PL_defstash;
 465     PL_defstash = 0;
 466     SvREFCNT_dec(hv);
 467
 468     /* clear queued errors */
 469     SvREFCNT_dec(PL_errors);
 470     PL_errors = Nullsv;
 471
 472     FREETMPS;
 473     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 474         if (PL_scopestack_ix != 0)
 475             Perl_warner(aTHX_ WARN_INTERNAL,
 476                  "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 477                  (long)PL_scopestack_ix);
 478         if (PL_savestack_ix != 0)
 479             Perl_warner(aTHX_ WARN_INTERNAL,
 480                  "Unbalanced saves: %ld more saves than restores\n",
 481                  (long)PL_savestack_ix);
 482         if (PL_tmps_floor != -1)
 483             Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
 484                  (long)PL_tmps_floor + 1);
 485         if (cxstack_ix != -1)
 486             Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
 487                  (long)cxstack_ix + 1);
 488     }
 489
 490     /* Now absolutely destruct everything, somehow or other, loops or no. */
 491     last_sv_count = 0;
 492     SvFLAGS(PL_strtab) |= SVTYPEMASK;           /* don't clean out strtab now */
 493     while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
 494         last_sv_count = PL_sv_count;
 495         sv_clean_all();
 496     }
 497     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
 498     SvFLAGS(PL_strtab) |= SVt_PVHV;
 499
 500     /* Destruct the global string table. */
 501     {
 502         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 503          * so that sv_free() won't fail on them.
 504          */
 505         I32 riter;
 506         I32 max;
 507         HE *hent;
 508         HE **array;
 509
 510         riter = 0;
 511         max = HvMAX(PL_strtab);
 512         array = HvARRAY(PL_strtab);
 513         hent = array[0];
 514         for (;;) {
 515             if (hent && ckWARN_d(WARN_INTERNAL)) {
 516                 Perl_warner(aTHX_ WARN_INTERNAL,
 517                      "Unbalanced string table refcount: (%d) for \"%s\"",
 518                      HeVAL(hent) - Nullsv, HeKEY(hent));
 519                 HeVAL(hent) = Nullsv;
 520                 hent = HeNEXT(hent);
 521             }
 522             if (!hent) {
 523                 if (++riter > max)
 524                     break;
 525                 hent = array[riter];
 526             }
 527         }
 528     }
 529     SvREFCNT_dec(PL_strtab);
 530
 531     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 532         Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
 533
 534     sv_free_arenas();
 535
 536     /* No SVs have survived, need to clean out */
 537     PL_linestr = NULL;
 538     PL_pidstatus = Nullhv;
 539     Safefree(PL_origfilename);
 540     Safefree(PL_archpat_auto);
 541     Safefree(PL_reg_start_tmp);
 542     if (PL_reg_curpm)
 543         Safefree(PL_reg_curpm);
 544     Safefree(PL_reg_poscache);
 545     Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
 546     Safefree(PL_op_mask);
 547     nuke_stacks();
 548     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
 549
 550     DEBUG_P(debprofdump());
 551 #ifdef USE_THREADS
 552     MUTEX_DESTROY(&PL_strtab_mutex);
 553     MUTEX_DESTROY(&PL_sv_mutex);
 554     MUTEX_DESTROY(&PL_eval_mutex);
 555     MUTEX_DESTROY(&PL_cred_mutex);
 556     COND_DESTROY(&PL_eval_cond);
 557 #ifdef EMULATE_ATOMIC_REFCOUNTS
 558     MUTEX_DESTROY(&PL_svref_mutex);
 559 #endif /* EMULATE_ATOMIC_REFCOUNTS */
 560
 561     /* As the penultimate thing, free the non-arena SV for thrsv */
 562     Safefree(SvPVX(PL_thrsv));
 563     Safefree(SvANY(PL_thrsv));
 564     Safefree(PL_thrsv);
 565     PL_thrsv = Nullsv;
 566 #endif /* USE_THREADS */
 567
 568     /* As the absolutely last thing, free the non-arena SV for mess() */
 569
 570     if (PL_mess_sv) {
 571         /* it could have accumulated taint magic */
 572         if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
 573             MAGIC* mg;
 574             MAGIC* moremagic;
 575             for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
 576                 moremagic = mg->mg_moremagic;
 577                 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
 578                     Safefree(mg->mg_ptr);
 579                 Safefree(mg);
 580             }
 581         }
 582         /* we know that type >= SVt_PV */
 583         SvOOK_off(PL_mess_sv);
 584         Safefree(SvPVX(PL_mess_sv));
 585         Safefree(SvANY(PL_mess_sv));
 586         Safefree(PL_mess_sv);
 587         PL_mess_sv = Nullsv;
 588     }
 589 }
 590
 591 void
 592 perl_free(pTHXx)
 593 {
 594 #if defined(PERL_OBJECT)
 595     PerlMem_free(this);
 596 #else
 597     PerlMem_free(aTHXx);
 598 #endif
 599 }
 600
 601 void
 602 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
 603 {
 604     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
 605     PL_exitlist[PL_exitlistlen].fn = fn;
 606     PL_exitlist[PL_exitlistlen].ptr = ptr;
 607     ++PL_exitlistlen;
 608 }
 609
 610 int
 611 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
 612 {
 613     dTHR;
 614     I32 oldscope;
 615     int ret;
 616     dJMPENV;
 617 #ifdef USE_THREADS
 618     dTHX;
 619 #endif
 620
 621 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 622 #ifdef IAMSUID
 623 #undef IAMSUID
 624     Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
 625 setuid perl scripts securely.\n");
 626 #endif
 627 #endif
 628
 629 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
 630     _dyld_lookup_and_bind
 631         ("__environ", (unsigned long *) &environ_pointer, NULL);
 632 #endif /* environ */
 633
 634     PL_origargv = argv;
 635     PL_origargc = argc;
 636 #ifndef VMS  /* VMS doesn't have environ array */
 637     PL_origenviron = environ;
 638 #endif
 639
 640     if (PL_do_undump) {
 641
 642         /* Come here if running an undumped a.out. */
 643
 644         PL_origfilename = savepv(argv[0]);
 645         PL_do_undump = FALSE;
 646         cxstack_ix = -1;                /* start label stack again */
 647         init_ids();
 648         init_postdump_symbols(argc,argv,env);
 649         return 0;
 650     }
 651
 652     if (PL_main_root) {
 653         PL_curpad = AvARRAY(PL_comppad);
 654         op_free(PL_main_root);
 655         PL_main_root = Nullop;
 656     }
 657     PL_main_start = Nullop;
 658     SvREFCNT_dec(PL_main_cv);
 659     PL_main_cv = Nullcv;
 660
 661     time(&PL_basetime);
 662     oldscope = PL_scopestack_ix;
 663     PL_dowarn = G_WARN_OFF;
 664
 665     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
 666                 env, xsinit);
 667     switch (ret) {
 668     case 0:
 669         return 0;
 670     case 1:
 671         STATUS_ALL_FAILURE;
 672         /* FALL THROUGH */
 673     case 2:
 674         /* my_exit() was called */
 675         while (PL_scopestack_ix > oldscope)
 676             LEAVE;
 677         FREETMPS;
 678         PL_curstash = PL_defstash;
 679         if (PL_endav && !PL_minus_c)
 680             call_list(oldscope, PL_endav);
 681         return STATUS_NATIVE_EXPORT;
 682     case 3:
 683         PerlIO_printf(Perl_error_log, "panic: top_env\n");
 684         return 1;
 685     }
 686     return 0;
 687 }
 688
 689 STATIC void *
 690 S_parse_body(pTHX_ va_list args)
 691 {
 692     dTHR;
 693     int argc = PL_origargc;
 694     char **argv = PL_origargv;
 695     char **env = va_arg(args, char**);
 696     char *scriptname = NULL;
 697     int fdscript = -1;
 698     VOL bool dosearch = FALSE;
 699     char *validarg = "";
 700     AV* comppadlist;
 701     register SV *sv;
 702     register char *s;
 703     char *cddir = Nullch;
 704
 705     XSINIT_t xsinit = va_arg(args, XSINIT_t);
 706
 707     sv_setpvn(PL_linestr,"",0);
 708     sv = newSVpvn("",0);                /* first used for -I flags */
 709     SAVEFREESV(sv);
 710     init_main_stash();
 711
 712     for (argc--,argv++; argc > 0; argc--,argv++) {
 713         if (argv[0][0] != '-' || !argv[0][1])
 714             break;
 715 #ifdef DOSUID
 716     if (*validarg)
 717         validarg = " PHOOEY ";
 718     else
 719         validarg = argv[0];
 720 #endif
 721         s = argv[0]+1;
 722       reswitch:
 723         switch (*s) {
 724 #ifndef PERL_STRICT_CR
 725         case '\r':
 726 #endif
 727         case ' ':
 728         case '0':
 729         case 'F':
 730         case 'a':
 731         case 'c':
 732         case 'd':
 733         case 'D':
 734         case 'h':
 735         case 'i':
 736         case 'l':
 737         case 'M':
 738         case 'm':
 739         case 'n':
 740         case 'p':
 741         case 's':
 742         case 'u':
 743         case 'U':
 744         case 'v':
 745         case 'W':
 746         case 'X':
 747         case 'w':
 748             if (s = moreswitches(s))
 749                 goto reswitch;
 750             break;
 751
 752         case 'T':
 753             PL_tainting = TRUE;
 754             s++;
 755             goto reswitch;
 756
 757         case 'e':
 758 #ifdef MACOS_TRADITIONAL
 759             /* ignore -e for Dev:Pseudo argument */
 760             if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
 761                 break;
 762 #endif
 763             if (PL_euid != PL_uid || PL_egid != PL_gid)
 764                 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
 765             if (!PL_e_script) {
 766                 PL_e_script = newSVpvn("",0);
 767                 filter_add(read_e_script, NULL);
 768             }
 769             if (*++s)
 770                 sv_catpv(PL_e_script, s);
 771             else if (argv[1]) {
 772                 sv_catpv(PL_e_script, argv[1]);
 773                 argc--,argv++;
 774             }
 775             else
 776                 Perl_croak(aTHX_ "No code specified for -e");
 777             sv_catpv(PL_e_script, "\n");
 778             break;
 779
 780         case 'I':       /* -I handled both here and in moreswitches() */
 781             forbid_setid("-I");
 782             if (!*++s && (s=argv[1]) != Nullch) {
 783                 argc--,argv++;
 784             }
 785             while (s && isSPACE(*s))
 786                 ++s;
 787             if (s && *s) {
 788                 char *e, *p;
 789                 for (e = s; *e && !isSPACE(*e); e++) ;
 790                 p = savepvn(s, e-s);
 791                 incpush(p, TRUE);
 792                 sv_catpv(sv,"-I");
 793                 sv_catpv(sv,p);
 794                 sv_catpv(sv," ");
 795                 Safefree(p);
 796             }   /* XXX else croak? */
 797             break;
 798         case 'P':
 799             forbid_setid("-P");
 800             PL_preprocess = TRUE;
 801             s++;
 802             goto reswitch;
 803         case 'S':
 804             forbid_setid("-S");
 805             dosearch = TRUE;
 806             s++;
 807             goto reswitch;
 808         case 'V':
 809             if (!PL_preambleav)
 810                 PL_preambleav = newAV();
 811             av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
 812             if (*++s != ':')  {
 813                 PL_Sv = newSVpv("print myconfig();",0);
 814 #ifdef VMS
 815                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
 816 #else
 817                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 818 #endif
 819                 sv_catpv(PL_Sv,"\"  Compile-time options:");
 820 #  ifdef DEBUGGING
 821                 sv_catpv(PL_Sv," DEBUGGING");
 822 #  endif
 823 #  ifdef MULTIPLICITY
 824                 sv_catpv(PL_Sv," MULTIPLICITY");
 825 #  endif
 826 #  ifdef USE_THREADS
 827                 sv_catpv(PL_Sv," USE_THREADS");
 828 #  endif
 829 #  ifdef PERL_OBJECT
 830                 sv_catpv(PL_Sv," PERL_OBJECT");
 831 #  endif
 832 #  ifdef PERL_IMPLICIT_CONTEXT
 833                 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
 834 #  endif
 835 #  ifdef PERL_IMPLICIT_SYS
 836                 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
 837 #  endif
 838                 sv_catpv(PL_Sv,"\\n\",");
 839
 840 #if defined(LOCAL_PATCH_COUNT)
 841                 if (LOCAL_PATCH_COUNT > 0) {
 842                     int i;
 843                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
 844                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
 845                         if (PL_localpatches[i])
 846                             Perl_sv_catpvf(aTHX_ PL_Sv,"q\"  \t%s\n\",",PL_localpatches[i]);
 847                     }
 848                 }
 849 #endif
 850                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
 851 #ifdef __DATE__
 852 #  ifdef __TIME__
 853                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 854 #  else
 855                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
 856 #  endif
 857 #endif
 858                 sv_catpv(PL_Sv, "; \
 859 $\"=\"\\n    \"; \
 860 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
 861 print \"  \\%ENV:\\n    @env\\n\" if @env; \
 862 print \"  \\@INC:\\n    @INC\\n\";");
 863             }
 864             else {
 865                 PL_Sv = newSVpv("config_vars(qw(",0);
 866                 sv_catpv(PL_Sv, ++s);
 867                 sv_catpv(PL_Sv, "))");
 868                 s += strlen(s);
 869             }
 870             av_push(PL_preambleav, PL_Sv);
 871             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
 872             goto reswitch;
 873         case 'x':
 874             PL_doextract = TRUE;
 875             s++;
 876             if (*s)
 877                 cddir = s;
 878             break;
 879         case 0:
 880             break;
 881         case '-':
 882             if (!*++s || isSPACE(*s)) {
 883                 argc--,argv++;
 884                 goto switch_end;
 885             }
 886             /* catch use of gnu style long options */
 887             if (strEQ(s, "version")) {
 888                 s = "v";
 889                 goto reswitch;
 890             }
 891             if (strEQ(s, "help")) {
 892                 s = "h";
 893                 goto reswitch;
 894             }
 895             s--;
 896             /* FALL THROUGH */
 897         default:
 898             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
 899         }
 900     }
 901   switch_end:
 902
 903     if (
 904 #ifndef SECURE_INTERNAL_GETENV
 905         !PL_tainting &&
 906 #endif
 907                         (s = PerlEnv_getenv("PERL5OPT"))) {
 908         while (isSPACE(*s))
 909             s++;
 910         if (*s == '-' && *(s+1) == 'T')
 911             PL_tainting = TRUE;
 912         else {
 913             while (s && *s) {
 914                 while (isSPACE(*s))
 915                     s++;
 916                 if (*s == '-') {
 917                     s++;
 918                     if (isSPACE(*s))
 919                         continue;
 920                 }
 921                 if (!*s)
 922                     break;
 923                 if (!strchr("DIMUdmw", *s))
 924                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
 925                 s = moreswitches(s);
 926             }
 927         }
 928     }
 929
 930     if (!scriptname)
 931         scriptname = argv[0];
 932     if (PL_e_script) {
 933         argc++,argv--;
 934         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
 935     }
 936     else if (scriptname == Nullch) {
 937 #ifdef MSDOS
 938         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
 939             moreswitches("h");
 940 #endif
 941         scriptname = "-";
 942     }
 943
 944     init_perllib();
 945
 946     open_script(scriptname,dosearch,sv,&fdscript);
 947
 948     validate_suid(validarg, scriptname,fdscript);
 949
 950 #if defined(SIGCHLD) || defined(SIGCLD)
 951     {
 952 #ifndef SIGCHLD
 953 #  define SIGCHLD SIGCLD
 954 #endif
 955         Sighandler_t sigstate = rsignal_state(SIGCHLD);
 956         if (sigstate == SIG_IGN) {
 957             if (ckWARN(WARN_SIGNAL))
 958                 Perl_warner(aTHX_ WARN_SIGNAL,
 959                             "Can't ignore signal CHLD, forcing to default");
 960             (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
 961         }
 962     }
 963 #endif
 964
 965 #ifdef MACOS_TRADITIONAL
 966     if (PL_doextract || gAlwaysExtract)
 967 #else
 968     if (PL_doextract) {
 969 #endif
 970         find_beginning();
 971         if (cddir && PerlDir_chdir(cddir) < 0)
 972             Perl_croak(aTHX_ "Can't chdir to %s",cddir);
 973     }
 974
 975     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
 976     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
 977     CvUNIQUE_on(PL_compcv);
 978
 979     PL_comppad = newAV();
 980     av_push(PL_comppad, Nullsv);
 981     PL_curpad = AvARRAY(PL_comppad);
 982     PL_comppad_name = newAV();
 983     PL_comppad_name_fill = 0;
 984     PL_min_intro_pending = 0;
 985     PL_padix = 0;
 986 #ifdef USE_THREADS
 987     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
 988     PL_curpad[0] = (SV*)newAV();
 989     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
 990     CvOWNER(PL_compcv) = 0;
 991     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
 992     MUTEX_INIT(CvMUTEXP(PL_compcv));
 993 #endif /* USE_THREADS */
 994
 995     comppadlist = newAV();
 996     AvREAL_off(comppadlist);
 997     av_store(comppadlist, 0, (SV*)PL_comppad_name);
 998     av_store(comppadlist, 1, (SV*)PL_comppad);
 999     CvPADLIST(PL_compcv) = comppadlist;
1000
1001     boot_core_UNIVERSAL();
1002     boot_core_xsutils();
1003
1004     if (xsinit)
1005         (*xsinit)(aTHXo);       /* in case linked C routines want magical variables */
1006 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1007     init_os_extras();
1008 #endif
1009
1010 #ifdef USE_SOCKS
1011     SOCKSinit(argv[0]);
1012 #endif
1013
1014     init_predump_symbols();
1015     /* init_postdump_symbols not currently designed to be called */
1016     /* more than once (ENV isn't cleared first, for example)     */
1017     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
1018     if (!PL_do_undump)
1019         init_postdump_symbols(argc,argv,env);
1020
1021     init_lexer();
1022
1023     /* now parse the script */
1024
1025     SETERRNO(0,SS$_NORMAL);
1026     PL_error_count = 0;
1027 #ifdef MACOS_TRADITIONAL
1028     if (gSyntaxError = (yyparse() || PL_error_count)) {
1029         if (PL_minus_c)
1030             Perl_croak(aTHX_ "%s had compilation errors.\n", MPWFileName(PL_origfilename));
1031         else {
1032             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1033                        MPWFileName(PL_origfilename));
1034         }
1035     }
1036 #else
1037     if (yyparse() || PL_error_count) {
1038         if (PL_minus_c)
1039             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1040         else {
1041             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1042                        PL_origfilename);
1043         }
1044     }
1045 #endif
1046     PL_curcop->cop_line = 0;
1047     PL_curstash = PL_defstash;
1048     PL_preprocess = FALSE;
1049     if (PL_e_script) {
1050         SvREFCNT_dec(PL_e_script);
1051         PL_e_script = Nullsv;
1052     }
1053
1054     /* now that script is parsed, we can modify record separator */
1055     SvREFCNT_dec(PL_rs);
1056     PL_rs = SvREFCNT_inc(PL_nrs);
1057     sv_setsv(get_sv("/", TRUE), PL_rs);
1058     if (PL_do_undump)
1059         my_unexec();
1060
1061     if (isWARN_ONCE)
1062         gv_check(PL_defstash);
1063
1064     LEAVE;
1065     FREETMPS;
1066
1067 #ifdef MYMALLOC
1068     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1069         dump_mstats("after compilation:");
1070 #endif
1071
1072     ENTER;
1073     PL_restartop = 0;
1074     return NULL;
1075 }
1076
1077 int
1078 perl_run(pTHXx)
1079 {
1080     dTHR;
1081     I32 oldscope;
1082     int ret;
1083     dJMPENV;
1084 #ifdef USE_THREADS
1085     dTHX;
1086 #endif
1087
1088     oldscope = PL_scopestack_ix;
1089
1090  redo_body:
1091     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1092     switch (ret) {
1093     case 1:
1094         cxstack_ix = -1;                /* start context stack again */
1095         goto redo_body;
1096     case 0:  /* normal completion */
1097     case 2:  /* my_exit() */
1098         while (PL_scopestack_ix > oldscope)
1099             LEAVE;
1100         FREETMPS;
1101         PL_curstash = PL_defstash;
1102         if (PL_endav && !PL_minus_c)
1103             call_list(oldscope, PL_endav);
1104 #ifdef MYMALLOC
1105         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1106             dump_mstats("after execution:  ");
1107 #endif
1108         return STATUS_NATIVE_EXPORT;
1109     case 3:
1110         if (PL_restartop) {
1111             POPSTACK_TO(PL_mainstack);
1112             goto redo_body;
1113         }
1114         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1115         FREETMPS;
1116         return 1;
1117     }
1118
1119     /* NOTREACHED */
1120     return 0;
1121 }
1122
1123 STATIC void *
1124 S_run_body(pTHX_ va_list args)
1125 {
1126     dTHR;
1127     I32 oldscope = va_arg(args, I32);
1128
1129     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1130                     PL_sawampersand ? "Enabling" : "Omitting"));
1131
1132     if (!PL_restartop) {
1133         DEBUG_x(dump_all());
1134         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1135         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1136                               PTR2UV(thr)));
1137
1138         if (PL_minus_c) {
1139 #ifdef MACOS_TRADITIONAL
1140             PerlIO_printf(PerlIO_stderr(), "# %s syntax OK\n", MPWFileName(PL_origfilename));
1141 #else
1142             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1143 #endif
1144 my_exit(0);
1145         }
1146         if (PERLDB_SINGLE && PL_DBsingle)
1147             sv_setiv(PL_DBsingle, 1);
1148         if (PL_initav)
1149             call_list(oldscope, PL_initav);
1150     }
1151
1152     /* do it */
1153
1154     if (PL_restartop) {
1155         PL_op = PL_restartop;
1156         PL_restartop = 0;
1157         CALLRUNOPS(aTHX);
1158     }
1159     else if (PL_main_start) {
1160         CvDEPTH(PL_main_cv) = 1;
1161         PL_op = PL_main_start;
1162         CALLRUNOPS(aTHX);
1163     }
1164
1165     my_exit(0);
1166     /* NOTREACHED */
1167     return NULL;
1168 }
1169
1170 SV*
1171 Perl_get_sv(pTHX_ const char *name, I32 create)
1172 {
1173     GV *gv;
1174 #ifdef USE_THREADS
1175     if (name[1] == '\0' && !isALPHA(name[0])) {
1176         PADOFFSET tmp = find_threadsv(name);
1177         if (tmp != NOT_IN_PAD) {
1178             dTHR;
1179             return THREADSV(tmp);
1180         }
1181     }
1182 #endif /* USE_THREADS */
1183     gv = gv_fetchpv(name, create, SVt_PV);
1184     if (gv)
1185         return GvSV(gv);
1186     return Nullsv;
1187 }
1188
1189 AV*
1190 Perl_get_av(pTHX_ const char *name, I32 create)
1191 {
1192     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1193     if (create)
1194         return GvAVn(gv);
1195     if (gv)
1196         return GvAV(gv);
1197     return Nullav;
1198 }
1199
1200 HV*
1201 Perl_get_hv(pTHX_ const char *name, I32 create)
1202 {
1203     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1204     if (create)
1205         return GvHVn(gv);
1206     if (gv)
1207         return GvHV(gv);
1208     return Nullhv;
1209 }
1210
1211 CV*
1212 Perl_get_cv(pTHX_ const char *name, I32 create)
1213 {
1214     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1215     /* XXX unsafe for threads if eval_owner isn't held */
1216     /* XXX this is probably not what they think they're getting.
1217      * It has the same effect as "sub name;", i.e. just a forward
1218      * declaration! */
1219     if (create && !GvCVu(gv))
1220         return newSUB(start_subparse(FALSE, 0),
1221                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1222                       Nullop,
1223                       Nullop);
1224     if (gv)
1225         return GvCVu(gv);
1226     return Nullcv;
1227 }
1228
1229 /* Be sure to refetch the stack pointer after calling these routines. */
1230
1231 I32
1232 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1233
1234                         /* See G_* flags in cop.h */
1235                         /* null terminated arg list */
1236 {
1237     dSP;
1238
1239     PUSHMARK(SP);
1240     if (argv) {
1241         while (*argv) {
1242             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1243             argv++;
1244         }
1245         PUTBACK;
1246     }
1247     return call_pv(sub_name, flags);
1248 }
1249
1250 I32
1251 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1252                         /* name of the subroutine */
1253                         /* See G_* flags in cop.h */
1254 {
1255     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1256 }
1257
1258 I32
1259 Perl_call_method(pTHX_ const char *methname, I32 flags)
1260                         /* name of the subroutine */
1261                         /* See G_* flags in cop.h */
1262 {
1263     dSP;
1264     OP myop;
1265     if (!PL_op)
1266         PL_op = &myop;
1267     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1268     PUTBACK;
1269     pp_method();
1270         if(PL_op == &myop)
1271                 PL_op = Nullop;
1272     return call_sv(*PL_stack_sp--, flags);
1273 }
1274
1275 /* May be called with any of a CV, a GV, or an SV containing the name. */
1276 I32
1277 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1278
1279                         /* See G_* flags in cop.h */
1280 {
1281     dSP;
1282     LOGOP myop;         /* fake syntax tree node */
1283     I32 oldmark;
1284     I32 retval;
1285     I32 oldscope;
1286     bool oldcatch = CATCH_GET;
1287     int ret;
1288     OP* oldop = PL_op;
1289     dJMPENV;
1290
1291     if (flags & G_DISCARD) {
1292         ENTER;
1293         SAVETMPS;
1294     }
1295
1296     Zero(&myop, 1, LOGOP);
1297     myop.op_next = Nullop;
1298     if (!(flags & G_NOARGS))
1299         myop.op_flags |= OPf_STACKED;
1300     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1301                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1302                       OPf_WANT_SCALAR);
1303     SAVEOP();
1304     PL_op = (OP*)&myop;
1305
1306     EXTEND(PL_stack_sp, 1);
1307     *++PL_stack_sp = sv;
1308     oldmark = TOPMARK;
1309     oldscope = PL_scopestack_ix;
1310
1311     if (PERLDB_SUB && PL_curstash != PL_debstash
1312            /* Handle first BEGIN of -d. */
1313           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1314            /* Try harder, since this may have been a sighandler, thus
1315             * curstash may be meaningless. */
1316           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1317           && !(flags & G_NODEBUG))
1318         PL_op->op_private |= OPpENTERSUB_DB;
1319
1320     if (!(flags & G_EVAL)) {
1321         CATCH_SET(TRUE);
1322         call_xbody((OP*)&myop, FALSE);
1323         retval = PL_stack_sp - (PL_stack_base + oldmark);
1324         CATCH_SET(oldcatch);
1325     }
1326     else {
1327         cLOGOP->op_other = PL_op;
1328         PL_markstack_ptr--;
1329         /* we're trying to emulate pp_entertry() here */
1330         {
1331             register PERL_CONTEXT *cx;
1332             I32 gimme = GIMME_V;
1333
1334             ENTER;
1335             SAVETMPS;
1336
1337             push_return(PL_op->op_next);
1338             PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1339             PUSHEVAL(cx, 0, 0);
1340             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
1341
1342             PL_in_eval = EVAL_INEVAL;
1343             if (flags & G_KEEPERR)
1344                 PL_in_eval |= EVAL_KEEPERR;
1345             else
1346                 sv_setpv(ERRSV,"");
1347         }
1348         PL_markstack_ptr++;
1349
1350   redo_body:
1351         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1352                     (OP*)&myop, FALSE);
1353         switch (ret) {
1354         case 0:
1355             retval = PL_stack_sp - (PL_stack_base + oldmark);
1356             if (!(flags & G_KEEPERR))
1357                 sv_setpv(ERRSV,"");
1358             break;
1359         case 1:
1360             STATUS_ALL_FAILURE;
1361             /* FALL THROUGH */
1362         case 2:
1363             /* my_exit() was called */
1364             PL_curstash = PL_defstash;
1365             FREETMPS;
1366             if (PL_statusvalue)
1367                 Perl_croak(aTHX_ "Callback called exit");
1368             my_exit_jump();
1369             /* NOTREACHED */
1370         case 3:
1371             if (PL_restartop) {
1372                 PL_op = PL_restartop;
1373                 PL_restartop = 0;
1374                 goto redo_body;
1375             }
1376             PL_stack_sp = PL_stack_base + oldmark;
1377             if (flags & G_ARRAY)
1378                 retval = 0;
1379             else {
1380                 retval = 1;
1381                 *++PL_stack_sp = &PL_sv_undef;
1382             }
1383             break;
1384         }
1385
1386         if (PL_scopestack_ix > oldscope) {
1387             SV **newsp;
1388             PMOP *newpm;
1389             I32 gimme;
1390             register PERL_CONTEXT *cx;
1391             I32 optype;
1392
1393             POPBLOCK(cx,newpm);
1394             POPEVAL(cx);
1395             pop_return();
1396             PL_curpm = newpm;
1397             LEAVE;
1398         }
1399     }
1400
1401     if (flags & G_DISCARD) {
1402         PL_stack_sp = PL_stack_base + oldmark;
1403         retval = 0;
1404         FREETMPS;
1405         LEAVE;
1406     }
1407     PL_op = oldop;
1408     return retval;
1409 }
1410
1411 STATIC void *
1412 S_call_body(pTHX_ va_list args)
1413 {
1414     OP *myop = va_arg(args, OP*);
1415     int is_eval = va_arg(args, int);
1416
1417     call_xbody(myop, is_eval);
1418     return NULL;
1419 }
1420
1421 STATIC void
1422 S_call_xbody(pTHX_ OP *myop, int is_eval)
1423 {
1424     dTHR;
1425
1426     if (PL_op == myop) {
1427         if (is_eval)
1428             PL_op = Perl_pp_entereval(aTHX);
1429         else
1430             PL_op = Perl_pp_entersub(aTHX);
1431     }
1432     if (PL_op)
1433         CALLRUNOPS(aTHX);
1434 }
1435
1436 /* Eval a string. The G_EVAL flag is always assumed. */
1437
1438 I32
1439 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1440
1441                         /* See G_* flags in cop.h */
1442 {
1443     dSP;
1444     UNOP myop;          /* fake syntax tree node */
1445     I32 oldmark = SP - PL_stack_base;
1446     I32 retval;
1447     I32 oldscope;
1448     int ret;
1449     OP* oldop = PL_op;
1450     dJMPENV;
1451
1452     if (flags & G_DISCARD) {
1453         ENTER;
1454         SAVETMPS;
1455     }
1456
1457     SAVEOP();
1458     PL_op = (OP*)&myop;
1459     Zero(PL_op, 1, UNOP);
1460     EXTEND(PL_stack_sp, 1);
1461     *++PL_stack_sp = sv;
1462     oldscope = PL_scopestack_ix;
1463
1464     if (!(flags & G_NOARGS))
1465         myop.op_flags = OPf_STACKED;
1466     myop.op_next = Nullop;
1467     myop.op_type = OP_ENTEREVAL;
1468     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1469                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1470                       OPf_WANT_SCALAR);
1471     if (flags & G_KEEPERR)
1472         myop.op_flags |= OPf_SPECIAL;
1473
1474  redo_body:
1475     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1476                 (OP*)&myop, TRUE);
1477     switch (ret) {
1478     case 0:
1479         retval = PL_stack_sp - (PL_stack_base + oldmark);
1480         if (!(flags & G_KEEPERR))
1481             sv_setpv(ERRSV,"");
1482         break;
1483     case 1:
1484         STATUS_ALL_FAILURE;
1485         /* FALL THROUGH */
1486     case 2:
1487         /* my_exit() was called */
1488         PL_curstash = PL_defstash;
1489         FREETMPS;
1490         if (PL_statusvalue)
1491             Perl_croak(aTHX_ "Callback called exit");
1492         my_exit_jump();
1493         /* NOTREACHED */
1494     case 3:
1495         if (PL_restartop) {
1496             PL_op = PL_restartop;
1497             PL_restartop = 0;
1498             goto redo_body;
1499         }
1500         PL_stack_sp = PL_stack_base + oldmark;
1501         if (flags & G_ARRAY)
1502             retval = 0;
1503         else {
1504             retval = 1;
1505             *++PL_stack_sp = &PL_sv_undef;
1506         }
1507         break;
1508     }
1509
1510     if (flags & G_DISCARD) {
1511         PL_stack_sp = PL_stack_base + oldmark;
1512         retval = 0;
1513         FREETMPS;
1514         LEAVE;
1515     }
1516     PL_op = oldop;
1517     return retval;
1518 }
1519
1520 SV*
1521 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1522 {
1523     dSP;
1524     SV* sv = newSVpv(p, 0);
1525
1526     PUSHMARK(SP);
1527     eval_sv(sv, G_SCALAR);
1528     SvREFCNT_dec(sv);
1529
1530     SPAGAIN;
1531     sv = POPs;
1532     PUTBACK;
1533
1534     if (croak_on_error && SvTRUE(ERRSV)) {
1535         STRLEN n_a;
1536         Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1537     }
1538
1539     return sv;
1540 }
1541
1542 /* Require a module. */
1543
1544 void
1545 Perl_require_pv(pTHX_ const char *pv)
1546 {
1547     SV* sv;
1548     dSP;
1549     PUSHSTACKi(PERLSI_REQUIRE);
1550     PUTBACK;
1551     sv = sv_newmortal();
1552     sv_setpv(sv, "require '");
1553     sv_catpv(sv, pv);
1554     sv_catpv(sv, "'");
1555     eval_sv(sv, G_DISCARD);
1556     SPAGAIN;
1557     POPSTACK;
1558 }
1559
1560 void
1561 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1562 {
1563     register GV *gv;
1564
1565     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1566         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1567 }
1568
1569 STATIC void
1570 S_usage(pTHX_ char *name)               /* XXX move this out into a module ? */
1571 {
1572     /* This message really ought to be max 23 lines.
1573      * Removed -h because the user already knows that opton. Others? */
1574
1575     static char *usage_msg[] = {
1576 "-0[octal]       specify record separator (\\0, if no argument)",
1577 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1578 "-c              check syntax only (runs BEGIN and END blocks)",
1579 "-d[:debugger]   run program under debugger",
1580 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1581 "-e 'command'    one line of program (several -e's allowed, omit programfile)",
1582 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
1583 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
1584 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
1585 "-l[octal]       enable line ending processing, specifies line terminator",
1586 "-[mM][-]module  execute `use/no module...' before executing program",
1587 "-n              assume 'while (<>) { ... }' loop around program",
1588 "-p              assume loop like -n but print line also, like sed",
1589 "-P              run program through C preprocessor before compilation",
1590 "-s              enable rudimentary parsing for switches after programfile",
1591 "-S              look for programfile using PATH environment variable",
1592 "-T              enable tainting checks",
1593 "-u              dump core after parsing program",
1594 "-U              allow unsafe operations",
1595 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
1596 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
1597 "-w              enable many useful warnings (RECOMMENDED)",
1598 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1599 "\n",
1600 NULL
1601 };
1602     char **p = usage_msg;
1603
1604     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1605     while (*p)
1606         printf("\n  %s", *p++);
1607 }
1608
1609 /* This routine handles any switches that can be given during run */
1610
1611 char *
1612 Perl_moreswitches(pTHX_ char *s)
1613 {
1614     I32 numlen;
1615     U32 rschar;
1616
1617     switch (*s) {
1618     case '0':
1619     {
1620         dTHR;
1621         rschar = (U32)scan_oct(s, 4, &numlen);
1622         SvREFCNT_dec(PL_nrs);
1623         if (rschar & ~((U8)~0))
1624             PL_nrs = &PL_sv_undef;
1625         else if (!rschar && numlen >= 2)
1626             PL_nrs = newSVpvn("", 0);
1627         else {
1628             char ch = rschar;
1629             PL_nrs = newSVpvn(&ch, 1);
1630         }
1631         return s + numlen;
1632     }
1633     case 'F':
1634         PL_minus_F = TRUE;
1635         PL_splitstr = savepv(s + 1);
1636         s += strlen(s);
1637         return s;
1638     case 'a':
1639         PL_minus_a = TRUE;
1640         s++;
1641         return s;
1642     case 'c':
1643         PL_minus_c = TRUE;
1644         s++;
1645         return s;
1646     case 'd':
1647         forbid_setid("-d");
1648         s++;
1649         if (*s == ':' || *s == '=')  {
1650             my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1651             s += strlen(s);
1652         }
1653         if (!PL_perldb) {
1654             PL_perldb = PERLDB_ALL;
1655             init_debugger();
1656         }
1657         return s;
1658     case 'D':
1659     {
1660 #ifdef DEBUGGING
1661         forbid_setid("-D");
1662         if (isALPHA(s[1])) {
1663             static char debopts[] = "psltocPmfrxuLHXDS";
1664             char *d;
1665
1666             for (s++; *s && (d = strchr(debopts,*s)); s++)
1667                 PL_debug |= 1 << (d - debopts);
1668         }
1669         else {
1670             PL_debug = atoi(s+1);
1671             for (s++; isDIGIT(*s); s++) ;
1672         }
1673         PL_debug |= 0x80000000;
1674 #else
1675         dTHR;
1676         if (ckWARN_d(WARN_DEBUGGING))
1677             Perl_warner(aTHX_ WARN_DEBUGGING,
1678                    "Recompile perl with -DDEBUGGING to use -D switch\n");
1679         for (s++; isALNUM(*s); s++) ;
1680 #endif
1681         /*SUPPRESS 530*/
1682         return s;
1683     }
1684     case 'h':
1685         usage(PL_origargv[0]);
1686         PerlProc_exit(0);
1687     case 'i':
1688         if (PL_inplace)
1689             Safefree(PL_inplace);
1690         PL_inplace = savepv(s+1);
1691         /*SUPPRESS 530*/
1692         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1693         if (*s) {
1694             *s++ = '\0';
1695             if (*s == '-')      /* Additional switches on #! line. */
1696                 s++;
1697         }
1698         return s;
1699     case 'I':   /* -I handled both here and in parse_perl() */
1700         forbid_setid("-I");
1701         ++s;
1702         while (*s && isSPACE(*s))
1703             ++s;
1704         if (*s) {
1705             char *e, *p;
1706             for (e = s; *e && !isSPACE(*e); e++) ;
1707             p = savepvn(s, e-s);
1708             incpush(p, TRUE);
1709             Safefree(p);
1710             s = e;
1711         }
1712         else
1713             Perl_croak(aTHX_ "No space allowed after -I");
1714         return s;
1715     case 'l':
1716         PL_minus_l = TRUE;
1717         s++;
1718         if (PL_ors)
1719             Safefree(PL_ors);
1720         if (isDIGIT(*s)) {
1721             PL_ors = savepv("\n");
1722             PL_orslen = 1;
1723             *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1724             s += numlen;
1725         }
1726         else {
1727             dTHR;
1728             if (RsPARA(PL_nrs)) {
1729                 PL_ors = "\n\n";
1730                 PL_orslen = 2;
1731             }
1732             else
1733                 PL_ors = SvPV(PL_nrs, PL_orslen);
1734             PL_ors = savepvn(PL_ors, PL_orslen);
1735         }
1736         return s;
1737     case 'M':
1738         forbid_setid("-M");     /* XXX ? */
1739         /* FALL THROUGH */
1740     case 'm':
1741         forbid_setid("-m");     /* XXX ? */
1742         if (*++s) {
1743             char *start;
1744             SV *sv;
1745             char *use = "use ";
1746             /* -M-foo == 'no foo'       */
1747             if (*s == '-') { use = "no "; ++s; }
1748             sv = newSVpv(use,0);
1749             start = s;
1750             /* We allow -M'Module qw(Foo Bar)'  */
1751             while(isALNUM(*s) || *s==':') ++s;
1752             if (*s != '=') {
1753                 sv_catpv(sv, start);
1754                 if (*(start-1) == 'm') {
1755                     if (*s != '\0')
1756                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1757                     sv_catpv( sv, " ()");
1758                 }
1759             } else {
1760                 sv_catpvn(sv, start, s-start);
1761                 sv_catpv(sv, " split(/,/,q{");
1762                 sv_catpv(sv, ++s);
1763                 sv_catpv(sv,    "})");
1764             }
1765             s += strlen(s);
1766             if (PL_preambleav == NULL)
1767                 PL_preambleav = newAV();
1768             av_push(PL_preambleav, sv);
1769         }
1770         else
1771             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1772         return s;
1773     case 'n':
1774         PL_minus_n = TRUE;
1775         s++;
1776         return s;
1777     case 'p':
1778         PL_minus_p = TRUE;
1779         s++;
1780         return s;
1781     case 's':
1782         forbid_setid("-s");
1783         PL_doswitches = TRUE;
1784         s++;
1785         return s;
1786     case 'T':
1787         if (!PL_tainting)
1788             Perl_croak(aTHX_ "Too late for \"-T\" option");
1789         s++;
1790         return s;
1791     case 'u':
1792 #ifdef MACOS_TRADITIONAL
1793         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
1794 #endif
1795         PL_do_undump = TRUE;
1796         s++;
1797         return s;
1798     case 'U':
1799         PL_unsafe = TRUE;
1800         s++;
1801         return s;
1802     case 'v':
1803 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1804         printf("\nThis is perl, version %d.%03d_%02d built for %s",
1805             PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1806 #else
1807         printf("\nThis is perl, version %s built for %s",
1808                 PL_patchlevel, ARCHNAME);
1809 #endif
1810 #if defined(LOCAL_PATCH_COUNT)
1811         if (LOCAL_PATCH_COUNT > 0)
1812             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1813                 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1814 #endif
1815
1816         printf("\n\nCopyright 1987-1999, Larry Wall\n");
1817 #ifdef MACOS_TRADITIONAL
1818         fputs("Macintosh port Copyright 1991-1999, Matthias Neeracher\n", stdout);
1819 #endif
1820 #ifdef MSDOS
1821         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1822 #endif
1823 #ifdef DJGPP
1824         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1825         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1826 #endif
1827 #ifdef OS2
1828         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1829             "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1830 #endif
1831 #ifdef atarist
1832         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1833 #endif
1834 #ifdef __BEOS__
1835         printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1836 #endif
1837 #ifdef MPE
1838         printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1839 #endif
1840 #ifdef OEMVS
1841         printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1842 #endif
1843 #ifdef __VOS__
1844         printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1845 #endif
1846 #ifdef __OPEN_VM
1847         printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1848 #endif
1849 #ifdef POSIX_BC
1850         printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1851 #endif
1852 #ifdef __MINT__
1853         printf("MiNT port by Guido Flohr, 1997-1999\n");
1854 #endif
1855 #ifdef BINARY_BUILD_NOTICE
1856         BINARY_BUILD_NOTICE;
1857 #endif
1858         printf("\n\
1859 Perl may be copied only under the terms of either the Artistic License or the\n\
1860 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1861 Complete documentation for Perl, including FAQ lists, should be found on\n\
1862 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
1863 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1864         PerlProc_exit(0);
1865     case 'w':
1866         if (! (PL_dowarn & G_WARN_ALL_MASK))
1867             PL_dowarn |= G_WARN_ON;
1868         s++;
1869         return s;
1870     case 'W':
1871         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1872         PL_compiling.cop_warnings = WARN_ALL ;
1873         s++;
1874         return s;
1875     case 'X':
1876         PL_dowarn = G_WARN_ALL_OFF;
1877         PL_compiling.cop_warnings = WARN_NONE ;
1878         s++;
1879         return s;
1880     case '*':
1881     case ' ':
1882         if (s[1] == '-')        /* Additional switches on #! line. */
1883             return s+2;
1884         break;
1885     case '-':
1886     case 0:
1887 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1888     case '\r':
1889 #endif
1890     case '\n':
1891     case '\t':
1892         break;
1893 #ifdef ALTERNATE_SHEBANG
1894     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1895         break;
1896 #endif
1897     case 'P':
1898         if (PL_preprocess)
1899             return s+1;
1900         /* FALL THROUGH */
1901     default:
1902         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1903     }
1904     return Nullch;
1905 }
1906
1907 /* compliments of Tom Christiansen */
1908
1909 /* unexec() can be found in the Gnu emacs distribution */
1910 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1911
1912 void
1913 Perl_my_unexec(pTHX)
1914 {
1915 #ifdef UNEXEC
1916     SV*    prog;
1917     SV*    file;
1918     int    status = 1;
1919     extern int etext;
1920
1921     prog = newSVpv(BIN_EXP, 0);
1922     sv_catpv(prog, "/perl");
1923     file = newSVpv(PL_origfilename, 0);
1924     sv_catpv(file, ".perldump");
1925
1926     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1927     /* unexec prints msg to stderr in case of failure */
1928     PerlProc_exit(status);
1929 #else
1930 #  ifdef VMS
1931 #    include <lib$routines.h>
1932      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1933 #  else
1934     ABORT();            /* for use with undump */
1935 #  endif
1936 #endif
1937 }
1938
1939 /* initialize curinterp */
1940 STATIC void
1941 S_init_interp(pTHX)
1942 {
1943
1944 #ifdef PERL_OBJECT              /* XXX kludge */
1945 #define I_REINIT \
1946   STMT_START {                          \
1947     PL_chopset          = " \n-";       \
1948     PL_copline          = NOLINE;       \
1949     PL_curcop           = &PL_compiling;\
1950     PL_curcopdb         = NULL;         \
1951     PL_dbargs           = 0;            \
1952     PL_dumpindent       = 4;            \
1953     PL_laststatval      = -1;           \
1954     PL_laststype        = OP_STAT;      \
1955     PL_maxscream        = -1;           \
1956     PL_maxsysfd         = MAXSYSFD;     \
1957     PL_statname         = Nullsv;       \
1958     PL_tmps_floor       = -1;           \
1959     PL_tmps_ix          = -1;           \
1960     PL_op_mask          = NULL;         \
1961     PL_laststatval      = -1;           \
1962     PL_laststype        = OP_STAT;      \
1963     PL_mess_sv          = Nullsv;       \
1964     PL_splitstr         = " ";          \
1965     PL_generation       = 100;          \
1966     PL_exitlist         = NULL;         \
1967     PL_exitlistlen      = 0;            \
1968     PL_regindent        = 0;            \
1969     PL_in_clean_objs    = FALSE;        \
1970     PL_in_clean_all     = FALSE;        \
1971     PL_profiledata      = NULL;         \
1972     PL_rsfp             = Nullfp;       \
1973     PL_rsfp_filters     = Nullav;       \
1974     PL_dirty            = FALSE;        \
1975   } STMT_END
1976     I_REINIT;
1977 #else
1978 #  ifdef MULTIPLICITY
1979 #    define PERLVAR(var,type)
1980 #    define PERLVARA(var,n,type)
1981 #    if defined(PERL_IMPLICIT_CONTEXT)
1982 #      if defined(USE_THREADS)
1983 #        define PERLVARI(var,type,init)         PERL_GET_INTERP->var = init;
1984 #        define PERLVARIC(var,type,init)        PERL_GET_INTERP->var = init;
1985 #      else /* !USE_THREADS */
1986 #        define PERLVARI(var,type,init)         aTHX->var = init;
1987 #        define PERLVARIC(var,type,init)        aTHX->var = init;
1988 #      endif /* USE_THREADS */
1989 #    else
1990 #      define PERLVARI(var,type,init)   PERL_GET_INTERP->var = init;
1991 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
1992 #    endif
1993 #    include "intrpvar.h"
1994 #    ifndef USE_THREADS
1995 #      include "thrdvar.h"
1996 #    endif
1997 #    undef PERLVAR
1998 #    undef PERLVARA
1999 #    undef PERLVARI
2000 #    undef PERLVARIC
2001 #  else
2002 #    define PERLVAR(var,type)
2003 #    define PERLVARA(var,n,type)
2004 #    define PERLVARI(var,type,init)     PL_##var = init;
2005 #    define PERLVARIC(var,type,init)    PL_##var = init;
2006 #    include "intrpvar.h"
2007 #    ifndef USE_THREADS
2008 #      include "thrdvar.h"
2009 #    endif
2010 #    undef PERLVAR
2011 #    undef PERLVARA
2012 #    undef PERLVARI
2013 #    undef PERLVARIC
2014 #  endif
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