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