perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (c) 1987-2002 Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
  12  */
  13
  14 #include "EXTERN.h"
  15 #define PERL_IN_PERL_C
  16 #include "perl.h"
  17 #include "patchlevel.h"                 /* for local_patches */
  18
  19 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  20 #ifdef I_UNISTD
  21 #include <unistd.h>
  22 #endif
  23
  24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
  25 char *getenv (char *); /* Usually in <stdlib.h> */
  26 #endif
  27
  28 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
  29
  30 #ifdef IAMSUID
  31 #ifndef DOSUID
  32 #define DOSUID
  33 #endif
  34 #endif
  35
  36 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  37 #ifdef DOSUID
  38 #undef DOSUID
  39 #endif
  40 #endif
  41
  42 #if defined(USE_5005THREADS)
  43 #  define INIT_TLS_AND_INTERP \
  44     STMT_START {                                \
  45         if (!PL_curinterp) {                    \
  46             PERL_SET_INTERP(my_perl);           \
  47             INIT_THREADS;                       \
  48             ALLOC_THREAD_KEY;                   \
  49         }                                       \
  50     } STMT_END
  51 #else
  52 #  if defined(USE_ITHREADS)
  53 #  define INIT_TLS_AND_INTERP \
  54     STMT_START {                                \
  55         if (!PL_curinterp) {                    \
  56             PERL_SET_INTERP(my_perl);           \
  57             INIT_THREADS;                       \
  58             ALLOC_THREAD_KEY;                   \
  59             PERL_SET_THX(my_perl);              \
  60             OP_REFCNT_INIT;                     \
  61         }                                       \
  62         else {                                  \
  63             PERL_SET_THX(my_perl);              \
  64         }                                       \
  65     } STMT_END
  66 #  else
  67 #  define INIT_TLS_AND_INTERP \
  68     STMT_START {                                \
  69         if (!PL_curinterp) {                    \
  70             PERL_SET_INTERP(my_perl);           \
  71         }                                       \
  72         PERL_SET_THX(my_perl);                  \
  73     } STMT_END
  74 #  endif
  75 #endif
  76
  77 #ifdef PERL_IMPLICIT_SYS
  78 PerlInterpreter *
  79 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
  80                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
  81                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
  82                  struct IPerlDir* ipD, struct IPerlSock* ipS,
  83                  struct IPerlProc* ipP)
  84 {
  85     PerlInterpreter *my_perl;
  86     /* New() needs interpreter, so call malloc() instead */
  87     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
  88     INIT_TLS_AND_INTERP;
  89     Zero(my_perl, 1, PerlInterpreter);
  90     PL_Mem = ipM;
  91     PL_MemShared = ipMS;
  92     PL_MemParse = ipMP;
  93     PL_Env = ipE;
  94     PL_StdIO = ipStd;
  95     PL_LIO = ipLIO;
  96     PL_Dir = ipD;
  97     PL_Sock = ipS;
  98     PL_Proc = ipP;
  99
 100     return my_perl;
 101 }
 102 #else
 103
 104 /*
 105 =head1 Embedding Functions
 106
 107 =for apidoc perl_alloc
 108
 109 Allocates a new Perl interpreter.  See L<perlembed>.
 110
 111 =cut
 112 */
 113
 114 PerlInterpreter *
 115 perl_alloc(void)
 116 {
 117     PerlInterpreter *my_perl;
 118 #ifdef USE_5005THREADS
 119     dTHX;
 120 #endif
 121
 122     /* New() needs interpreter, so call malloc() instead */
 123     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
 124
 125     INIT_TLS_AND_INTERP;
 126     Zero(my_perl, 1, PerlInterpreter);
 127     return my_perl;
 128 }
 129 #endif /* PERL_IMPLICIT_SYS */
 130
 131 /*
 132 =for apidoc perl_construct
 133
 134 Initializes a new Perl interpreter.  See L<perlembed>.
 135
 136 =cut
 137 */
 138
 139 void
 140 perl_construct(pTHXx)
 141 {
 142 #ifdef USE_5005THREADS
 143 #ifndef FAKE_THREADS
 144     struct perl_thread *thr = NULL;
 145 #endif /* FAKE_THREADS */
 146 #endif /* USE_5005THREADS */
 147
 148 #ifdef MULTIPLICITY
 149     init_interp();
 150     PL_perl_destruct_level = 1;
 151 #else
 152    if (PL_perl_destruct_level > 0)
 153        init_interp();
 154 #endif
 155
 156    /* Init the real globals (and main thread)? */
 157     if (!PL_linestr) {
 158 #ifdef USE_5005THREADS
 159         MUTEX_INIT(&PL_sv_mutex);
 160         /*
 161          * Safe to use basic SV functions from now on (though
 162          * not things like mortals or tainting yet).
 163          */
 164         MUTEX_INIT(&PL_eval_mutex);
 165         COND_INIT(&PL_eval_cond);
 166         MUTEX_INIT(&PL_threads_mutex);
 167         COND_INIT(&PL_nthreads_cond);
 168 #  ifdef EMULATE_ATOMIC_REFCOUNTS
 169         MUTEX_INIT(&PL_svref_mutex);
 170 #  endif /* EMULATE_ATOMIC_REFCOUNTS */
 171
 172         MUTEX_INIT(&PL_cred_mutex);
 173         MUTEX_INIT(&PL_sv_lock_mutex);
 174         MUTEX_INIT(&PL_fdpid_mutex);
 175
 176         thr = init_main_thread();
 177 #endif /* USE_5005THREADS */
 178
 179 #ifdef PERL_FLEXIBLE_EXCEPTIONS
 180         PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
 181 #endif
 182
 183         PL_curcop = &PL_compiling;      /* needed by ckWARN, right away */
 184
 185         PL_linestr = NEWSV(65,79);
 186         sv_upgrade(PL_linestr,SVt_PVIV);
 187
 188         if (!SvREADONLY(&PL_sv_undef)) {
 189             /* set read-only and try to insure than we wont see REFCNT==0
 190                very often */
 191
 192             SvREADONLY_on(&PL_sv_undef);
 193             SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
 194
 195             sv_setpv(&PL_sv_no,PL_No);
 196             SvNV(&PL_sv_no);
 197             SvREADONLY_on(&PL_sv_no);
 198             SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
 199
 200             sv_setpv(&PL_sv_yes,PL_Yes);
 201             SvNV(&PL_sv_yes);
 202             SvREADONLY_on(&PL_sv_yes);
 203             SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
 204         }
 205
 206         PL_sighandlerp = Perl_sighandler;
 207         PL_pidstatus = newHV();
 208     }
 209
 210     PL_rs = newSVpvn("\n", 1);
 211
 212     init_stacks();
 213
 214     init_ids();
 215     PL_lex_state = LEX_NOTPARSING;
 216
 217     JMPENV_BOOTSTRAP;
 218     STATUS_ALL_SUCCESS;
 219
 220     init_i18nl10n(1);
 221     SET_NUMERIC_STANDARD();
 222
 223     {
 224         U8 *s;
 225         PL_patchlevel = NEWSV(0,4);
 226         (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
 227         if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
 228             SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
 229         s = (U8*)SvPVX(PL_patchlevel);
 230         /* Build version strings using "native" characters */
 231         s = uvchr_to_utf8(s, (UV)PERL_REVISION);
 232         s = uvchr_to_utf8(s, (UV)PERL_VERSION);
 233         s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
 234         *s = '\0';
 235         SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
 236         SvPOK_on(PL_patchlevel);
 237         SvNVX(PL_patchlevel) = (NV)PERL_REVISION
 238                                 + ((NV)PERL_VERSION / (NV)1000)
 239 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
 240                                 + ((NV)PERL_SUBVERSION / (NV)1000000)
 241 #endif
 242                                 ;
 243         SvNOK_on(PL_patchlevel);        /* dual valued */
 244         SvUTF8_on(PL_patchlevel);
 245         SvREADONLY_on(PL_patchlevel);
 246     }
 247
 248 #if defined(LOCAL_PATCH_COUNT)
 249     PL_localpatches = local_patches;    /* For possible -v */
 250 #endif
 251
 252 #ifdef HAVE_INTERP_INTERN
 253     sys_intern_init();
 254 #endif
 255
 256     PerlIO_init(aTHX);                  /* Hook to IO system */
 257
 258     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
 259     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
 260     PL_errors = newSVpvn("",0);
 261 #ifdef USE_ITHREADS
 262     PL_regex_padav = newAV();
 263     av_push(PL_regex_padav,(SV*)newAV());    /* First entry is an array of empty elements */
 264     PL_regex_pad = AvARRAY(PL_regex_padav);
 265 #endif
 266 #ifdef USE_REENTRANT_API
 267     Perl_reentrant_init(aTHX);
 268 #endif
 269
 270     /* Note that strtab is a rather special HV.  Assumptions are made
 271        about not iterating on it, and not adding tie magic to it.
 272        It is properly deallocated in perl_destruct() */
 273     PL_strtab = newHV();
 274
 275 #ifdef USE_5005THREADS
 276     MUTEX_INIT(&PL_strtab_mutex);
 277 #endif
 278     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
 279     hv_ksplit(PL_strtab, 512);
 280
 281 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
 282     _dyld_lookup_and_bind
 283         ("__environ", (unsigned long *) &environ_pointer, NULL);
 284 #endif /* environ */
 285
 286 #ifdef  USE_ENVIRON_ARRAY
 287     PL_origenviron = environ;
 288 #endif
 289
 290     ENTER;
 291 }
 292
 293 /*
 294 =for apidoc perl_destruct
 295
 296 Shuts down a Perl interpreter.  See L<perlembed>.
 297
 298 =cut
 299 */
 300
 301 int
 302 perl_destruct(pTHXx)
 303 {
 304     volatile int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 305     HV *hv;
 306 #ifdef USE_5005THREADS
 307     Thread t;
 308     dTHX;
 309 #endif /* USE_5005THREADS */
 310
 311     /* wait for all pseudo-forked children to finish */
 312     PERL_WAIT_FOR_CHILDREN;
 313
 314 #ifdef USE_5005THREADS
 315 #ifndef FAKE_THREADS
 316     /* Pass 1 on any remaining threads: detach joinables, join zombies */
 317   retry_cleanup:
 318     MUTEX_LOCK(&PL_threads_mutex);
 319     DEBUG_S(PerlIO_printf(Perl_debug_log,
 320                           "perl_destruct: waiting for %d threads...\n",
 321                           PL_nthreads - 1));
 322     for (t = thr->next; t != thr; t = t->next) {
 323         MUTEX_LOCK(&t->mutex);
 324         switch (ThrSTATE(t)) {
 325             AV *av;
 326         case THRf_ZOMBIE:
 327             DEBUG_S(PerlIO_printf(Perl_debug_log,
 328                                   "perl_destruct: joining zombie %p\n", t));
 329             ThrSETSTATE(t, THRf_DEAD);
 330             MUTEX_UNLOCK(&t->mutex);
 331             PL_nthreads--;
 332             /*
 333              * The SvREFCNT_dec below may take a long time (e.g. av
 334              * may contain an object scalar whose destructor gets
 335              * called) so we have to unlock threads_mutex and start
 336              * all over again.
 337              */
 338             MUTEX_UNLOCK(&PL_threads_mutex);
 339             JOIN(t, &av);
 340             SvREFCNT_dec((SV*)av);
 341             DEBUG_S(PerlIO_printf(Perl_debug_log,
 342                                   "perl_destruct: joined zombie %p OK\n", t));
 343             goto retry_cleanup;
 344         case THRf_R_JOINABLE:
 345             DEBUG_S(PerlIO_printf(Perl_debug_log,
 346                                   "perl_destruct: detaching thread %p\n", t));
 347             ThrSETSTATE(t, THRf_R_DETACHED);
 348             /*
 349              * We unlock threads_mutex and t->mutex in the opposite order
 350              * from which we locked them just so that DETACH won't
 351              * deadlock if it panics. It's only a breach of good style
 352              * not a bug since they are unlocks not locks.
 353              */
 354             MUTEX_UNLOCK(&PL_threads_mutex);
 355             DETACH(t);
 356             MUTEX_UNLOCK(&t->mutex);
 357             goto retry_cleanup;
 358         default:
 359             DEBUG_S(PerlIO_printf(Perl_debug_log,
 360                                   "perl_destruct: ignoring %p (state %u)\n",
 361                                   t, ThrSTATE(t)));
 362             MUTEX_UNLOCK(&t->mutex);
 363             /* fall through and out */
 364         }
 365     }
 366     /* We leave the above "Pass 1" loop with threads_mutex still locked */
 367
 368     /* Pass 2 on remaining threads: wait for the thread count to drop to one */
 369     while (PL_nthreads > 1)
 370     {
 371         DEBUG_S(PerlIO_printf(Perl_debug_log,
 372                               "perl_destruct: final wait for %d threads\n",
 373                               PL_nthreads - 1));
 374         COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
 375     }
 376     /* At this point, we're the last thread */
 377     MUTEX_UNLOCK(&PL_threads_mutex);
 378     DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
 379     MUTEX_DESTROY(&PL_threads_mutex);
 380     COND_DESTROY(&PL_nthreads_cond);
 381     PL_nthreads--;
 382 #endif /* !defined(FAKE_THREADS) */
 383 #endif /* USE_5005THREADS */
 384
 385     destruct_level = PL_perl_destruct_level;
 386 #ifdef DEBUGGING
 387     {
 388         char *s;
 389         if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
 390             int i = atoi(s);
 391             if (destruct_level < i)
 392                 destruct_level = i;
 393         }
 394     }
 395 #endif
 396
 397
 398     if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
 399         dJMPENV;
 400         int x = 0;
 401
 402         JMPENV_PUSH(x);
 403         if (PL_endav && !PL_minus_c)
 404             call_list(PL_scopestack_ix, PL_endav);
 405         JMPENV_POP;
 406     }
 407     LEAVE;
 408     FREETMPS;
 409
 410     /* We must account for everything.  */
 411
 412     /* Destroy the main CV and syntax tree */
 413     if (PL_main_root) {
 414         PL_curpad = AvARRAY(PL_comppad);
 415         op_free(PL_main_root);
 416         PL_main_root = Nullop;
 417     }
 418     PL_curcop = &PL_compiling;
 419     PL_main_start = Nullop;
 420     SvREFCNT_dec(PL_main_cv);
 421     PL_main_cv = Nullcv;
 422     PL_dirty = TRUE;
 423
 424     /* Tell PerlIO we are about to tear things apart in case
 425        we have layers which are using resources that should
 426        be cleaned up now.
 427      */
 428
 429     PerlIO_destruct(aTHX);
 430
 431     if (PL_sv_objcount) {
 432         /*
 433          * Try to destruct global references.  We do this first so that the
 434          * destructors and destructees still exist.  Some sv's might remain.
 435          * Non-referenced objects are on their own.
 436          */
 437         sv_clean_objs();
 438     }
 439
 440     /* unhook hooks which will soon be, or use, destroyed data */
 441     SvREFCNT_dec(PL_warnhook);
 442     PL_warnhook = Nullsv;
 443     SvREFCNT_dec(PL_diehook);
 444     PL_diehook = Nullsv;
 445
 446     /* call exit list functions */
 447     while (PL_exitlistlen-- > 0)
 448         PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
 449
 450     Safefree(PL_exitlist);
 451
 452     if (destruct_level == 0){
 453
 454         DEBUG_P(debprofdump());
 455
 456 #if defined(PERLIO_LAYERS)
 457         /* No more IO - including error messages ! */
 458         PerlIO_cleanup(aTHX);
 459 #endif
 460
 461         /* The exit() function will do everything that needs doing. */
 462         return STATUS_NATIVE_EXPORT;;
 463     }
 464
 465     /* jettison our possibly duplicated environment */
 466     /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
 467      * so we certainly shouldn't free it here
 468      */
 469 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
 470     if (environ != PL_origenviron) {
 471         I32 i;
 472
 473         for (i = 0; environ[i]; i++)
 474             safesysfree(environ[i]);
 475
 476         /* Must use safesysfree() when working with environ. */
 477         safesysfree(environ);
 478
 479         environ = PL_origenviron;
 480     }
 481 #endif
 482
 483 #ifdef USE_ITHREADS
 484     /* the syntax tree is shared between clones
 485      * so op_free(PL_main_root) only ReREFCNT_dec's
 486      * REGEXPs in the parent interpreter
 487      * we need to manually ReREFCNT_dec for the clones
 488      */
 489     {
 490         I32 i = AvFILLp(PL_regex_padav) + 1;
 491         SV **ary = AvARRAY(PL_regex_padav);
 492
 493         while (i) {
 494             SV *resv = ary[--i];
 495             REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
 496
 497             if (SvFLAGS(resv) & SVf_BREAK) {
 498                 /* this is PL_reg_curpm, already freed
 499                  * flag is set in regexec.c:S_regtry
 500                  */
 501                 SvFLAGS(resv) &= ~SVf_BREAK;
 502             }
 503             else if(SvREPADTMP(resv)) {
 504               SvREPADTMP_off(resv);
 505             }
 506             else {
 507                 ReREFCNT_dec(re);
 508             }
 509         }
 510     }
 511     SvREFCNT_dec(PL_regex_padav);
 512     PL_regex_padav = Nullav;
 513     PL_regex_pad = NULL;
 514 #endif
 515
 516     /* loosen bonds of global variables */
 517
 518     if(PL_rsfp) {
 519         (void)PerlIO_close(PL_rsfp);
 520         PL_rsfp = Nullfp;
 521     }
 522
 523     /* Filters for program text */
 524     SvREFCNT_dec(PL_rsfp_filters);
 525     PL_rsfp_filters = Nullav;
 526
 527     /* switches */
 528     PL_preprocess   = FALSE;
 529     PL_minus_n      = FALSE;
 530     PL_minus_p      = FALSE;
 531     PL_minus_l      = FALSE;
 532     PL_minus_a      = FALSE;
 533     PL_minus_F      = FALSE;
 534     PL_doswitches   = FALSE;
 535     PL_dowarn       = G_WARN_OFF;
 536     PL_doextract    = FALSE;
 537     PL_sawampersand = FALSE;    /* must save all match strings */
 538     PL_unsafe       = FALSE;
 539
 540     Safefree(PL_inplace);
 541     PL_inplace = Nullch;
 542     SvREFCNT_dec(PL_patchlevel);
 543
 544     if (PL_e_script) {
 545         SvREFCNT_dec(PL_e_script);
 546         PL_e_script = Nullsv;
 547     }
 548
 549     while (--PL_origargc >= 0) {
 550         Safefree(PL_origargv[PL_origargc]);
 551     }
 552     Safefree(PL_origargv);
 553
 554     /* magical thingies */
 555
 556     SvREFCNT_dec(PL_ofs_sv);    /* $, */
 557     PL_ofs_sv = Nullsv;
 558
 559     SvREFCNT_dec(PL_ors_sv);    /* $\ */
 560     PL_ors_sv = Nullsv;
 561
 562     SvREFCNT_dec(PL_rs);        /* $/ */
 563     PL_rs = Nullsv;
 564
 565     PL_multiline = 0;           /* $* */
 566     Safefree(PL_osname);        /* $^O */
 567     PL_osname = Nullch;
 568
 569     SvREFCNT_dec(PL_statname);
 570     PL_statname = Nullsv;
 571     PL_statgv = Nullgv;
 572
 573     /* defgv, aka *_ should be taken care of elsewhere */
 574
 575     /* clean up after study() */
 576     SvREFCNT_dec(PL_lastscream);
 577     PL_lastscream = Nullsv;
 578     Safefree(PL_screamfirst);
 579     PL_screamfirst = 0;
 580     Safefree(PL_screamnext);
 581     PL_screamnext  = 0;
 582
 583     /* float buffer */
 584     Safefree(PL_efloatbuf);
 585     PL_efloatbuf = Nullch;
 586     PL_efloatsize = 0;
 587
 588     /* startup and shutdown function lists */
 589     SvREFCNT_dec(PL_beginav);
 590     SvREFCNT_dec(PL_beginav_save);
 591     SvREFCNT_dec(PL_endav);
 592     SvREFCNT_dec(PL_checkav);
 593     SvREFCNT_dec(PL_initav);
 594     PL_beginav = Nullav;
 595     PL_beginav_save = Nullav;
 596     PL_endav = Nullav;
 597     PL_checkav = Nullav;
 598     PL_initav = Nullav;
 599
 600     /* shortcuts just get cleared */
 601     PL_envgv = Nullgv;
 602     PL_incgv = Nullgv;
 603     PL_hintgv = Nullgv;
 604     PL_errgv = Nullgv;
 605     PL_argvgv = Nullgv;
 606     PL_argvoutgv = Nullgv;
 607     PL_stdingv = Nullgv;
 608     PL_stderrgv = Nullgv;
 609     PL_last_in_gv = Nullgv;
 610     PL_replgv = Nullgv;
 611     PL_debstash = Nullhv;
 612
 613     /* reset so print() ends up where we expect */
 614     setdefout(Nullgv);
 615
 616     SvREFCNT_dec(PL_argvout_stack);
 617     PL_argvout_stack = Nullav;
 618
 619     SvREFCNT_dec(PL_modglobal);
 620     PL_modglobal = Nullhv;
 621     SvREFCNT_dec(PL_preambleav);
 622     PL_preambleav = Nullav;
 623     SvREFCNT_dec(PL_subname);
 624     PL_subname = Nullsv;
 625     SvREFCNT_dec(PL_linestr);
 626     PL_linestr = Nullsv;
 627     SvREFCNT_dec(PL_pidstatus);
 628     PL_pidstatus = Nullhv;
 629     SvREFCNT_dec(PL_toptarget);
 630     PL_toptarget = Nullsv;
 631     SvREFCNT_dec(PL_bodytarget);
 632     PL_bodytarget = Nullsv;
 633     PL_formtarget = Nullsv;
 634
 635     /* free locale stuff */
 636 #ifdef USE_LOCALE_COLLATE
 637     Safefree(PL_collation_name);
 638     PL_collation_name = Nullch;
 639 #endif
 640
 641 #ifdef USE_LOCALE_NUMERIC
 642     Safefree(PL_numeric_name);
 643     PL_numeric_name = Nullch;
 644     SvREFCNT_dec(PL_numeric_radix_sv);
 645 #endif
 646
 647     /* clear utf8 character classes */
 648     SvREFCNT_dec(PL_utf8_alnum);
 649     SvREFCNT_dec(PL_utf8_alnumc);
 650     SvREFCNT_dec(PL_utf8_ascii);
 651     SvREFCNT_dec(PL_utf8_alpha);
 652     SvREFCNT_dec(PL_utf8_space);
 653     SvREFCNT_dec(PL_utf8_cntrl);
 654     SvREFCNT_dec(PL_utf8_graph);
 655     SvREFCNT_dec(PL_utf8_digit);
 656     SvREFCNT_dec(PL_utf8_upper);
 657     SvREFCNT_dec(PL_utf8_lower);
 658     SvREFCNT_dec(PL_utf8_print);
 659     SvREFCNT_dec(PL_utf8_punct);
 660     SvREFCNT_dec(PL_utf8_xdigit);
 661     SvREFCNT_dec(PL_utf8_mark);
 662     SvREFCNT_dec(PL_utf8_toupper);
 663     SvREFCNT_dec(PL_utf8_totitle);
 664     SvREFCNT_dec(PL_utf8_tolower);
 665     SvREFCNT_dec(PL_utf8_tofold);
 666     PL_utf8_alnum       = Nullsv;
 667     PL_utf8_alnumc      = Nullsv;
 668     PL_utf8_ascii       = Nullsv;
 669     PL_utf8_alpha       = Nullsv;
 670     PL_utf8_space       = Nullsv;
 671     PL_utf8_cntrl       = Nullsv;
 672     PL_utf8_graph       = Nullsv;
 673     PL_utf8_digit       = Nullsv;
 674     PL_utf8_upper       = Nullsv;
 675     PL_utf8_lower       = Nullsv;
 676     PL_utf8_print       = Nullsv;
 677     PL_utf8_punct       = Nullsv;
 678     PL_utf8_xdigit      = Nullsv;
 679     PL_utf8_mark        = Nullsv;
 680     PL_utf8_toupper     = Nullsv;
 681     PL_utf8_totitle     = Nullsv;
 682     PL_utf8_tolower     = Nullsv;
 683     PL_utf8_tofold      = Nullsv;
 684
 685     if (!specialWARN(PL_compiling.cop_warnings))
 686         SvREFCNT_dec(PL_compiling.cop_warnings);
 687     PL_compiling.cop_warnings = Nullsv;
 688     if (!specialCopIO(PL_compiling.cop_io))
 689         SvREFCNT_dec(PL_compiling.cop_io);
 690     PL_compiling.cop_io = Nullsv;
 691     CopFILE_free(&PL_compiling);
 692     CopSTASH_free(&PL_compiling);
 693
 694     /* Prepare to destruct main symbol table.  */
 695
 696     hv = PL_defstash;
 697     PL_defstash = 0;
 698     SvREFCNT_dec(hv);
 699     SvREFCNT_dec(PL_curstname);
 700     PL_curstname = Nullsv;
 701
 702     /* clear queued errors */
 703     SvREFCNT_dec(PL_errors);
 704     PL_errors = Nullsv;
 705
 706     FREETMPS;
 707     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 708         if (PL_scopestack_ix != 0)
 709             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 710                  "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 711                  (long)PL_scopestack_ix);
 712         if (PL_savestack_ix != 0)
 713             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 714                  "Unbalanced saves: %ld more saves than restores\n",
 715                  (long)PL_savestack_ix);
 716         if (PL_tmps_floor != -1)
 717             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
 718                  (long)PL_tmps_floor + 1);
 719         if (cxstack_ix != -1)
 720             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
 721                  (long)cxstack_ix + 1);
 722     }
 723
 724     /* Now absolutely destruct everything, somehow or other, loops or no. */
 725     SvFLAGS(PL_fdpid) |= SVTYPEMASK;            /* don't clean out pid table now */
 726     SvFLAGS(PL_strtab) |= SVTYPEMASK;           /* don't clean out strtab now */
 727
 728     /* the 2 is for PL_fdpid and PL_strtab */
 729     while (PL_sv_count > 2 && sv_clean_all())
 730         ;
 731
 732     SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
 733     SvFLAGS(PL_fdpid) |= SVt_PVAV;
 734     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
 735     SvFLAGS(PL_strtab) |= SVt_PVHV;
 736
 737     AvREAL_off(PL_fdpid);               /* no surviving entries */
 738     SvREFCNT_dec(PL_fdpid);             /* needed in io_close() */
 739     PL_fdpid = Nullav;
 740
 741 #ifdef HAVE_INTERP_INTERN
 742     sys_intern_clear();
 743 #endif
 744
 745     /* Destruct the global string table. */
 746     {
 747         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 748          * so that sv_free() won't fail on them.
 749          */
 750         I32 riter;
 751         I32 max;
 752         HE *hent;
 753         HE **array;
 754
 755         riter = 0;
 756         max = HvMAX(PL_strtab);
 757         array = HvARRAY(PL_strtab);
 758         hent = array[0];
 759         for (;;) {
 760             if (hent && ckWARN_d(WARN_INTERNAL)) {
 761                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 762                      "Unbalanced string table refcount: (%d) for \"%s\"",
 763                      HeVAL(hent) - Nullsv, HeKEY(hent));
 764                 HeVAL(hent) = Nullsv;
 765                 hent = HeNEXT(hent);
 766             }
 767             if (!hent) {
 768                 if (++riter > max)
 769                     break;
 770                 hent = array[riter];
 771             }
 772         }
 773     }
 774     SvREFCNT_dec(PL_strtab);
 775
 776 #ifdef USE_ITHREADS
 777     /* free the pointer table used for cloning */
 778     ptr_table_free(PL_ptr_table);
 779 #endif
 780
 781     /* free special SVs */
 782
 783     SvREFCNT(&PL_sv_yes) = 0;
 784     sv_clear(&PL_sv_yes);
 785     SvANY(&PL_sv_yes) = NULL;
 786     SvFLAGS(&PL_sv_yes) = 0;
 787
 788     SvREFCNT(&PL_sv_no) = 0;
 789     sv_clear(&PL_sv_no);
 790     SvANY(&PL_sv_no) = NULL;
 791     SvFLAGS(&PL_sv_no) = 0;
 792
 793     SvREFCNT(&PL_sv_undef) = 0;
 794     SvREADONLY_off(&PL_sv_undef);
 795
 796     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 797         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
 798
 799 #if defined(PERLIO_LAYERS)
 800     /* No more IO - including error messages ! */
 801     PerlIO_cleanup(aTHX);
 802 #endif
 803
 804     Safefree(PL_origfilename);
 805     Safefree(PL_reg_start_tmp);
 806     if (PL_reg_curpm)
 807         Safefree(PL_reg_curpm);
 808     Safefree(PL_reg_poscache);
 809     Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
 810     Safefree(PL_op_mask);
 811     Safefree(PL_psig_ptr);
 812     Safefree(PL_psig_name);
 813     Safefree(PL_bitcount);
 814     Safefree(PL_psig_pend);
 815     nuke_stacks();
 816     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
 817
 818     DEBUG_P(debprofdump());
 819 #ifdef USE_5005THREADS
 820     MUTEX_DESTROY(&PL_strtab_mutex);
 821     MUTEX_DESTROY(&PL_sv_mutex);
 822     MUTEX_DESTROY(&PL_eval_mutex);
 823     MUTEX_DESTROY(&PL_cred_mutex);
 824     MUTEX_DESTROY(&PL_fdpid_mutex);
 825     COND_DESTROY(&PL_eval_cond);
 826 #ifdef EMULATE_ATOMIC_REFCOUNTS
 827     MUTEX_DESTROY(&PL_svref_mutex);
 828 #endif /* EMULATE_ATOMIC_REFCOUNTS */
 829
 830     /* As the penultimate thing, free the non-arena SV for thrsv */
 831     Safefree(SvPVX(PL_thrsv));
 832     Safefree(SvANY(PL_thrsv));
 833     Safefree(PL_thrsv);
 834     PL_thrsv = Nullsv;
 835 #endif /* USE_5005THREADS */
 836
 837 #ifdef USE_REENTRANT_API
 838     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_ packWARN(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 "-t              enable tainting warnings",
2165 "-u              dump core after parsing program",
2166 "-U              allow unsafe operations",
2167 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
2168 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
2169 "-w              enable many useful warnings (RECOMMENDED)",
2170 "-W              enable all warnings",
2171 "-X              disable all warnings",
2172 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
2173 "\n",
2174 NULL
2175 };
2176     char **p = usage_msg;
2177
2178     PerlIO_printf(PerlIO_stdout(),
2179                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2180                   name);
2181     while (*p)
2182         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2183 }
2184
2185 /* This routine handles any switches that can be given during run */
2186
2187 char *
2188 Perl_moreswitches(pTHX_ char *s)
2189 {
2190     STRLEN numlen;
2191     U32 rschar;
2192
2193     switch (*s) {
2194     case '0':
2195     {
2196         I32 flags = 0;
2197         numlen = 4;
2198         rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2199         SvREFCNT_dec(PL_rs);
2200         if (rschar & ~((U8)~0))
2201             PL_rs = &PL_sv_undef;
2202         else if (!rschar && numlen >= 2)
2203             PL_rs = newSVpvn("", 0);
2204         else {
2205             char ch = rschar;
2206             PL_rs = newSVpvn(&ch, 1);
2207         }
2208         return s + numlen;
2209     }
2210     case 'C':
2211         PL_widesyscalls = TRUE;
2212         s++;
2213         return s;
2214     case 'F':
2215         PL_minus_F = TRUE;
2216         PL_splitstr = ++s;
2217         while (*s && !isSPACE(*s)) ++s;
2218         *s = '\0';
2219         PL_splitstr = savepv(PL_splitstr);
2220         return s;
2221     case 'a':
2222         PL_minus_a = TRUE;
2223         s++;
2224         return s;
2225     case 'c':
2226         PL_minus_c = TRUE;
2227         s++;
2228         return s;
2229     case 'd':
2230         forbid_setid("-d");
2231         s++;
2232         /* The following permits -d:Mod to accepts arguments following an =
2233            in the fashion that -MSome::Mod does. */
2234         if (*s == ':' || *s == '=') {
2235             char *start;
2236             SV *sv;
2237             sv = newSVpv("use Devel::", 0);
2238             start = ++s;
2239             /* We now allow -d:Module=Foo,Bar */
2240             while(isALNUM(*s) || *s==':') ++s;
2241             if (*s != '=')
2242                 sv_catpv(sv, start);
2243             else {
2244                 sv_catpvn(sv, start, s-start);
2245                 sv_catpv(sv, " split(/,/,q{");
2246                 sv_catpv(sv, ++s);
2247                 sv_catpv(sv,    "})");
2248             }
2249             s += strlen(s);
2250             my_setenv("PERL5DB", SvPV(sv, PL_na));
2251         }
2252         if (!PL_perldb) {
2253             PL_perldb = PERLDB_ALL;
2254             init_debugger();
2255         }
2256         return s;
2257     case 'D':
2258     {
2259 #ifdef DEBUGGING
2260         forbid_setid("-D");
2261         if (isALPHA(s[1])) {
2262             /* if adding extra options, remember to update DEBUG_MASK */
2263             static char debopts[] = "psltocPmfrxuLHXDSTRJ";
2264             char *d;
2265
2266             for (s++; *s && (d = strchr(debopts,*s)); s++)
2267                 PL_debug |= 1 << (d - debopts);
2268         }
2269         else {
2270             PL_debug = atoi(s+1);
2271             for (s++; isDIGIT(*s); s++) ;
2272         }
2273         PL_debug |= DEBUG_TOP_FLAG;
2274 #else
2275         if (ckWARN_d(WARN_DEBUGGING))
2276             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2277                    "Recompile perl with -DDEBUGGING to use -D switch\n");
2278         for (s++; isALNUM(*s); s++) ;
2279 #endif
2280         /*SUPPRESS 530*/
2281         return s;
2282     }
2283     case 'h':
2284         usage(PL_origargv[0]);
2285         PerlProc_exit(0);
2286     case 'i':
2287         if (PL_inplace)
2288             Safefree(PL_inplace);
2289         PL_inplace = savepv(s+1);
2290         /*SUPPRESS 530*/
2291         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2292         if (*s) {
2293             *s++ = '\0';
2294             if (*s == '-')      /* Additional switches on #! line. */
2295                 s++;
2296         }
2297         return s;
2298     case 'I':   /* -I handled both here and in parse_body() */
2299         forbid_setid("-I");
2300         ++s;
2301         while (*s && isSPACE(*s))
2302             ++s;
2303         if (*s) {
2304             char *e, *p;
2305             p = s;
2306             /* ignore trailing spaces (possibly followed by other switches) */
2307             do {
2308                 for (e = p; *e && !isSPACE(*e); e++) ;
2309                 p = e;
2310                 while (isSPACE(*p))
2311                     p++;
2312             } while (*p && *p != '-');
2313             e = savepvn(s, e-s);
2314             incpush(e, TRUE, TRUE);
2315             Safefree(e);
2316             s = p;
2317             if (*s == '-')
2318                 s++;
2319         }
2320         else
2321             Perl_croak(aTHX_ "No directory specified for -I");
2322         return s;
2323     case 'l':
2324         PL_minus_l = TRUE;
2325         s++;
2326         if (PL_ors_sv) {
2327             SvREFCNT_dec(PL_ors_sv);
2328             PL_ors_sv = Nullsv;
2329         }
2330         if (isDIGIT(*s)) {
2331             I32 flags = 0;
2332             PL_ors_sv = newSVpvn("\n",1);
2333             numlen = 3 + (*s == '0');
2334             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2335             s += numlen;
2336         }
2337         else {
2338             if (RsPARA(PL_rs)) {
2339                 PL_ors_sv = newSVpvn("\n\n",2);
2340             }
2341             else {
2342                 PL_ors_sv = newSVsv(PL_rs);
2343             }
2344         }
2345         return s;
2346     case 'M':
2347         forbid_setid("-M");     /* XXX ? */
2348         /* FALL THROUGH */
2349     case 'm':
2350         forbid_setid("-m");     /* XXX ? */
2351         if (*++s) {
2352             char *start;
2353             SV *sv;
2354             char *use = "use ";
2355             /* -M-foo == 'no foo'       */
2356             if (*s == '-') { use = "no "; ++s; }
2357             sv = newSVpv(use,0);
2358             start = s;
2359             /* We allow -M'Module qw(Foo Bar)'  */
2360             while(isALNUM(*s) || *s==':') ++s;
2361             if (*s != '=') {
2362                 sv_catpv(sv, start);
2363                 if (*(start-1) == 'm') {
2364                     if (*s != '\0')
2365                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2366                     sv_catpv( sv, " ()");
2367                 }
2368             } else {
2369                 if (s == start)
2370                     Perl_croak(aTHX_ "Module name required with -%c option",
2371                                s[-1]);
2372                 sv_catpvn(sv, start, s-start);
2373                 sv_catpv(sv, " split(/,/,q{");
2374                 sv_catpv(sv, ++s);
2375                 sv_catpv(sv,    "})");
2376             }
2377             s += strlen(s);
2378             if (!PL_preambleav)
2379                 PL_preambleav = newAV();
2380             av_push(PL_preambleav, sv);
2381         }
2382         else
2383             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2384         return s;
2385     case 'n':
2386         PL_minus_n = TRUE;
2387         s++;
2388         return s;
2389     case 'p':
2390         PL_minus_p = TRUE;
2391         s++;
2392         return s;
2393     case 's':
2394         forbid_setid("-s");
2395         PL_doswitches = TRUE;
2396         s++;
2397         return s;
2398     case 't':
2399         if (!PL_tainting)
2400             Perl_croak(aTHX_ "Too late for \"-t\" option");
2401         s++;
2402         return s;
2403     case 'T':
2404         if (!PL_tainting)
2405             Perl_croak(aTHX_ "Too late for \"-T\" option");
2406         s++;
2407         return s;
2408     case 'u':
2409 #ifdef MACOS_TRADITIONAL
2410         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2411 #endif
2412         PL_do_undump = TRUE;
2413         s++;
2414         return s;
2415     case 'U':
2416         PL_unsafe = TRUE;
2417         s++;
2418         return s;
2419     case 'v':
2420 #if !defined(DGUX)
2421         PerlIO_printf(PerlIO_stdout(),
2422                       Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2423                                 PL_patchlevel, ARCHNAME));
2424 #else /* DGUX */
2425 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2426         PerlIO_printf(PerlIO_stdout(),
2427                         Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2428         PerlIO_printf(PerlIO_stdout(),
2429                         Perl_form(aTHX_ "        built under %s at %s %s\n",
2430                                         OSNAME, __DATE__, __TIME__));
2431         PerlIO_printf(PerlIO_stdout(),
2432                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
2433                                         OSVERS));
2434 #endif /* !DGUX */
2435
2436 #if defined(LOCAL_PATCH_COUNT)
2437         if (LOCAL_PATCH_COUNT > 0)
2438             PerlIO_printf(PerlIO_stdout(),
2439                           "\n(with %d registered patch%s, "
2440                           "see perl -V for more detail)",
2441                           (int)LOCAL_PATCH_COUNT,
2442                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2443 #endif
2444
2445         PerlIO_printf(PerlIO_stdout(),
2446                       "\n\nCopyright 1987-2002, Larry Wall\n");
2447 #ifdef MACOS_TRADITIONAL
2448         PerlIO_printf(PerlIO_stdout(),
2449                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2450                       "maintained by Chris Nandor\n");
2451 #endif
2452 #ifdef MSDOS
2453         PerlIO_printf(PerlIO_stdout(),
2454                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2455 #endif
2456 #ifdef DJGPP
2457         PerlIO_printf(PerlIO_stdout(),
2458                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2459                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2460 #endif
2461 #ifdef OS2
2462         PerlIO_printf(PerlIO_stdout(),
2463                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2464                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2465 #endif
2466 #ifdef atarist
2467         PerlIO_printf(PerlIO_stdout(),
2468                       "atariST series port, ++jrb  bammi@cadence.com\n");
2469 #endif
2470 #ifdef __BEOS__
2471         PerlIO_printf(PerlIO_stdout(),
2472                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
2473 #endif
2474 #ifdef MPE
2475         PerlIO_printf(PerlIO_stdout(),
2476                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2477 #endif
2478 #ifdef OEMVS
2479         PerlIO_printf(PerlIO_stdout(),
2480                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2481 #endif
2482 #ifdef __VOS__
2483         PerlIO_printf(PerlIO_stdout(),
2484                       "Stratus VOS port by Paul_Green@stratus.com, 1997-2002\n");
2485 #endif
2486 #ifdef __OPEN_VM
2487         PerlIO_printf(PerlIO_stdout(),
2488                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
2489 #endif
2490 #ifdef POSIX_BC
2491         PerlIO_printf(PerlIO_stdout(),
2492                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2493 #endif
2494 #ifdef __MINT__
2495         PerlIO_printf(PerlIO_stdout(),
2496                       "MiNT port by Guido Flohr, 1997-1999\n");
2497 #endif
2498 #ifdef EPOC
2499         PerlIO_printf(PerlIO_stdout(),
2500                       "EPOC port by Olaf Flebbe, 1999-2002\n");
2501 #endif
2502 #ifdef UNDER_CE
2503         printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2504         printf("Built on " __DATE__ " " __TIME__ "\n\n");
2505         wce_hitreturn();
2506 #endif
2507 #ifdef BINARY_BUILD_NOTICE
2508         BINARY_BUILD_NOTICE;
2509 #endif
2510         PerlIO_printf(PerlIO_stdout(),
2511                       "\n\
2512 Perl may be copied only under the terms of either the Artistic License or the\n\
2513 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2514 Complete documentation for Perl, including FAQ lists, should be found on\n\
2515 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
2516 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2517         PerlProc_exit(0);
2518     case 'w':
2519         if (! (PL_dowarn & G_WARN_ALL_MASK))
2520             PL_dowarn |= G_WARN_ON;
2521         s++;
2522         return s;
2523     case 'W':
2524         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2525         if (!specialWARN(PL_compiling.cop_warnings))
2526             SvREFCNT_dec(PL_compiling.cop_warnings);
2527         PL_compiling.cop_warnings = pWARN_ALL ;
2528         s++;
2529         return s;
2530     case 'X':
2531         PL_dowarn = G_WARN_ALL_OFF;
2532         if (!specialWARN(PL_compiling.cop_warnings))
2533             SvREFCNT_dec(PL_compiling.cop_warnings);
2534         PL_compiling.cop_warnings = pWARN_NONE ;
2535         s++;
2536         return s;
2537     case '*':
2538     case ' ':
2539         if (s[1] == '-')        /* Additional switches on #! line. */
2540             return s+2;
2541         break;
2542     case '-':
2543     case 0:
2544 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2545     case '\r':
2546 #endif
2547     case '\n':
2548     case '\t':
2549         break;
2550 #ifdef ALTERNATE_SHEBANG
2551     case 'S':                   /* OS/2 needs -S on "extproc" line. */
2552         break;
2553 #endif
2554     case 'P':
2555         if (PL_preprocess)
2556             return s+1;
2557         /* FALL THROUGH */
2558     default:
2559         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2560     }
2561     return Nullch;
2562 }
2563
2564 /* compliments of Tom Christiansen */
2565
2566 /* unexec() can be found in the Gnu emacs distribution */
2567 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2568
2569 void
2570 Perl_my_unexec(pTHX)
2571 {
2572 #ifdef UNEXEC
2573     SV*    prog;
2574     SV*    file;
2575     int    status = 1;
2576     extern int etext;
2577
2578     prog = newSVpv(BIN_EXP, 0);
2579     sv_catpv(prog, "/perl");
2580     file = newSVpv(PL_origfilename, 0);
2581     sv_catpv(file, ".perldump");
2582
2583     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2584     /* unexec prints msg to stderr in case of failure */
2585     PerlProc_exit(status);
2586 #else
2587 #  ifdef VMS
2588 #    include <lib$routines.h>
2589      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
2590 #  else
2591     ABORT();            /* for use with undump */
2592 #  endif
2593 #endif
2594 }
2595
2596 /* initialize curinterp */
2597 STATIC void
2598 S_init_interp(pTHX)
2599 {
2600
2601 #ifdef MULTIPLICITY
2602 #  define PERLVAR(var,type)
2603 #  define PERLVARA(var,n,type)
2604 #  if defined(PERL_IMPLICIT_CONTEXT)
2605 #    if defined(USE_5005THREADS)
2606 #      define PERLVARI(var,type,init)           PERL_GET_INTERP->var = init;
2607 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2608 #    else /* !USE_5005THREADS */
2609 #      define PERLVARI(var,type,init)           aTHX->var = init;
2610 #      define PERLVARIC(var,type,init)  aTHX->var = init;
2611 #    endif /* USE_5005THREADS */
2612 #  else
2613 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
2614 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
2615 #  endif
2616 #  include "intrpvar.h"
2617 #  ifndef USE_5005THREADS
2618 #    include "thrdvar.h"
2619 #  endif
2620 #  undef PERLVAR
2621 #  undef PERLVARA
2622 #  undef PERLVARI
2623 #  undef PERLVARIC
2624 #else
2625 #  define PERLVAR(var,type)
2626 #  define PERLVARA(var,n,type)
2627 #  define PERLVARI(var,type,init)       PL_##var = init;
2628 #  define PERLVARIC(var,type,init)      PL_##var = init;
2629 #  include "intrpvar.h"
2630 #  ifndef USE_5005THREADS
2631 #    include "thrdvar.h"
2632 #  endif
2633 #  undef PERLVAR
2634 #  undef PERLVARA
2635 #  undef PERLVARI
2636 #  undef PERLVARIC
2637 #endif
2638
2639 }
2640
2641 STATIC void
2642 S_init_main_stash(pTHX)
2643 {
2644     GV *gv;
2645
2646
2647
2648     PL_curstash = PL_defstash = newHV();
2649     PL_curstname = newSVpvn("main",4);
2650     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2651     SvREFCNT_dec(GvHV(gv));
2652     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2653     SvREADONLY_on(gv);
2654     HvNAME(PL_defstash) = savepv("main");
2655     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2656     GvMULTI_on(PL_incgv);
2657     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2658     GvMULTI_on(PL_hintgv);
2659     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2660     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2661     GvMULTI_on(PL_errgv);
2662     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2663     GvMULTI_on(PL_replgv);
2664     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2665     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2666     sv_setpvn(ERRSV, "", 0);
2667     PL_curstash = PL_defstash;
2668     CopSTASH_set(&PL_compiling, PL_defstash);
2669     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2670     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2671     PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2672     /* We must init $/ before switches are processed. */
2673     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2674 }
2675
2676 STATIC void
2677 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2678 {
2679     char *quote;
2680     char *code;
2681     char *cpp_discard_flag;
2682     char *perl;
2683
2684     *fdscript = -1;
2685
2686     if (PL_e_script) {
2687         PL_origfilename = savepv("-e");
2688     }
2689     else {
2690         /* if find_script() returns, it returns a malloc()-ed value */
2691         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2692
2693         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2694             char *s = scriptname + 8;
2695             *fdscript = atoi(s);
2696             while (isDIGIT(*s))
2697                 s++;
2698             if (*s) {
2699                 scriptname = savepv(s + 1);
2700                 Safefree(PL_origfilename);
2701                 PL_origfilename = scriptname;
2702             }
2703         }
2704     }
2705
2706     CopFILE_free(PL_curcop);
2707     CopFILE_set(PL_curcop, PL_origfilename);
2708     if (strEQ(PL_origfilename,"-"))
2709         scriptname = "";
2710     if (*fdscript >= 0) {
2711         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2712 #       if defined(HAS_FCNTL) && defined(F_SETFD)
2713             if (PL_rsfp)
2714                 /* ensure close-on-exec */
2715                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2716 #       endif
2717     }
2718     else if (PL_preprocess) {
2719         char *cpp_cfg = CPPSTDIN;
2720         SV *cpp = newSVpvn("",0);
2721         SV *cmd = NEWSV(0,0);
2722
2723         if (strEQ(cpp_cfg, "cppstdin"))
2724             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2725         sv_catpv(cpp, cpp_cfg);
2726
2727 #       ifndef VMS
2728             sv_catpvn(sv, "-I", 2);
2729             sv_catpv(sv,PRIVLIB_EXP);
2730 #       endif
2731
2732         DEBUG_P(PerlIO_printf(Perl_debug_log,
2733                               "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2734                               scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2735
2736 #       if defined(MSDOS) || defined(WIN32) || defined(VMS)
2737             quote = "\"";
2738 #       else
2739             quote = "'";
2740 #       endif
2741
2742 #       ifdef VMS
2743             cpp_discard_flag = "";
2744 #       else
2745             cpp_discard_flag = "-C";
2746 #       endif
2747
2748 #       ifdef OS2
2749             perl = os2_execname(aTHX);
2750 #       else
2751             perl = PL_origargv[0];
2752 #       endif
2753
2754
2755         /* This strips off Perl comments which might interfere with
2756            the C pre-processor, including #!.  #line directives are
2757            deliberately stripped to avoid confusion with Perl's version
2758            of #line.  FWP played some golf with it so it will fit
2759            into VMS's 255 character buffer.
2760         */
2761         if( PL_doextract )
2762             code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2763         else
2764             code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2765
2766         Perl_sv_setpvf(aTHX_ cmd, "\
2767 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2768                        perl, quote, code, quote, scriptname, cpp,
2769                        cpp_discard_flag, sv, CPPMINUS);
2770
2771         PL_doextract = FALSE;
2772 #       ifdef IAMSUID                   /* actually, this is caught earlier */
2773             if (PL_euid != PL_uid && !PL_euid) {  /* if running suidperl */
2774 #               ifdef HAS_SETEUID
2775                     (void)seteuid(PL_uid);        /* musn't stay setuid root */
2776 #               else
2777 #               ifdef HAS_SETREUID
2778                     (void)setreuid((Uid_t)-1, PL_uid);
2779 #               else
2780 #               ifdef HAS_SETRESUID
2781                     (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2782 #               else
2783                     PerlProc_setuid(PL_uid);
2784 #               endif
2785 #               endif
2786 #               endif
2787             if (PerlProc_geteuid() != PL_uid)
2788                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2789         }
2790 #       endif /* IAMSUID */
2791
2792         DEBUG_P(PerlIO_printf(Perl_debug_log,
2793                               "PL_preprocess: cmd=\"%s\"\n",
2794                               SvPVX(cmd)));
2795
2796         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2797         SvREFCNT_dec(cmd);
2798         SvREFCNT_dec(cpp);
2799     }
2800     else if (!*scriptname) {
2801         forbid_setid("program input from stdin");
2802         PL_rsfp = PerlIO_stdin();
2803     }
2804     else {
2805         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2806 #       if defined(HAS_FCNTL) && defined(F_SETFD)
2807             if (PL_rsfp)
2808                 /* ensure close-on-exec */
2809                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2810 #       endif
2811     }
2812     if (!PL_rsfp) {
2813 #       ifdef DOSUID
2814 #       ifndef IAMSUID  /* in case script is not readable before setuid */
2815             if (PL_euid &&
2816                 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2817                 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2818             {
2819                 /* try again */
2820                 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2821                                          BIN_EXP, (int)PERL_REVISION,
2822                                          (int)PERL_VERSION,
2823                                          (int)PERL_SUBVERSION), PL_origargv);
2824                 Perl_croak(aTHX_ "Can't do setuid\n");
2825             }
2826 #       endif
2827 #       endif
2828 #       ifdef IAMSUID
2829             errno = EPERM;
2830             Perl_croak(aTHX_ "Can't open perl script: %s\n",
2831                        Strerror(errno));
2832 #       else
2833             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2834                        CopFILE(PL_curcop), Strerror(errno));
2835 #       endif
2836     }
2837 }
2838
2839 /* Mention
2840  * I_SYSSTATVFS HAS_FSTATVFS
2841  * I_SYSMOUNT
2842  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
2843  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2844  * here so that metaconfig picks them up. */
2845
2846 #ifdef IAMSUID
2847 STATIC int
2848 S_fd_on_nosuid_fs(pTHX_ int fd)
2849 {
2850     int check_okay = 0; /* able to do all the required sys/libcalls */
2851     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2852 /*
2853  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2854  * fstatvfs() is UNIX98.
2855  * fstatfs() is 4.3 BSD.
2856  * ustat()+getmnt() is pre-4.3 BSD.
2857  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2858  * an irrelevant filesystem while trying to reach the right one.
2859  */
2860
2861 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
2862
2863 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2864         defined(HAS_FSTATVFS)
2865 #   define FD_ON_NOSUID_CHECK_OKAY
2866     struct statvfs stfs;
2867
2868     check_okay = fstatvfs(fd, &stfs) == 0;
2869     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2870 #   endif /* fstatvfs */
2871
2872 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2873         defined(PERL_MOUNT_NOSUID)      && \
2874         defined(HAS_FSTATFS)            && \
2875         defined(HAS_STRUCT_STATFS)      && \
2876         defined(HAS_STRUCT_STATFS_F_FLAGS)
2877 #   define FD_ON_NOSUID_CHECK_OKAY
2878     struct statfs  stfs;
2879
2880     check_okay = fstatfs(fd, &stfs)  == 0;
2881     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2882 #   endif /* fstatfs */
2883
2884 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2885         defined(PERL_MOUNT_NOSUID)      && \
2886         defined(HAS_FSTAT)              && \
2887         defined(HAS_USTAT)              && \
2888         defined(HAS_GETMNT)             && \
2889         defined(HAS_STRUCT_FS_DATA)     && \
2890         defined(NOSTAT_ONE)
2891 #   define FD_ON_NOSUID_CHECK_OKAY
2892     struct stat fdst;
2893
2894     if (fstat(fd, &fdst) == 0) {
2895         struct ustat us;
2896         if (ustat(fdst.st_dev, &us) == 0) {
2897             struct fs_data fsd;
2898             /* NOSTAT_ONE here because we're not examining fields which
2899              * vary between that case and STAT_ONE. */
2900             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2901                 size_t cmplen = sizeof(us.f_fname);
2902                 if (sizeof(fsd.fd_req.path) < cmplen)
2903                     cmplen = sizeof(fsd.fd_req.path);
2904                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2905                     fdst.st_dev == fsd.fd_req.dev) {
2906                         check_okay = 1;
2907                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2908                     }
2909                 }
2910             }
2911         }
2912     }
2913 #   endif /* fstat+ustat+getmnt */
2914
2915 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2916         defined(HAS_GETMNTENT)          && \
2917         defined(HAS_HASMNTOPT)          && \
2918         defined(MNTOPT_NOSUID)
2919 #   define FD_ON_NOSUID_CHECK_OKAY
2920     FILE                *mtab = fopen("/etc/mtab", "r");
2921     struct mntent       *entry;
2922     struct stat         stb, fsb;
2923
2924     if (mtab && (fstat(fd, &stb) == 0)) {
2925         while (entry = getmntent(mtab)) {
2926             if (stat(entry->mnt_dir, &fsb) == 0
2927                 && fsb.st_dev == stb.st_dev)
2928             {
2929                 /* found the filesystem */
2930                 check_okay = 1;
2931                 if (hasmntopt(entry, MNTOPT_NOSUID))
2932                     on_nosuid = 1;
2933                 break;
2934             } /* A single fs may well fail its stat(). */
2935         }
2936     }
2937     if (mtab)
2938         fclose(mtab);
2939 #   endif /* getmntent+hasmntopt */
2940
2941     if (!check_okay)
2942         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2943     return on_nosuid;
2944 }
2945 #endif /* IAMSUID */
2946
2947 STATIC void
2948 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2949 {
2950 #ifdef IAMSUID
2951     int which;
2952 #endif
2953
2954     /* do we need to emulate setuid on scripts? */
2955
2956     /* This code is for those BSD systems that have setuid #! scripts disabled
2957      * in the kernel because of a security problem.  Merely defining DOSUID
2958      * in perl will not fix that problem, but if you have disabled setuid
2959      * scripts in the kernel, this will attempt to emulate setuid and setgid
2960      * on scripts that have those now-otherwise-useless bits set.  The setuid
2961      * root version must be called suidperl or sperlN.NNN.  If regular perl
2962      * discovers that it has opened a setuid script, it calls suidperl with
2963      * the same argv that it had.  If suidperl finds that the script it has
2964      * just opened is NOT setuid root, it sets the effective uid back to the
2965      * uid.  We don't just make perl setuid root because that loses the
2966      * effective uid we had before invoking perl, if it was different from the
2967      * uid.
2968      *
2969      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2970      * be defined in suidperl only.  suidperl must be setuid root.  The
2971      * Configure script will set this up for you if you want it.
2972      */
2973
2974 #ifdef DOSUID
2975     char *s, *s2;
2976
2977     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2978         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2979     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2980         I32 len;
2981         STRLEN n_a;
2982
2983 #ifdef IAMSUID
2984 #ifndef HAS_SETREUID
2985         /* On this access check to make sure the directories are readable,
2986          * there is actually a small window that the user could use to make
2987          * filename point to an accessible directory.  So there is a faint
2988          * chance that someone could execute a setuid script down in a
2989          * non-accessible directory.  I don't know what to do about that.
2990          * But I don't think it's too important.  The manual lies when
2991          * it says access() is useful in setuid programs.
2992          */
2993         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2994             Perl_croak(aTHX_ "Permission denied");
2995 #else
2996         /* If we can swap euid and uid, then we can determine access rights
2997          * with a simple stat of the file, and then compare device and
2998          * inode to make sure we did stat() on the same file we opened.
2999          * Then we just have to make sure he or she can execute it.
3000          */
3001         {
3002             struct stat tmpstatbuf;
3003
3004             if (
3005 #ifdef HAS_SETREUID
3006                 setreuid(PL_euid,PL_uid) < 0
3007 #else
3008 # if HAS_SETRESUID
3009                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3010 # endif
3011 #endif
3012                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3013                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
3014             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3015                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
3016 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3017             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3018                 Perl_croak(aTHX_ "Permission denied");
3019 #endif
3020             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3021                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3022                 (void)PerlIO_close(PL_rsfp);
3023                 Perl_croak(aTHX_ "Permission denied\n");
3024             }
3025             if (
3026 #ifdef HAS_SETREUID
3027               setreuid(PL_uid,PL_euid) < 0
3028 #else
3029 # if defined(HAS_SETRESUID)
3030               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3031 # endif
3032 #endif
3033               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3034                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3035             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
3036                 Perl_croak(aTHX_ "Permission denied\n");
3037         }
3038 #endif /* HAS_SETREUID */
3039 #endif /* IAMSUID */
3040
3041         if (!S_ISREG(PL_statbuf.st_mode))
3042             Perl_croak(aTHX_ "Permission denied");
3043         if (PL_statbuf.st_mode & S_IWOTH)
3044             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3045         PL_doswitches = FALSE;          /* -s is insecure in suid */
3046         CopLINE_inc(PL_curcop);
3047         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3048           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3049             Perl_croak(aTHX_ "No #! line");
3050         s = SvPV(PL_linestr,n_a)+2;
3051         if (*s == ' ') s++;
3052         while (!isSPACE(*s)) s++;
3053         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
3054                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
3055         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
3056             Perl_croak(aTHX_ "Not a perl script");
3057         while (*s == ' ' || *s == '\t') s++;
3058         /*
3059          * #! arg must be what we saw above.  They can invoke it by
3060          * mentioning suidperl explicitly, but they may not add any strange
3061          * arguments beyond what #! says if they do invoke suidperl that way.
3062          */
3063         len = strlen(validarg);
3064         if (strEQ(validarg," PHOOEY ") ||
3065             strnNE(s,validarg,len) || !isSPACE(s[len]))
3066             Perl_croak(aTHX_ "Args must match #! line");
3067
3068 #ifndef IAMSUID
3069         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3070             PL_euid == PL_statbuf.st_uid)
3071             if (!PL_do_undump)
3072                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3073 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3074 #endif /* IAMSUID */
3075
3076         if (PL_euid) {  /* oops, we're not the setuid root perl */
3077             (void)PerlIO_close(PL_rsfp);
3078 #ifndef IAMSUID
3079             /* try again */
3080             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3081                                      (int)PERL_REVISION, (int)PERL_VERSION,
3082                                      (int)PERL_SUBVERSION), PL_origargv);
3083 #endif
3084             Perl_croak(aTHX_ "Can't do setuid\n");
3085         }
3086
3087         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3088 #ifdef HAS_SETEGID
3089             (void)setegid(PL_statbuf.st_gid);
3090 #else
3091 #ifdef HAS_SETREGID
3092            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3093 #else
3094 #ifdef HAS_SETRESGID
3095            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3096 #else
3097             PerlProc_setgid(PL_statbuf.st_gid);
3098 #endif
3099 #endif
3100 #endif
3101             if (PerlProc_getegid() != PL_statbuf.st_gid)
3102                 Perl_croak(aTHX_ "Can't do setegid!\n");
3103         }
3104         if (PL_statbuf.st_mode & S_ISUID) {
3105             if (PL_statbuf.st_uid != PL_euid)
3106 #ifdef HAS_SETEUID
3107                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
3108 #else
3109 #ifdef HAS_SETREUID
3110                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3111 #else
3112 #ifdef HAS_SETRESUID
3113                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3114 #else
3115                 PerlProc_setuid(PL_statbuf.st_uid);
3116 #endif
3117 #endif
3118 #endif
3119             if (PerlProc_geteuid() != PL_statbuf.st_uid)
3120                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3121         }
3122         else if (PL_uid) {                      /* oops, mustn't run as root */
3123 #ifdef HAS_SETEUID
3124           (void)seteuid((Uid_t)PL_uid);
3125 #else
3126 #ifdef HAS_SETREUID
3127           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3128 #else
3129 #ifdef HAS_SETRESUID
3130           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3131 #else
3132           PerlProc_setuid((Uid_t)PL_uid);
3133 #endif
3134 #endif
3135 #endif
3136             if (PerlProc_geteuid() != PL_uid)
3137                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3138         }
3139         init_ids();
3140         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3141             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
3142     }
3143 #ifdef IAMSUID
3144     else if (PL_preprocess)
3145         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3146     else if (fdscript >= 0)
3147         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3148     else
3149         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3150
3151     /* We absolutely must clear out any saved ids here, so we */
3152     /* exec the real perl, substituting fd script for scriptname. */
3153     /* (We pass script name as "subdir" of fd, which perl will grok.) */
3154     PerlIO_rewind(PL_rsfp);
3155     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3156     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3157     if (!PL_origargv[which])
3158         Perl_croak(aTHX_ "Permission denied");
3159     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3160                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3161 #if defined(HAS_FCNTL) && defined(F_SETFD)
3162     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3163 #endif
3164     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3165                              (int)PERL_REVISION, (int)PERL_VERSION,
3166                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
3167     Perl_croak(aTHX_ "Can't do setuid\n");
3168 #endif /* IAMSUID */
3169 #else /* !DOSUID */
3170     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3171 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3172         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
3173         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3174             ||
3175             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3176            )
3177             if (!PL_do_undump)
3178                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3179 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3180 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3181         /* not set-id, must be wrapped */
3182     }
3183 #endif /* DOSUID */
3184 }
3185
3186 STATIC void
3187 S_find_beginning(pTHX)
3188 {
3189     register char *s, *s2;
3190
3191     /* skip forward in input to the real script? */
3192
3193     forbid_setid("-x");
3194 #ifdef MACOS_TRADITIONAL
3195     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3196
3197     while (PL_doextract || gMacPerl_AlwaysExtract) {
3198         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3199             if (!gMacPerl_AlwaysExtract)
3200                 Perl_croak(aTHX_ "No Perl script found in input\n");
3201
3202             if (PL_doextract)                   /* require explicit override ? */
3203                 if (!OverrideExtract(PL_origfilename))
3204                     Perl_croak(aTHX_ "User aborted script\n");
3205                 else
3206                     PL_doextract = FALSE;
3207
3208             /* Pater peccavi, file does not have #! */
3209             PerlIO_rewind(PL_rsfp);
3210
3211             break;
3212         }
3213 #else
3214     while (PL_doextract) {
3215         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3216             Perl_croak(aTHX_ "No Perl script found in input\n");
3217 #endif
3218         s2 = s;
3219         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3220             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
3221             PL_doextract = FALSE;
3222             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3223             s2 = s;
3224             while (*s == ' ' || *s == '\t') s++;
3225             if (*s++ == '-') {
3226                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3227                 if (strnEQ(s2-4,"perl",4))
3228                     /*SUPPRESS 530*/
3229                     while ((s = moreswitches(s)))
3230                         ;
3231             }
3232 #ifdef MACOS_TRADITIONAL
3233             break;
3234 #endif
3235         }
3236     }
3237 }
3238
3239
3240 STATIC void
3241 S_init_ids(pTHX)
3242 {
3243     PL_uid = PerlProc_getuid();
3244     PL_euid = PerlProc_geteuid();
3245     PL_gid = PerlProc_getgid();
3246     PL_egid = PerlProc_getegid();
3247 #ifdef VMS
3248     PL_uid |= PL_gid << 16;
3249     PL_euid |= PL_egid << 16;
3250 #endif
3251     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3252 }
3253
3254 STATIC void
3255 S_forbid_setid(pTHX_ char *s)
3256 {
3257     if (PL_euid != PL_uid)
3258         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3259     if (PL_egid != PL_gid)
3260         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3261 }
3262
3263 void
3264 Perl_init_debugger(pTHX)
3265 {
3266     HV *ostash = PL_curstash;
3267
3268     PL_curstash = PL_debstash;
3269     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3270     AvREAL_off(PL_dbargs);
3271     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3272     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3273     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3274     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3275     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3276     sv_setiv(PL_DBsingle, 0);
3277     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3278     sv_setiv(PL_DBtrace, 0);
3279     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3280     sv_setiv(PL_DBsignal, 0);
3281     PL_curstash = ostash;
3282 }
3283
3284 #ifndef STRESS_REALLOC
3285 #define REASONABLE(size) (size)
3286 #else
3287 #define REASONABLE(size) (1) /* unreasonable */
3288 #endif
3289
3290 void
3291 Perl_init_stacks(pTHX)
3292 {
3293     /* start with 128-item stack and 8K cxstack */
3294     PL_curstackinfo = new_stackinfo(REASONABLE(128),
3295                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3296     PL_curstackinfo->si_type = PERLSI_MAIN;
3297     PL_curstack = PL_curstackinfo->si_stack;
3298     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
3299
3300     PL_stack_base = AvARRAY(PL_curstack);
3301     PL_stack_sp = PL_stack_base;
3302     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3303
3304     New(50,PL_tmps_stack,REASONABLE(128),SV*);
3305     PL_tmps_floor = -1;
3306     PL_tmps_ix = -1;
3307     PL_tmps_max = REASONABLE(128);
3308
3309     New(54,PL_markstack,REASONABLE(32),I32);
3310     PL_markstack_ptr = PL_markstack;
3311     PL_markstack_max = PL_markstack + REASONABLE(32);
3312
3313     SET_MARK_OFFSET;
3314
3315     New(54,PL_scopestack,REASONABLE(32),I32);
3316     PL_scopestack_ix = 0;
3317     PL_scopestack_max = REASONABLE(32);
3318
3319     New(54,PL_savestack,REASONABLE(128),ANY);
3320     PL_savestack_ix = 0;
3321     PL_savestack_max = REASONABLE(128);
3322
3323     New(54,PL_retstack,REASONABLE(16),OP*);
3324     PL_retstack_ix = 0;
3325     PL_retstack_max = REASONABLE(16);
3326 }
3327
3328 #undef REASONABLE
3329
3330 STATIC void
3331 S_nuke_stacks(pTHX)
3332 {
3333     while (PL_curstackinfo->si_next)
3334         PL_curstackinfo = PL_curstackinfo->si_next;
3335     while (PL_curstackinfo) {
3336         PERL_SI *p = PL_curstackinfo->si_prev;
3337         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3338         Safefree(PL_curstackinfo->si_cxstack);
3339         Safefree(PL_curstackinfo);
3340         PL_curstackinfo = p;
3341     }
3342     Safefree(PL_tmps_stack);
3343     Safefree(PL_markstack);
3344     Safefree(PL_scopestack);
3345     Safefree(PL_savestack);
3346     Safefree(PL_retstack);
3347 }
3348
3349 STATIC void
3350 S_init_lexer(pTHX)
3351 {
3352     PerlIO *tmpfp;
3353     tmpfp = PL_rsfp;
3354     PL_rsfp = Nullfp;
3355     lex_start(PL_linestr);
3356     PL_rsfp = tmpfp;
3357     PL_subname = newSVpvn("main",4);
3358 }
3359
3360 STATIC void
3361 S_init_predump_symbols(pTHX)
3362 {
3363     GV *tmpgv;
3364     IO *io;
3365
3366     sv_setpvn(get_sv("\"", TRUE), " ", 1);
3367     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3368     GvMULTI_on(PL_stdingv);
3369     io = GvIOp(PL_stdingv);
3370     IoTYPE(io) = IoTYPE_RDONLY;
3371     IoIFP(io) = PerlIO_stdin();
3372     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3373     GvMULTI_on(tmpgv);
3374     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3375
3376     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3377     GvMULTI_on(tmpgv);
3378     io = GvIOp(tmpgv);
3379     IoTYPE(io) = IoTYPE_WRONLY;
3380     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3381     setdefout(tmpgv);
3382     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3383     GvMULTI_on(tmpgv);
3384     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3385
3386     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3387     GvMULTI_on(PL_stderrgv);
3388     io = GvIOp(PL_stderrgv);
3389     IoTYPE(io) = IoTYPE_WRONLY;
3390     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3391     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3392     GvMULTI_on(tmpgv);
3393     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3394
3395     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
3396
3397     if (PL_osname)
3398         Safefree(PL_osname);
3399     PL_osname = savepv(OSNAME);
3400 }
3401
3402 void
3403 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3404 {
3405     char *s;
3406     argc--,argv++;      /* skip name of script */
3407     if (PL_doswitches) {
3408         for (; argc > 0 && **argv == '-'; argc--,argv++) {
3409             if (!argv[0][1])
3410                 break;
3411             if (argv[0][1] == '-' && !argv[0][2]) {
3412                 argc--,argv++;
3413                 break;
3414             }
3415             if ((s = strchr(argv[0], '='))) {
3416                 *s++ = '\0';
3417                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3418             }
3419             else
3420                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3421         }
3422     }
3423     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3424         GvMULTI_on(PL_argvgv);
3425         (void)gv_AVadd(PL_argvgv);
3426         av_clear(GvAVn(PL_argvgv));
3427         for (; argc > 0; argc--,argv++) {
3428             SV *sv = newSVpv(argv[0],0);
3429             av_push(GvAVn(PL_argvgv),sv);
3430             if (PL_widesyscalls)
3431                 (void)sv_utf8_decode(sv);
3432         }
3433     }
3434 }
3435
3436 #ifdef HAS_PROCSELFEXE
3437 /* This is a function so that we don't hold on to MAXPATHLEN
3438    bytes of stack longer than necessary
3439  */
3440 STATIC void
3441 S_procself_val(pTHX_ SV *sv, char *arg0)
3442 {
3443     char buf[MAXPATHLEN];
3444     int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3445     /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3446        returning the text "unknown" from the readlink rather than the path
3447        to the executable (or returning an error from the readlink).  Any valid
3448        path has a '/' in it somewhere, so use that to validate the result.
3449        See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3450     */
3451     if (len > 0 && memchr(buf, '/', len)) {
3452         sv_setpvn(sv,buf,len);
3453     }
3454     else {
3455         sv_setpv(sv,arg0);
3456     }
3457 }
3458 #endif /* HAS_PROCSELFEXE */
3459
3460 STATIC void
3461 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3462 {
3463     char *s;
3464     SV *sv;
3465     GV* tmpgv;
3466
3467     PL_toptarget = NEWSV(0,0);
3468     sv_upgrade(PL_toptarget, SVt_PVFM);
3469     sv_setpvn(PL_toptarget, "", 0);
3470     PL_bodytarget = NEWSV(0,0);
3471     sv_upgrade(PL_bodytarget, SVt_PVFM);
3472     sv_setpvn(PL_bodytarget, "", 0);
3473     PL_formtarget = PL_bodytarget;
3474
3475     TAINT;
3476
3477     init_argv_symbols(argc,argv);
3478
3479     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3480 #ifdef MACOS_TRADITIONAL
3481         /* $0 is not majick on a Mac */
3482         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3483 #else
3484         sv_setpv(GvSV(tmpgv),PL_origfilename);
3485         magicname("0", "0", 1);
3486 #endif
3487     }
3488     if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3489 #ifdef HAS_PROCSELFEXE
3490         S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3491 #else
3492 #ifdef OS2
3493         sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3494 #else
3495         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3496 #endif
3497 #endif
3498     }
3499     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3500         HV *hv;
3501         GvMULTI_on(PL_envgv);
3502         hv = GvHVn(PL_envgv);
3503         hv_magic(hv, Nullgv, PERL_MAGIC_env);
3504 #ifdef USE_ENVIRON_ARRAY
3505         /* Note that if the supplied env parameter is actually a copy
3506            of the global environ then it may now point to free'd memory
3507            if the environment has been modified since. To avoid this
3508            problem we treat env==NULL as meaning 'use the default'
3509         */
3510         if (!env)
3511             env = environ;
3512         if (env != environ)
3513             environ[0] = Nullch;
3514         if (env)
3515           for (; *env; env++) {
3516             if (!(s = strchr(*env,'=')))
3517                 continue;
3518 #if defined(MSDOS)
3519             *s = '\0';
3520             (void)strupr(*env);
3521             *s = '=';
3522 #endif
3523             sv = newSVpv(s+1, 0);
3524             (void)hv_store(hv, *env, s - *env, sv, 0);
3525             if (env != environ)
3526                 mg_set(sv);
3527           }
3528 #endif /* USE_ENVIRON_ARRAY */
3529     }
3530     TAINT_NOT;
3531     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3532         SvREADONLY_off(GvSV(tmpgv));
3533         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3534         SvREADONLY_on(GvSV(tmpgv));
3535     }
3536 }
3537
3538 STATIC void
3539 S_init_perllib(pTHX)
3540 {
3541     char *s;
3542     if (!PL_tainting) {
3543 #ifndef VMS
3544         s = PerlEnv_getenv("PERL5LIB");
3545         if (s)
3546             incpush(s, TRUE, TRUE);
3547         else
3548             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3549 #else /* VMS */
3550         /* Treat PERL5?LIB as a possible search list logical name -- the
3551          * "natural" VMS idiom for a Unix path string.  We allow each
3552          * element to be a set of |-separated directories for compatibility.
3553          */
3554         char buf[256];
3555         int idx = 0;
3556         if (my_trnlnm("PERL5LIB",buf,0))
3557             do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3558         else
3559             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3560 #endif /* VMS */
3561     }
3562
3563 /* Use the ~-expanded versions of APPLLIB (undocumented),
3564     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3565 */
3566 #ifdef APPLLIB_EXP
3567     incpush(APPLLIB_EXP, TRUE, TRUE);
3568 #endif
3569
3570 #ifdef ARCHLIB_EXP
3571     incpush(ARCHLIB_EXP, FALSE, FALSE);
3572 #endif
3573 #ifdef MACOS_TRADITIONAL
3574     {
3575         struct stat tmpstatbuf;
3576         SV * privdir = NEWSV(55, 0);
3577         char * macperl = PerlEnv_getenv("MACPERL");
3578
3579         if (!macperl)
3580             macperl = "";
3581
3582         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3583         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3584             incpush(SvPVX(privdir), TRUE, FALSE);
3585         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3586         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3587             incpush(SvPVX(privdir), TRUE, FALSE);
3588
3589         SvREFCNT_dec(privdir);
3590     }
3591     if (!PL_tainting)
3592         incpush(":", FALSE, FALSE);
3593 #else
3594 #ifndef PRIVLIB_EXP
3595 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3596 #endif
3597 #if defined(WIN32)
3598     incpush(PRIVLIB_EXP, TRUE, FALSE);
3599 #else
3600     incpush(PRIVLIB_EXP, FALSE, FALSE);
3601 #endif
3602
3603 #ifdef SITEARCH_EXP
3604     /* sitearch is always relative to sitelib on Windows for
3605      * DLL-based path intuition to work correctly */
3606 #  if !defined(WIN32)
3607     incpush(SITEARCH_EXP, FALSE, FALSE);
3608 #  endif
3609 #endif
3610
3611 #ifdef SITELIB_EXP
3612 #  if defined(WIN32)
3613     incpush(SITELIB_EXP, TRUE, FALSE);  /* this picks up sitearch as well */
3614 #  else
3615     incpush(SITELIB_EXP, FALSE, FALSE);
3616 #  endif
3617 #endif
3618
3619 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3620     incpush(SITELIB_STEM, FALSE, TRUE);
3621 #endif
3622
3623 #ifdef PERL_VENDORARCH_EXP
3624     /* vendorarch is always relative to vendorlib on Windows for
3625      * DLL-based path intuition to work correctly */
3626 #  if !defined(WIN32)
3627     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3628 #  endif
3629 #endif
3630
3631 #ifdef PERL_VENDORLIB_EXP
3632 #  if defined(WIN32)
3633     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE);   /* this picks up vendorarch as well */
3634 #  else
3635     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3636 #  endif
3637 #endif
3638
3639 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3640     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3641 #endif
3642
3643 #ifdef PERL_OTHERLIBDIRS
3644     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3645 #endif
3646
3647     if (!PL_tainting)
3648         incpush(".", FALSE, FALSE);
3649 #endif /* MACOS_TRADITIONAL */
3650 }
3651
3652 #if defined(DOSISH) || defined(EPOC)
3653 #    define PERLLIB_SEP ';'
3654 #else
3655 #  if defined(VMS)
3656 #    define PERLLIB_SEP '|'
3657 #  else
3658 #    if defined(MACOS_TRADITIONAL)
3659 #      define PERLLIB_SEP ','
3660 #    else
3661 #      define PERLLIB_SEP ':'
3662 #    endif
3663 #  endif
3664 #endif
3665 #ifndef PERLLIB_MANGLE
3666 #  define PERLLIB_MANGLE(s,n) (s)
3667 #endif
3668
3669 STATIC void
3670 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3671 {
3672     SV *subdir = Nullsv;
3673
3674     if (!p || !*p)
3675         return;
3676
3677     if (addsubdirs || addoldvers) {
3678         subdir = sv_newmortal();
3679     }
3680
3681     /* Break at all separators */
3682     while (p && *p) {
3683         SV *libdir = NEWSV(55,0);
3684         char *s;
3685
3686         /* skip any consecutive separators */
3687         while ( *p == PERLLIB_SEP ) {
3688             /* Uncomment the next line for PATH semantics */
3689             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3690             p++;
3691         }
3692
3693         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3694             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3695                       (STRLEN)(s - p));
3696             p = s + 1;
3697         }
3698         else {
3699             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3700             p = Nullch; /* break out */
3701         }
3702 #ifdef MACOS_TRADITIONAL
3703         if (!strchr(SvPVX(libdir), ':'))
3704             sv_insert(libdir, 0, 0, ":", 1);
3705         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3706             sv_catpv(libdir, ":");
3707 #endif
3708
3709         /*
3710          * BEFORE pushing libdir onto @INC we may first push version- and
3711          * archname-specific sub-directories.
3712          */
3713         if (addsubdirs || addoldvers) {
3714 #ifdef PERL_INC_VERSION_LIST
3715             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3716             const char *incverlist[] = { PERL_INC_VERSION_LIST };
3717             const char **incver;
3718 #endif
3719             struct stat tmpstatbuf;
3720 #ifdef VMS
3721             char *unix;
3722             STRLEN len;
3723
3724             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3725                 len = strlen(unix);
3726                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3727                 sv_usepvn(libdir,unix,len);
3728             }
3729             else
3730                 PerlIO_printf(Perl_error_log,
3731                               "Failed to unixify @INC element \"%s\"\n",
3732                               SvPV(libdir,len));
3733 #endif
3734             if (addsubdirs) {
3735 #ifdef MACOS_TRADITIONAL
3736 #define PERL_AV_SUFFIX_FMT      ""
3737 #define PERL_ARCH_FMT           "%s:"
3738 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3739 #else
3740 #define PERL_AV_SUFFIX_FMT      "/"
3741 #define PERL_ARCH_FMT           "/%s"
3742 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3743 #endif
3744                 /* .../version/archname if -d .../version/archname */
3745                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3746                                 libdir,
3747                                (int)PERL_REVISION, (int)PERL_VERSION,
3748                                (int)PERL_SUBVERSION, ARCHNAME);
3749                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3750                       S_ISDIR(tmpstatbuf.st_mode))
3751                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3752
3753                 /* .../version if -d .../version */
3754                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3755                                (int)PERL_REVISION, (int)PERL_VERSION,
3756                                (int)PERL_SUBVERSION);
3757                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3758                       S_ISDIR(tmpstatbuf.st_mode))
3759                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3760
3761                 /* .../archname if -d .../archname */
3762                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3763                 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3764                       S_ISDIR(tmpstatbuf.st_mode))
3765                     av_push(GvAVn(PL_incgv), newSVsv(subdir));
3766             }
3767
3768 #ifdef PERL_INC_VERSION_LIST
3769             if (addoldvers) {
3770                 for (incver = incverlist; *incver; incver++) {
3771                     /* .../xxx if -d .../xxx */
3772                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3773                     if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3774                           S_ISDIR(tmpstatbuf.st_mode))
3775                         av_push(GvAVn(PL_incgv), newSVsv(subdir));
3776                 }
3777             }
3778 #endif
3779         }
3780
3781         /* finally push this lib directory on the end of @INC */
3782         av_push(GvAVn(PL_incgv), libdir);
3783     }
3784 }
3785
3786 #ifdef USE_5005THREADS
3787 STATIC struct perl_thread *
3788 S_init_main_thread(pTHX)
3789 {
3790 #if !defined(PERL_IMPLICIT_CONTEXT)
3791     struct perl_thread *thr;
3792 #endif
3793     XPV *xpv;
3794
3795     Newz(53, thr, 1, struct perl_thread);
3796     PL_curcop = &PL_compiling;
3797     thr->interp = PERL_GET_INTERP;
3798     thr->cvcache = newHV();
3799     thr->threadsv = newAV();
3800     /* thr->threadsvp is set when find_threadsv is called */
3801     thr->specific = newAV();
3802     thr->flags = THRf_R_JOINABLE;
3803     MUTEX_INIT(&thr->mutex);
3804     /* Handcraft thrsv similarly to mess_sv */
3805     New(53, PL_thrsv, 1, SV);
3806     Newz(53, xpv, 1, XPV);
3807     SvFLAGS(PL_thrsv) = SVt_PV;
3808     SvANY(PL_thrsv) = (void*)xpv;
3809     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3810     SvPVX(PL_thrsv) = (char*)thr;
3811     SvCUR_set(PL_thrsv, sizeof(thr));
3812     SvLEN_set(PL_thrsv, sizeof(thr));
3813     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3814     thr->oursv = PL_thrsv;
3815     PL_chopset = " \n-";
3816     PL_dumpindent = 4;
3817
3818     MUTEX_LOCK(&PL_threads_mutex);
3819     PL_nthreads++;
3820     thr->tid = 0;
3821     thr->next = thr;
3822     thr->prev = thr;
3823     thr->thr_done = 0;
3824     MUTEX_UNLOCK(&PL_threads_mutex);
3825
3826 #ifdef HAVE_THREAD_INTERN
3827     Perl_init_thread_intern(thr);
3828 #endif
3829
3830 #ifdef SET_THREAD_SELF
3831     SET_THREAD_SELF(thr);
3832 #else
3833     thr->self = pthread_self();
3834 #endif /* SET_THREAD_SELF */
3835     PERL_SET_THX(thr);
3836
3837     /*
3838      * These must come after the thread self setting
3839      * because sv_setpvn does SvTAINT and the taint
3840      * fields thread selfness being set.
3841      */
3842     PL_toptarget = NEWSV(0,0);
3843     sv_upgrade(PL_toptarget, SVt_PVFM);
3844     sv_setpvn(PL_toptarget, "", 0);
3845     PL_bodytarget = NEWSV(0,0);
3846     sv_upgrade(PL_bodytarget, SVt_PVFM);
3847     sv_setpvn(PL_bodytarget, "", 0);
3848     PL_formtarget = PL_bodytarget;
3849     thr->errsv = newSVpvn("", 0);
3850     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3851
3852     PL_maxscream = -1;
3853     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3854     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3855     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3856     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3857     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3858     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3859     PL_regindent = 0;
3860     PL_reginterp_cnt = 0;
3861
3862     return thr;
3863 }
3864 #endif /* USE_5005THREADS */
3865
3866 void
3867 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3868 {
3869     SV *atsv;
3870     line_t oldline = CopLINE(PL_curcop);
3871     CV *cv;
3872     STRLEN len;
3873     int ret;
3874     dJMPENV;
3875
3876     while (AvFILL(paramList) >= 0) {
3877         cv = (CV*)av_shift(paramList);
3878         if (PL_savebegin && (paramList == PL_beginav)) {
3879                 /* save PL_beginav for compiler */
3880             if (! PL_beginav_save)
3881                 PL_beginav_save = newAV();
3882             av_push(PL_beginav_save, (SV*)cv);
3883         } else {
3884             SAVEFREESV(cv);
3885         }
3886 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3887         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3888 #else
3889         JMPENV_PUSH(ret);
3890 #endif
3891         switch (ret) {
3892         case 0:
3893 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3894             call_list_body(cv);
3895 #endif
3896             atsv = ERRSV;
3897             (void)SvPV(atsv, len);
3898             if (len) {
3899                 STRLEN n_a;
3900                 PL_curcop = &PL_compiling;
3901                 CopLINE_set(PL_curcop, oldline);
3902                 if (paramList == PL_beginav)
3903                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3904                 else
3905                     Perl_sv_catpvf(aTHX_ atsv,
3906                                    "%s failed--call queue aborted",
3907                                    paramList == PL_checkav ? "CHECK"
3908                                    : paramList == PL_initav ? "INIT"
3909                                    : "END");
3910                 while (PL_scopestack_ix > oldscope)
3911                     LEAVE;
3912                 JMPENV_POP;
3913                 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3914             }
3915             break;
3916         case 1:
3917             STATUS_ALL_FAILURE;
3918             /* FALL THROUGH */
3919         case 2:
3920             /* my_exit() was called */
3921             while (PL_scopestack_ix > oldscope)
3922                 LEAVE;
3923             FREETMPS;
3924             PL_curstash = PL_defstash;
3925             PL_curcop = &PL_compiling;
3926             CopLINE_set(PL_curcop, oldline);
3927             JMPENV_POP;
3928             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3929                 if (paramList == PL_beginav)
3930                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3931                 else
3932                     Perl_croak(aTHX_ "%s failed--call queue aborted",
3933                                paramList == PL_checkav ? "CHECK"
3934                                : paramList == PL_initav ? "INIT"
3935                                : "END");
3936             }
3937             my_exit_jump();
3938             /* NOTREACHED */
3939         case 3:
3940             if (PL_restartop) {
3941                 PL_curcop = &PL_compiling;
3942                 CopLINE_set(PL_curcop, oldline);
3943                 JMPENV_JUMP(3);
3944             }
3945             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3946             FREETMPS;
3947             break;
3948         }
3949         JMPENV_POP;
3950     }
3951 }
3952
3953 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3954 STATIC void *
3955 S_vcall_list_body(pTHX_ va_list args)
3956 {
3957     CV *cv = va_arg(args, CV*);
3958     return call_list_body(cv);
3959 }
3960 #endif
3961
3962 STATIC void *
3963 S_call_list_body(pTHX_ CV *cv)
3964 {
3965     PUSHMARK(PL_stack_sp);
3966     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3967     return NULL;
3968 }
3969
3970 void
3971 Perl_my_exit(pTHX_ U32 status)
3972 {
3973     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3974                           thr, (unsigned long) status));
3975     switch (status) {
3976     case 0:
3977         STATUS_ALL_SUCCESS;
3978         break;
3979     case 1:
3980         STATUS_ALL_FAILURE;
3981         break;
3982     default:
3983         STATUS_NATIVE_SET(status);
3984         break;
3985     }
3986     my_exit_jump();
3987 }
3988
3989 void
3990 Perl_my_failure_exit(pTHX)
3991 {
3992 #ifdef VMS
3993     if (vaxc$errno & 1) {
3994         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3995             STATUS_NATIVE_SET(44);
3996     }
3997     else {
3998         if (!vaxc$errno && errno)       /* unlikely */
3999             STATUS_NATIVE_SET(44);
4000         else
4001             STATUS_NATIVE_SET(vaxc$errno);
4002     }
4003 #else
4004     int exitstatus;
4005     if (errno & 255)
4006         STATUS_POSIX_SET(errno);
4007     else {
4008         exitstatus = STATUS_POSIX >> 8;
4009         if (exitstatus & 255)
4010             STATUS_POSIX_SET(exitstatus);
4011         else
4012             STATUS_POSIX_SET(255);
4013     }
4014 #endif
4015     my_exit_jump();
4016 }
4017
4018 STATIC void
4019 S_my_exit_jump(pTHX)
4020 {
4021     register PERL_CONTEXT *cx;
4022     I32 gimme;
4023     SV **newsp;
4024
4025     if (PL_e_script) {
4026         SvREFCNT_dec(PL_e_script);
4027         PL_e_script = Nullsv;
4028     }
4029
4030     POPSTACK_TO(PL_mainstack);
4031     if (cxstack_ix >= 0) {
4032         if (cxstack_ix > 0)
4033             dounwind(0);
4034         POPBLOCK(cx,PL_curpm);
4035         LEAVE;
4036     }
4037
4038     JMPENV_JUMP(2);
4039 }
4040
4041 static I32
4042 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4043 {
4044     char *p, *nl;
4045     p  = SvPVX(PL_e_script);
4046     nl = strchr(p, '\n');
4047     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4048     if (nl-p == 0) {
4049         filter_del(read_e_script);
4050         return 0;
4051     }
4052     sv_catpvn(buf_sv, p, nl-p);
4053     sv_chop(PL_e_script, nl);
4054     return 1;
4055 }