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