perl.c

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