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