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