perl.c

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