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