perl.c

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