perl.c

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