perl.c

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