perl.c

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