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