perl.c

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