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