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