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     PL_curcop->cop_line = 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         gv_check(PL_defstash);
1102
1103     LEAVE;
1104     FREETMPS;
1105
1106 #ifdef MYMALLOC
1107     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1108         dump_mstats("after compilation:");
1109 #endif
1110
1111     ENTER;
1112     PL_restartop = 0;
1113     return NULL;
1114 }
1115
1116 int
1117 perl_run(pTHXx)
1118 {
1119     dTHR;
1120     I32 oldscope;
1121     int ret;
1122     dJMPENV;
1123 #ifdef USE_THREADS
1124     dTHX;
1125 #endif
1126
1127     oldscope = PL_scopestack_ix;
1128
1129  redo_body:
1130     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1131     switch (ret) {
1132     case 1:
1133         cxstack_ix = -1;                /* start context stack again */
1134         goto redo_body;
1135     case 0:  /* normal completion */
1136     case 2:  /* my_exit() */
1137         while (PL_scopestack_ix > oldscope)
1138             LEAVE;
1139         FREETMPS;
1140         PL_curstash = PL_defstash;
1141         if (PL_endav && !PL_minus_c)
1142             call_list(oldscope, PL_endav);
1143 #ifdef MYMALLOC
1144         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1145             dump_mstats("after execution:  ");
1146 #endif
1147         return STATUS_NATIVE_EXPORT;
1148     case 3:
1149         if (PL_restartop) {
1150             POPSTACK_TO(PL_mainstack);
1151             goto redo_body;
1152         }
1153         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1154         FREETMPS;
1155         return 1;
1156     }
1157
1158     /* NOTREACHED */
1159     return 0;
1160 }
1161
1162 STATIC void *
1163 S_run_body(pTHX_ va_list args)
1164 {
1165     dTHR;
1166     I32 oldscope = va_arg(args, I32);
1167
1168     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1169                     PL_sawampersand ? "Enabling" : "Omitting"));
1170
1171     if (!PL_restartop) {
1172         DEBUG_x(dump_all());
1173         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1174         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1175                               PTR2UV(thr)));
1176
1177         if (PL_minus_c) {
1178             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1179             my_exit(0);
1180         }
1181         if (PERLDB_SINGLE && PL_DBsingle)
1182             sv_setiv(PL_DBsingle, 1);
1183         if (PL_initav)
1184             call_list(oldscope, PL_initav);
1185     }
1186
1187     /* do it */
1188
1189     if (PL_restartop) {
1190         PL_op = PL_restartop;
1191         PL_restartop = 0;
1192         CALLRUNOPS(aTHX);
1193     }
1194     else if (PL_main_start) {
1195         CvDEPTH(PL_main_cv) = 1;
1196         PL_op = PL_main_start;
1197         CALLRUNOPS(aTHX);
1198     }
1199
1200     my_exit(0);
1201     /* NOTREACHED */
1202     return NULL;
1203 }
1204
1205 SV*
1206 Perl_get_sv(pTHX_ const char *name, I32 create)
1207 {
1208     GV *gv;
1209 #ifdef USE_THREADS
1210     if (name[1] == '\0' && !isALPHA(name[0])) {
1211         PADOFFSET tmp = find_threadsv(name);
1212         if (tmp != NOT_IN_PAD) {
1213             dTHR;
1214             return THREADSV(tmp);
1215         }
1216     }
1217 #endif /* USE_THREADS */
1218     gv = gv_fetchpv(name, create, SVt_PV);
1219     if (gv)
1220         return GvSV(gv);
1221     return Nullsv;
1222 }
1223
1224 AV*
1225 Perl_get_av(pTHX_ const char *name, I32 create)
1226 {
1227     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1228     if (create)
1229         return GvAVn(gv);
1230     if (gv)
1231         return GvAV(gv);
1232     return Nullav;
1233 }
1234
1235 HV*
1236 Perl_get_hv(pTHX_ const char *name, I32 create)
1237 {
1238     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1239     if (create)
1240         return GvHVn(gv);
1241     if (gv)
1242         return GvHV(gv);
1243     return Nullhv;
1244 }
1245
1246 CV*
1247 Perl_get_cv(pTHX_ const char *name, I32 create)
1248 {
1249     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1250     /* XXX unsafe for threads if eval_owner isn't held */
1251     /* XXX this is probably not what they think they're getting.
1252      * It has the same effect as "sub name;", i.e. just a forward
1253      * declaration! */
1254     if (create && !GvCVu(gv))
1255         return newSUB(start_subparse(FALSE, 0),
1256                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1257                       Nullop,
1258                       Nullop);
1259     if (gv)
1260         return GvCVu(gv);
1261     return Nullcv;
1262 }
1263
1264 /* Be sure to refetch the stack pointer after calling these routines. */
1265
1266 I32
1267 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1268
1269                         /* See G_* flags in cop.h */
1270                         /* null terminated arg list */
1271 {
1272     dSP;
1273
1274     PUSHMARK(SP);
1275     if (argv) {
1276         while (*argv) {
1277             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1278             argv++;
1279         }
1280         PUTBACK;
1281     }
1282     return call_pv(sub_name, flags);
1283 }
1284
1285 I32
1286 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1287                         /* name of the subroutine */
1288                         /* See G_* flags in cop.h */
1289 {
1290     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1291 }
1292
1293 I32
1294 Perl_call_method(pTHX_ const char *methname, I32 flags)
1295                         /* name of the subroutine */
1296                         /* See G_* flags in cop.h */
1297 {
1298     dSP;
1299     OP myop;
1300     if (!PL_op)
1301         PL_op = &myop;
1302     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1303     PUTBACK;
1304     pp_method();
1305         if(PL_op == &myop)
1306                 PL_op = Nullop;
1307     return call_sv(*PL_stack_sp--, flags);
1308 }
1309
1310 /* May be called with any of a CV, a GV, or an SV containing the name. */
1311 I32
1312 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1313
1314                         /* See G_* flags in cop.h */
1315 {
1316     dSP;
1317     LOGOP myop;         /* fake syntax tree node */
1318     I32 oldmark;
1319     I32 retval;
1320     I32 oldscope;
1321     bool oldcatch = CATCH_GET;
1322     int ret;
1323     OP* oldop = PL_op;
1324     dJMPENV;
1325
1326     if (flags & G_DISCARD) {
1327         ENTER;
1328         SAVETMPS;
1329     }
1330
1331     Zero(&myop, 1, LOGOP);
1332     myop.op_next = Nullop;
1333     if (!(flags & G_NOARGS))
1334         myop.op_flags |= OPf_STACKED;
1335     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1336                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1337                       OPf_WANT_SCALAR);
1338     SAVEOP();
1339     PL_op = (OP*)&myop;
1340
1341     EXTEND(PL_stack_sp, 1);
1342     *++PL_stack_sp = sv;
1343     oldmark = TOPMARK;
1344     oldscope = PL_scopestack_ix;
1345
1346     if (PERLDB_SUB && PL_curstash != PL_debstash
1347            /* Handle first BEGIN of -d. */
1348           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1349            /* Try harder, since this may have been a sighandler, thus
1350             * curstash may be meaningless. */
1351           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1352           && !(flags & G_NODEBUG))
1353         PL_op->op_private |= OPpENTERSUB_DB;
1354
1355     if (!(flags & G_EVAL)) {
1356         CATCH_SET(TRUE);
1357         call_xbody((OP*)&myop, FALSE);
1358         retval = PL_stack_sp - (PL_stack_base + oldmark);
1359         CATCH_SET(oldcatch);
1360     }
1361     else {
1362         cLOGOP->op_other = PL_op;
1363         PL_markstack_ptr--;
1364         /* we're trying to emulate pp_entertry() here */
1365         {
1366             register PERL_CONTEXT *cx;
1367             I32 gimme = GIMME_V;
1368
1369             ENTER;
1370             SAVETMPS;
1371
1372             push_return(PL_op->op_next);
1373             PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1374             PUSHEVAL(cx, 0, 0);
1375             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
1376
1377             PL_in_eval = EVAL_INEVAL;
1378             if (flags & G_KEEPERR)
1379                 PL_in_eval |= EVAL_KEEPERR;
1380             else
1381                 sv_setpv(ERRSV,"");
1382         }
1383         PL_markstack_ptr++;
1384
1385   redo_body:
1386         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1387                     (OP*)&myop, FALSE);
1388         switch (ret) {
1389         case 0:
1390             retval = PL_stack_sp - (PL_stack_base + oldmark);
1391             if (!(flags & G_KEEPERR))
1392                 sv_setpv(ERRSV,"");
1393             break;
1394         case 1:
1395             STATUS_ALL_FAILURE;
1396             /* FALL THROUGH */
1397         case 2:
1398             /* my_exit() was called */
1399             PL_curstash = PL_defstash;
1400             FREETMPS;
1401             if (PL_statusvalue)
1402                 Perl_croak(aTHX_ "Callback called exit");
1403             my_exit_jump();
1404             /* NOTREACHED */
1405         case 3:
1406             if (PL_restartop) {
1407                 PL_op = PL_restartop;
1408                 PL_restartop = 0;
1409                 goto redo_body;
1410             }
1411             PL_stack_sp = PL_stack_base + oldmark;
1412             if (flags & G_ARRAY)
1413                 retval = 0;
1414             else {
1415                 retval = 1;
1416                 *++PL_stack_sp = &PL_sv_undef;
1417             }
1418             break;
1419         }
1420
1421         if (PL_scopestack_ix > oldscope) {
1422             SV **newsp;
1423             PMOP *newpm;
1424             I32 gimme;
1425             register PERL_CONTEXT *cx;
1426             I32 optype;
1427
1428             POPBLOCK(cx,newpm);
1429             POPEVAL(cx);
1430             pop_return();
1431             PL_curpm = newpm;
1432             LEAVE;
1433         }
1434     }
1435
1436     if (flags & G_DISCARD) {
1437         PL_stack_sp = PL_stack_base + oldmark;
1438         retval = 0;
1439         FREETMPS;
1440         LEAVE;
1441     }
1442     PL_op = oldop;
1443     return retval;
1444 }
1445
1446 STATIC void *
1447 S_call_body(pTHX_ va_list args)
1448 {
1449     OP *myop = va_arg(args, OP*);
1450     int is_eval = va_arg(args, int);
1451
1452     call_xbody(myop, is_eval);
1453     return NULL;
1454 }
1455
1456 STATIC void
1457 S_call_xbody(pTHX_ OP *myop, int is_eval)
1458 {
1459     dTHR;
1460
1461     if (PL_op == myop) {
1462         if (is_eval)
1463             PL_op = Perl_pp_entereval(aTHX);
1464         else
1465             PL_op = Perl_pp_entersub(aTHX);
1466     }
1467     if (PL_op)
1468         CALLRUNOPS(aTHX);
1469 }
1470
1471 /* Eval a string. The G_EVAL flag is always assumed. */
1472
1473 I32
1474 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1475
1476                         /* See G_* flags in cop.h */
1477 {
1478     dSP;
1479     UNOP myop;          /* fake syntax tree node */
1480     I32 oldmark = SP - PL_stack_base;
1481     I32 retval;
1482     I32 oldscope;
1483     int ret;
1484     OP* oldop = PL_op;
1485     dJMPENV;
1486
1487     if (flags & G_DISCARD) {
1488         ENTER;
1489         SAVETMPS;
1490     }
1491
1492     SAVEOP();
1493     PL_op = (OP*)&myop;
1494     Zero(PL_op, 1, UNOP);
1495     EXTEND(PL_stack_sp, 1);
1496     *++PL_stack_sp = sv;
1497     oldscope = PL_scopestack_ix;
1498
1499     if (!(flags & G_NOARGS))
1500         myop.op_flags = OPf_STACKED;
1501     myop.op_next = Nullop;
1502     myop.op_type = OP_ENTEREVAL;
1503     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1504                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1505                       OPf_WANT_SCALAR);
1506     if (flags & G_KEEPERR)
1507         myop.op_flags |= OPf_SPECIAL;
1508
1509  redo_body:
1510     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1511                 (OP*)&myop, TRUE);
1512     switch (ret) {
1513     case 0:
1514         retval = PL_stack_sp - (PL_stack_base + oldmark);
1515         if (!(flags & G_KEEPERR))
1516             sv_setpv(ERRSV,"");
1517         break;
1518     case 1:
1519         STATUS_ALL_FAILURE;
1520         /* FALL THROUGH */
1521     case 2:
1522         /* my_exit() was called */
1523         PL_curstash = PL_defstash;
1524         FREETMPS;
1525         if (PL_statusvalue)
1526             Perl_croak(aTHX_ "Callback called exit");
1527         my_exit_jump();
1528         /* NOTREACHED */
1529     case 3:
1530         if (PL_restartop) {
1531             PL_op = PL_restartop;
1532             PL_restartop = 0;
1533             goto redo_body;
1534         }
1535         PL_stack_sp = PL_stack_base + oldmark;
1536         if (flags & G_ARRAY)
1537             retval = 0;
1538         else {
1539             retval = 1;
1540             *++PL_stack_sp = &PL_sv_undef;
1541         }
1542         break;
1543     }
1544
1545     if (flags & G_DISCARD) {
1546         PL_stack_sp = PL_stack_base + oldmark;
1547         retval = 0;
1548         FREETMPS;
1549         LEAVE;
1550     }
1551     PL_op = oldop;
1552     return retval;
1553 }
1554
1555 SV*
1556 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1557 {
1558     dSP;
1559     SV* sv = newSVpv(p, 0);
1560
1561     PUSHMARK(SP);
1562     eval_sv(sv, G_SCALAR);
1563     SvREFCNT_dec(sv);
1564
1565     SPAGAIN;
1566     sv = POPs;
1567     PUTBACK;
1568
1569     if (croak_on_error && SvTRUE(ERRSV)) {
1570         STRLEN n_a;
1571         Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1572     }
1573
1574     return sv;
1575 }
1576
1577 /* Require a module. */
1578
1579 void
1580 Perl_require_pv(pTHX_ const char *pv)
1581 {
1582     SV* sv;
1583     dSP;
1584     PUSHSTACKi(PERLSI_REQUIRE);
1585     PUTBACK;
1586     sv = sv_newmortal();
1587     sv_setpv(sv, "require '");
1588     sv_catpv(sv, pv);
1589     sv_catpv(sv, "'");
1590     eval_sv(sv, G_DISCARD);
1591     SPAGAIN;
1592     POPSTACK;
1593 }
1594
1595 void
1596 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1597 {
1598     register GV *gv;
1599
1600     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1601         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1602 }
1603
1604 STATIC void
1605 S_usage(pTHX_ char *name)               /* XXX move this out into a module ? */
1606 {
1607     /* This message really ought to be max 23 lines.
1608      * Removed -h because the user already knows that opton. Others? */
1609
1610     static char *usage_msg[] = {
1611 "-0[octal]       specify record separator (\\0, if no argument)",
1612 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1613 "-c              check syntax only (runs BEGIN and END blocks)",
1614 "-d[:debugger]   run program under debugger",
1615 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1616 "-e 'command'    one line of program (several -e's allowed, omit programfile)",
1617 "-F/pattern/     split() pattern for -a switch (//'s are optional)",
1618 "-i[extension]   edit <> files in place (makes backup if extension supplied)",
1619 "-Idirectory     specify @INC/#include directory (several -I's allowed)",
1620 "-l[octal]       enable line ending processing, specifies line terminator",
1621 "-[mM][-]module  execute `use/no module...' before executing program",
1622 "-n              assume 'while (<>) { ... }' loop around program",
1623 "-p              assume loop like -n but print line also, like sed",
1624 "-P              run program through C preprocessor before compilation",
1625 "-s              enable rudimentary parsing for switches after programfile",
1626 "-S              look for programfile using PATH environment variable",
1627 "-T              enable tainting checks",
1628 "-u              dump core after parsing program",
1629 "-U              allow unsafe operations",
1630 "-v              print version, subversion (includes VERY IMPORTANT perl info)",
1631 "-V[:variable]   print configuration summary (or a single Config.pm variable)",
1632 "-w              enable many useful warnings (RECOMMENDED)",
1633 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1634 "\n",
1635 NULL
1636 };
1637     char **p = usage_msg;
1638
1639     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1640     while (*p)
1641         printf("\n  %s", *p++);
1642 }
1643
1644 /* This routine handles any switches that can be given during run */
1645
1646 char *
1647 Perl_moreswitches(pTHX_ char *s)
1648 {
1649     I32 numlen;
1650     U32 rschar;
1651
1652     switch (*s) {
1653     case '0':
1654     {
1655         dTHR;
1656         rschar = (U32)scan_oct(s, 4, &numlen);
1657         SvREFCNT_dec(PL_nrs);
1658         if (rschar & ~((U8)~0))
1659             PL_nrs = &PL_sv_undef;
1660         else if (!rschar && numlen >= 2)
1661             PL_nrs = newSVpvn("", 0);
1662         else {
1663             char ch = rschar;
1664             PL_nrs = newSVpvn(&ch, 1);
1665         }
1666         return s + numlen;
1667     }
1668     case 'F':
1669         PL_minus_F = TRUE;
1670         PL_splitstr = savepv(s + 1);
1671         s += strlen(s);
1672         return s;
1673     case 'a':
1674         PL_minus_a = TRUE;
1675         s++;
1676         return s;
1677     case 'c':
1678         PL_minus_c = TRUE;
1679         s++;
1680         return s;
1681     case 'd':
1682         forbid_setid("-d");
1683         s++;
1684         if (*s == ':' || *s == '=')  {
1685             my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1686             s += strlen(s);
1687         }
1688         if (!PL_perldb)
1689             PL_perldb = PERLDB_ALL;
1690         if (!PL_debstash)
1691             init_debugger();
1692         return s;
1693     case 'D':
1694     {
1695 #ifdef DEBUGGING
1696         forbid_setid("-D");
1697         if (isALPHA(s[1])) {
1698             static char debopts[] = "psltocPmfrxuLHXDS";
1699             char *d;
1700
1701             for (s++; *s && (d = strchr(debopts,*s)); s++)
1702                 PL_debug |= 1 << (d - debopts);
1703         }
1704         else {
1705             PL_debug = atoi(s+1);
1706             for (s++; isDIGIT(*s); s++) ;
1707         }
1708         PL_debug |= 0x80000000;
1709 #else
1710         dTHR;
1711         if (ckWARN_d(WARN_DEBUGGING))
1712             Perl_warner(aTHX_ WARN_DEBUGGING,
1713                    "Recompile perl with -DDEBUGGING to use -D switch\n");
1714         for (s++; isALNUM(*s); s++) ;
1715 #endif
1716         /*SUPPRESS 530*/
1717         return s;
1718     }
1719     case 'h':
1720         usage(PL_origargv[0]);
1721         PerlProc_exit(0);
1722     case 'i':
1723         if (PL_inplace)
1724             Safefree(PL_inplace);
1725         PL_inplace = savepv(s+1);
1726         /*SUPPRESS 530*/
1727         for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1728         if (*s) {
1729             *s++ = '\0';
1730             if (*s == '-')      /* Additional switches on #! line. */
1731                 s++;
1732         }
1733         return s;
1734     case 'I':   /* -I handled both here and in parse_perl() */
1735         forbid_setid("-I");
1736         ++s;
1737         while (*s && isSPACE(*s))
1738             ++s;
1739         if (*s) {
1740             char *e, *p;
1741             for (e = s; *e && !isSPACE(*e); e++) ;
1742             p = savepvn(s, e-s);
1743             incpush(p, TRUE);
1744             Safefree(p);
1745             s = e;
1746         }
1747         else
1748             Perl_croak(aTHX_ "No space allowed after -I");
1749         return s;
1750     case 'l':
1751         PL_minus_l = TRUE;
1752         s++;
1753         if (PL_ors)
1754             Safefree(PL_ors);
1755         if (isDIGIT(*s)) {
1756             PL_ors = savepv("\n");
1757             PL_orslen = 1;
1758             *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1759             s += numlen;
1760         }
1761         else {
1762             dTHR;
1763             if (RsPARA(PL_nrs)) {
1764                 PL_ors = "\n\n";
1765                 PL_orslen = 2;
1766             }
1767             else
1768                 PL_ors = SvPV(PL_nrs, PL_orslen);
1769             PL_ors = savepvn(PL_ors, PL_orslen);
1770         }
1771         return s;
1772     case 'M':
1773         forbid_setid("-M");     /* XXX ? */
1774         /* FALL THROUGH */
1775     case 'm':
1776         forbid_setid("-m");     /* XXX ? */
1777         if (*++s) {
1778             char *start;
1779             SV *sv;
1780             char *use = "use ";
1781             /* -M-foo == 'no foo'       */
1782             if (*s == '-') { use = "no "; ++s; }
1783             sv = newSVpv(use,0);
1784             start = s;
1785             /* We allow -M'Module qw(Foo Bar)'  */
1786             while(isALNUM(*s) || *s==':') ++s;
1787             if (*s != '=') {
1788                 sv_catpv(sv, start);
1789                 if (*(start-1) == 'm') {
1790                     if (*s != '\0')
1791                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1792                     sv_catpv( sv, " ()");
1793                 }
1794             } else {
1795                 sv_catpvn(sv, start, s-start);
1796                 sv_catpv(sv, " split(/,/,q{");
1797                 sv_catpv(sv, ++s);
1798                 sv_catpv(sv,    "})");
1799             }
1800             s += strlen(s);
1801             if (!PL_preambleav)
1802                 PL_preambleav = newAV();
1803             av_push(PL_preambleav, sv);
1804         }
1805         else
1806             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1807         return s;
1808     case 'n':
1809         PL_minus_n = TRUE;
1810         s++;
1811         return s;
1812     case 'p':
1813         PL_minus_p = TRUE;
1814         s++;
1815         return s;
1816     case 's':
1817         forbid_setid("-s");
1818         PL_doswitches = TRUE;
1819         s++;
1820         return s;
1821     case 'T':
1822         if (!PL_tainting)
1823             Perl_croak(aTHX_ "Too late for \"-T\" option");
1824         s++;
1825         return s;
1826     case 'u':
1827         PL_do_undump = TRUE;
1828         s++;
1829         return s;
1830     case 'U':
1831         PL_unsafe = TRUE;
1832         s++;
1833         return s;
1834     case 'v':
1835 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1836         printf("\nThis is perl, version %d.%03d_%02d built for %s",
1837             PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1838 #else
1839         printf("\nThis is perl, version %s built for %s",
1840                 PL_patchlevel, ARCHNAME);
1841 #endif
1842 #if defined(LOCAL_PATCH_COUNT)
1843         if (LOCAL_PATCH_COUNT > 0)
1844             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1845                 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1846 #endif
1847
1848         printf("\n\nCopyright 1987-1999, Larry Wall\n");
1849 #ifdef MSDOS
1850         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1851 #endif
1852 #ifdef DJGPP
1853         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1854         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1855 #endif
1856 #ifdef OS2
1857         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1858             "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1859 #endif
1860 #ifdef atarist
1861         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1862 #endif
1863 #ifdef __BEOS__
1864         printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1865 #endif
1866 #ifdef MPE
1867         printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1868 #endif
1869 #ifdef OEMVS
1870         printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1871 #endif
1872 #ifdef __VOS__
1873         printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1874 #endif
1875 #ifdef __OPEN_VM
1876         printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1877 #endif
1878 #ifdef POSIX_BC
1879         printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1880 #endif
1881 #ifdef __MINT__
1882         printf("MiNT port by Guido Flohr, 1997-1999\n");
1883 #endif
1884 #ifdef BINARY_BUILD_NOTICE
1885         BINARY_BUILD_NOTICE;
1886 #endif
1887         printf("\n\
1888 Perl may be copied only under the terms of either the Artistic License or the\n\
1889 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1890 Complete documentation for Perl, including FAQ lists, should be found on\n\
1891 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
1892 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1893         PerlProc_exit(0);
1894     case 'w':
1895         if (! (PL_dowarn & G_WARN_ALL_MASK))
1896             PL_dowarn |= G_WARN_ON;
1897         s++;
1898         return s;
1899     case 'W':
1900         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1901         PL_compiling.cop_warnings = WARN_ALL ;
1902         s++;
1903         return s;
1904     case 'X':
1905         PL_dowarn = G_WARN_ALL_OFF;
1906         PL_compiling.cop_warnings = WARN_NONE ;
1907         s++;
1908         return s;
1909     case '*':
1910     case ' ':
1911         if (s[1] == '-')        /* Additional switches on #! line. */
1912             return s+2;
1913         break;
1914     case '-':
1915     case 0:
1916 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1917     case '\r':
1918 #endif
1919     case '\n':
1920     case '\t':
1921         break;
1922 #ifdef ALTERNATE_SHEBANG
1923     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1924         break;
1925 #endif
1926     case 'P':
1927         if (PL_preprocess)
1928             return s+1;
1929         /* FALL THROUGH */
1930     default:
1931         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1932     }
1933     return Nullch;
1934 }
1935
1936 /* compliments of Tom Christiansen */
1937
1938 /* unexec() can be found in the Gnu emacs distribution */
1939 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1940
1941 void
1942 Perl_my_unexec(pTHX)
1943 {
1944 #ifdef UNEXEC
1945     SV*    prog;
1946     SV*    file;
1947     int    status = 1;
1948     extern int etext;
1949
1950     prog = newSVpv(BIN_EXP, 0);
1951     sv_catpv(prog, "/perl");
1952     file = newSVpv(PL_origfilename, 0);
1953     sv_catpv(file, ".perldump");
1954
1955     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1956     /* unexec prints msg to stderr in case of failure */
1957     PerlProc_exit(status);
1958 #else
1959 #  ifdef VMS
1960 #    include <lib$routines.h>
1961      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1962 #  else
1963     ABORT();            /* for use with undump */
1964 #  endif
1965 #endif
1966 }
1967
1968 /* initialize curinterp */
1969 STATIC void
1970 S_init_interp(pTHX)
1971 {
1972
1973 #ifdef PERL_OBJECT              /* XXX kludge */
1974 #define I_REINIT \
1975   STMT_START {                          \
1976     PL_chopset          = " \n-";       \
1977     PL_copline          = NOLINE;       \
1978     PL_curcop           = &PL_compiling;\
1979     PL_curcopdb         = NULL;         \
1980     PL_dbargs           = 0;            \
1981     PL_dumpindent       = 4;            \
1982     PL_laststatval      = -1;           \
1983     PL_laststype        = OP_STAT;      \
1984     PL_maxscream        = -1;           \
1985     PL_maxsysfd         = MAXSYSFD;     \
1986     PL_statname         = Nullsv;       \
1987     PL_tmps_floor       = -1;           \
1988     PL_tmps_ix          = -1;           \
1989     PL_op_mask          = NULL;         \
1990     PL_laststatval      = -1;           \
1991     PL_laststype        = OP_STAT;      \
1992     PL_mess_sv          = Nullsv;       \
1993     PL_splitstr         = " ";          \
1994     PL_generation       = 100;          \
1995     PL_exitlist         = NULL;         \
1996     PL_exitlistlen      = 0;            \
1997     PL_regindent        = 0;            \
1998     PL_in_clean_objs    = FALSE;        \
1999     PL_in_clean_all     = FALSE;        \
2000     PL_profiledata      = NULL;         \
2001     PL_rsfp             = Nullfp;       \
2002     PL_rsfp_filters     = Nullav;       \
2003     PL_dirty            = FALSE;        \
2004   } STMT_END
2005     I_REINIT;
2006 #else
2007 #  ifdef MULTIPLICITY
2008 #    define PERLVAR(var,type)
2009 #    define PERLVARA(var,n,type)
2010 #    if defined(PERL_IMPLICIT_CONTEXT)
2011 #      if defined(USE_THREADS)
2012 #        define PERLVARI(var,type,init)         PERL_GET_INTERP->var = init;
2013 #        define PERLVARIC(var,type,init)        PERL_GET_INTERP->var = init;
2014 #      else /* !USE_THREADS */
2015 #        define PERLVARI(var,type,init)         aTHX->var = init;
2016 #        define PERLVARIC(var,type,init)        aTHX->var = init;
2017 #      endif /* USE_THREADS */
2018 #    else
2019 #      define PERLVARI(var,type,init)   PERL_GET_INTERP->var = init;
2020 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2021 #    endif
2022 #    include "intrpvar.h"
2023 #    ifndef USE_THREADS
2024 #      include "thrdvar.h"
2025 #    endif
2026 #    undef PERLVAR
2027 #    undef PERLVARA
2028 #    undef PERLVARI
2029 #    undef PERLVARIC
2030 #  else
2031 #    define PERLVAR(var,type)
2032 #    define PERLVARA(var,n,type)
2033 #    define PERLVARI(var,type,init)     PL_##var = init;
2034 #    define PERLVARIC(var,type,init)    PL_##var = init;
2035 #    include "intrpvar.h"
2036 #    ifndef USE_THREADS
2037 #      include "thrdvar.h"
2038 #    endif
2039 #    undef PERLVAR
2040 #    undef PERLVARA
2041 #    undef PERLVARI
2042 #    undef PERLVARIC
2043 #  endif
2044 #endif
2045
2046 }
2047
2048 STATIC void
2049 S_init_main_stash(pTHX)
2050 {
2051     dTHR;
2052     GV *gv;
2053
2054     /* Note that strtab is a rather special HV.  Assumptions are made
2055        about not iterating on it, and not adding tie magic to it.
2056        It is properly deallocated in perl_destruct() */
2057     PL_strtab = newHV();
2058 #ifdef USE_THREADS
2059     MUTEX_INIT(&PL_strtab_mutex);
2060 #endif
2061     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
2062     hv_ksplit(PL_strtab, 512);
2063
2064     PL_curstash = PL_defstash = newHV();
2065     PL_curstname = newSVpvn("main",4);
2066     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2067     SvREFCNT_dec(GvHV(gv));
2068     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2069     SvREADONLY_on(gv);
2070     HvNAME(PL_defstash) = savepv("main");
2071     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2072     GvMULTI_on(PL_incgv);
2073     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2074     GvMULTI_on(PL_hintgv);
2075     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2076     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2077     GvMULTI_on(PL_errgv);
2078     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2079     GvMULTI_on(PL_replgv);
2080     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2081     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2082     sv_setpvn(ERRSV, "", 0);
2083     PL_curstash = PL_defstash;
2084     PL_compiling.cop_stash = PL_defstash;
2085     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2086     /* We must init $/ before switches are processed. */
2087     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2088 }
2089
2090 STATIC void
2091 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2092 {
2093     dTHR;
2094     register char *s;
2095
2096     *fdscript = -1;
2097
2098     if (PL_e_script) {
2099         PL_origfilename = savepv("-e");
2100     }
2101     else {
2102         /* if find_script() returns, it returns a malloc()-ed value */
2103         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2104
2105         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2106             char *s = scriptname + 8;
2107             *fdscript = atoi(s);
2108             while (isDIGIT(*s))
2109                 s++;
2110             if (*s) {
2111                 scriptname = savepv(s + 1);
2112                 Safefree(PL_origfilename);
2113                 PL_origfilename = scriptname;
2114             }
2115         }
2116     }
2117
2118     CopFILEGV_set(PL_curcop, gv_fetchfile(PL_origfilename));
2119     if (strEQ(PL_origfilename,"-"))
2120         scriptname = "";
2121     if (*fdscript >= 0) {
2122         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2123 #if defined(HAS_FCNTL) && defined(F_SETFD)
2124         if (PL_rsfp)
2125             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2126 #endif
2127     }
2128     else if (PL_preprocess) {
2129         char *cpp_cfg = CPPSTDIN;
2130         SV *cpp = newSVpvn("",0);
2131         SV *cmd = NEWSV(0,0);
2132
2133         if (strEQ(cpp_cfg, "cppstdin"))
2134             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2135         sv_catpv(cpp, cpp_cfg);
2136
2137         sv_catpv(sv,"-I");
2138         sv_catpv(sv,PRIVLIB_EXP);
2139
2140 #ifdef MSDOS
2141         Perl_sv_setpvf(aTHX_ cmd, "\
2142 sed %s -e \"/^[^#]/b\" \
2143  -e \"/^#[      ]*include[      ]/b\" \
2144  -e \"/^#[      ]*define[       ]/b\" \
2145  -e \"/^#[      ]*if[   ]/b\" \
2146  -e \"/^#[      ]*ifdef[        ]/b\" \
2147  -e \"/^#[      ]*ifndef[       ]/b\" \
2148  -e \"/^#[      ]*else/b\" \
2149  -e \"/^#[      ]*elif[         ]/b\" \
2150  -e \"/^#[      ]*undef[        ]/b\" \
2151  -e \"/^#[      ]*endif/b\" \
2152  -e \"s/^#.*//\" \
2153  %s | %_ -C %_ %s",
2154           (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2155 #else
2156 #  ifdef __OPEN_VM
2157         Perl_sv_setpvf(aTHX_ cmd, "\
2158 %s %s -e '/^[^#]/b' \
2159  -e '/^#[       ]*include[      ]/b' \
2160  -e '/^#[       ]*define[       ]/b' \
2161  -e '/^#[       ]*if[   ]/b' \
2162  -e '/^#[       ]*ifdef[        ]/b' \
2163  -e '/^#[       ]*ifndef[       ]/b' \
2164  -e '/^#[       ]*else/b' \
2165  -e '/^#[       ]*elif[         ]/b' \
2166  -e '/^#[       ]*undef[        ]/b' \
2167  -e '/^#[       ]*endif/b' \
2168  -e 's/^[       ]*#.*//' \
2169  %s | %_ %_ %s",
2170 #  else
2171         Perl_sv_setpvf(aTHX_ cmd, "\
2172 %s %s -e '/^[^#]/b' \
2173  -e '/^#[       ]*include[      ]/b' \
2174  -e '/^#[       ]*define[       ]/b' \
2175  -e '/^#[       ]*if[   ]/b' \
2176  -e '/^#[       ]*ifdef[        ]/b' \
2177  -e '/^#[       ]*ifndef[       ]/b' \
2178  -e '/^#[       ]*else/b' \
2179  -e '/^#[       ]*elif[         ]/b' \
2180  -e '/^#[       ]*undef[        ]/b' \
2181  -e '/^#[       ]*endif/b' \
2182  -e 's/^[       ]*#.*//' \
2183  %s | %_ -C %_ %s",
2184 #  endif
2185 #ifdef LOC_SED
2186           LOC_SED,
2187 #else
2188           "sed",
2189 #endif
2190           (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2191 #endif
2192           scriptname, cpp, sv, CPPMINUS);
2193         PL_doextract = FALSE;
2194 #ifdef IAMSUID                          /* actually, this is caught earlier */
2195         if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
2196 #ifdef HAS_SETEUID
2197             (void)seteuid(PL_uid);              /* musn't stay setuid root */
2198 #else
2199 #ifdef HAS_SETREUID
2200             (void)setreuid((Uid_t)-1, PL_uid);
2201 #else
2202 #ifdef HAS_SETRESUID
2203             (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2204 #else
2205             PerlProc_setuid(PL_uid);
2206 #endif
2207 #endif
2208 #endif
2209             if (PerlProc_geteuid() != PL_uid)
2210                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2211         }
2212 #endif /* IAMSUID */
2213         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2214         SvREFCNT_dec(cmd);
2215         SvREFCNT_dec(cpp);
2216     }
2217     else if (!*scriptname) {
2218         forbid_setid("program input from stdin");
2219         PL_rsfp = PerlIO_stdin();
2220     }
2221     else {
2222         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2223 #if defined(HAS_FCNTL) && defined(F_SETFD)
2224         if (PL_rsfp)
2225             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2226 #endif
2227     }
2228     if (!PL_rsfp) {
2229 #ifdef DOSUID
2230 #ifndef IAMSUID         /* in case script is not readable before setuid */
2231         if (PL_euid &&
2232             PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2233             PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2234         {
2235             /* try again */
2236             PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2237             Perl_croak(aTHX_ "Can't do setuid\n");
2238         }
2239 #endif
2240 #endif
2241         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2242                    CopFILE(PL_curcop), Strerror(errno));
2243     }
2244 }
2245
2246 /* Mention
2247  * I_SYSSTATVFS HAS_FSTATVFS
2248  * I_SYSMOUNT
2249  * I_STATFS     HAS_FSTATFS
2250  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2251  * here so that metaconfig picks them up. */
2252
2253 #ifdef IAMSUID
2254 STATIC int
2255 S_fd_on_nosuid_fs(pTHX_ int fd)
2256 {
2257     int check_okay = 0; /* able to do all the required sys/libcalls */
2258     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2259 /*
2260  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2261  * fstatvfs() is UNIX98.
2262  * fstatfs() is 4.3 BSD.
2263  * ustat()+getmnt() is pre-4.3 BSD.
2264  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2265  * an irrelevant filesystem while trying to reach the right one.
2266  */
2267
2268 #   ifdef HAS_FSTATVFS
2269     struct statvfs stfs;
2270     check_okay = fstatvfs(fd, &stfs) == 0;
2271     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2272 #   else
2273 #       ifdef PERL_MOUNT_NOSUID
2274 #           if defined(HAS_FSTATFS) && \
2275                defined(HAS_STRUCT_STATFS) && \
2276                defined(HAS_STRUCT_STATFS_F_FLAGS)
2277     struct statfs  stfs;
2278     check_okay = fstatfs(fd, &stfs)  == 0;
2279     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2280 #           else
2281 #               if defined(HAS_FSTAT) && \
2282                    defined(HAS_USTAT) && \
2283                    defined(HAS_GETMNT) && \
2284                    defined(HAS_STRUCT_FS_DATA) &&
2285                    defined(NOSTAT_ONE)
2286     struct stat fdst;
2287     if (fstat(fd, &fdst) == 0) {
2288         struct ustat us;
2289         if (ustat(fdst.st_dev, &us) == 0) {
2290             struct fs_data fsd;
2291             /* NOSTAT_ONE here because we're not examining fields which
2292              * vary between that case and STAT_ONE. */
2293             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2294                 size_t cmplen = sizeof(us.f_fname);
2295                 if (sizeof(fsd.fd_req.path) < cmplen)
2296                     cmplen = sizeof(fsd.fd_req.path);
2297                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2298                     fdst.st_dev == fsd.fd_req.dev) {
2299                         check_okay = 1;
2300                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2301                     }
2302                 }
2303             }
2304         }
2305     }
2306 #               endif /* fstat+ustat+getmnt */
2307 #           endif /* fstatfs */
2308 #       else
2309 #           if defined(HAS_GETMNTENT) && \
2310                defined(HAS_HASMNTOPT) && \
2311                defined(MNTOPT_NOSUID)
2312     FILE                *mtab = fopen("/etc/mtab", "r");
2313     struct mntent       *entry;
2314     struct stat         stb, fsb;
2315
2316     if (mtab && (fstat(fd, &stb) == 0)) {
2317         while (entry = getmntent(mtab)) {
2318             if (stat(entry->mnt_dir, &fsb) == 0
2319                 && fsb.st_dev == stb.st_dev)
2320             {
2321                 /* found the filesystem */
2322                 check_okay = 1;
2323                 if (hasmntopt(entry, MNTOPT_NOSUID))
2324                     on_nosuid = 1;
2325                 break;
2326             } /* A single fs may well fail its stat(). */
2327         }
2328     }
2329     if (mtab)
2330         fclose(mtab);
2331 #           endif /* getmntent+hasmntopt */
2332 #       endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2333 #   endif /* statvfs */
2334
2335     if (!check_okay)
2336         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2337     return on_nosuid;
2338 }
2339 #endif /* IAMSUID */
2340
2341 STATIC void
2342 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2343 {
2344     int which;
2345
2346     /* do we need to emulate setuid on scripts? */
2347
2348     /* This code is for those BSD systems that have setuid #! scripts disabled
2349      * in the kernel because of a security problem.  Merely defining DOSUID
2350      * in perl will not fix that problem, but if you have disabled setuid
2351      * scripts in the kernel, this will attempt to emulate setuid and setgid
2352      * on scripts that have those now-otherwise-useless bits set.  The setuid
2353      * root version must be called suidperl or sperlN.NNN.  If regular perl
2354      * discovers that it has opened a setuid script, it calls suidperl with
2355      * the same argv that it had.  If suidperl finds that the script it has
2356      * just opened is NOT setuid root, it sets the effective uid back to the
2357      * uid.  We don't just make perl setuid root because that loses the
2358      * effective uid we had before invoking perl, if it was different from the
2359      * uid.
2360      *
2361      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2362      * be defined in suidperl only.  suidperl must be setuid root.  The
2363      * Configure script will set this up for you if you want it.
2364      */
2365
2366 #ifdef DOSUID
2367     dTHR;
2368     char *s, *s2;
2369
2370     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2371         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2372     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2373         I32 len;
2374         STRLEN n_a;
2375
2376 #ifdef IAMSUID
2377 #ifndef HAS_SETREUID
2378         /* On this access check to make sure the directories are readable,
2379          * there is actually a small window that the user could use to make
2380          * filename point to an accessible directory.  So there is a faint
2381          * chance that someone could execute a setuid script down in a
2382          * non-accessible directory.  I don't know what to do about that.
2383          * But I don't think it's too important.  The manual lies when
2384          * it says access() is useful in setuid programs.
2385          */
2386         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2387             Perl_croak(aTHX_ "Permission denied");
2388 #else
2389         /* If we can swap euid and uid, then we can determine access rights
2390          * with a simple stat of the file, and then compare device and
2391          * inode to make sure we did stat() on the same file we opened.
2392          * Then we just have to make sure he or she can execute it.
2393          */
2394         {
2395             struct stat tmpstatbuf;
2396
2397             if (
2398 #ifdef HAS_SETREUID
2399                 setreuid(PL_euid,PL_uid) < 0
2400 #else
2401 # if HAS_SETRESUID
2402                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2403 # endif
2404 #endif
2405                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2406                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
2407             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2408                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
2409 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2410             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2411                 Perl_croak(aTHX_ "Permission denied");
2412 #endif
2413             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2414                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2415                 (void)PerlIO_close(PL_rsfp);
2416                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2417                     PerlIO_printf(PL_rsfp,
2418 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2419 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2420                         PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2421                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2422                         CopFILE(PL_curcop),
2423                         PL_statbuf.st_uid, PL_statbuf.st_gid);
2424                     (void)PerlProc_pclose(PL_rsfp);
2425                 }
2426                 Perl_croak(aTHX_ "Permission denied\n");
2427             }
2428             if (
2429 #ifdef HAS_SETREUID
2430               setreuid(PL_uid,PL_euid) < 0
2431 #else
2432 # if defined(HAS_SETRESUID)
2433               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2434 # endif
2435 #endif
2436               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2437                 Perl_croak(aTHX_ "Can't reswap uid and euid");
2438             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2439                 Perl_croak(aTHX_ "Permission denied\n");
2440         }
2441 #endif /* HAS_SETREUID */
2442 #endif /* IAMSUID */
2443
2444         if (!S_ISREG(PL_statbuf.st_mode))
2445             Perl_croak(aTHX_ "Permission denied");
2446         if (PL_statbuf.st_mode & S_IWOTH)
2447             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2448         PL_doswitches = FALSE;          /* -s is insecure in suid */
2449         PL_curcop->cop_line++;
2450         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2451           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2452             Perl_croak(aTHX_ "No #! line");
2453         s = SvPV(PL_linestr,n_a)+2;
2454         if (*s == ' ') s++;
2455         while (!isSPACE(*s)) s++;
2456         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
2457                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2458         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2459             Perl_croak(aTHX_ "Not a perl script");
2460         while (*s == ' ' || *s == '\t') s++;
2461         /*
2462          * #! arg must be what we saw above.  They can invoke it by
2463          * mentioning suidperl explicitly, but they may not add any strange
2464          * arguments beyond what #! says if they do invoke suidperl that way.
2465          */
2466         len = strlen(validarg);
2467         if (strEQ(validarg," PHOOEY ") ||
2468             strnNE(s,validarg,len) || !isSPACE(s[len]))
2469             Perl_croak(aTHX_ "Args must match #! line");
2470
2471 #ifndef IAMSUID
2472         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2473             PL_euid == PL_statbuf.st_uid)
2474             if (!PL_do_undump)
2475                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2476 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2477 #endif /* IAMSUID */
2478
2479         if (PL_euid) {  /* oops, we're not the setuid root perl */
2480             (void)PerlIO_close(PL_rsfp);
2481 #ifndef IAMSUID
2482             /* try again */
2483             PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2484 #endif
2485             Perl_croak(aTHX_ "Can't do setuid\n");
2486         }
2487
2488         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2489 #ifdef HAS_SETEGID
2490             (void)setegid(PL_statbuf.st_gid);
2491 #else
2492 #ifdef HAS_SETREGID
2493            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2494 #else
2495 #ifdef HAS_SETRESGID
2496            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2497 #else
2498             PerlProc_setgid(PL_statbuf.st_gid);
2499 #endif
2500 #endif
2501 #endif
2502             if (PerlProc_getegid() != PL_statbuf.st_gid)
2503                 Perl_croak(aTHX_ "Can't do setegid!\n");
2504         }
2505         if (PL_statbuf.st_mode & S_ISUID) {
2506             if (PL_statbuf.st_uid != PL_euid)
2507 #ifdef HAS_SETEUID
2508                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2509 #else
2510 #ifdef HAS_SETREUID
2511                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2512 #else
2513 #ifdef HAS_SETRESUID
2514                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2515 #else
2516                 PerlProc_setuid(PL_statbuf.st_uid);
2517 #endif
2518 #endif
2519 #endif
2520             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2521                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2522         }
2523         else if (PL_uid) {                      /* oops, mustn't run as root */
2524 #ifdef HAS_SETEUID
2525           (void)seteuid((Uid_t)PL_uid);
2526 #else
2527 #ifdef HAS_SETREUID
2528           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2529 #else
2530 #ifdef HAS_SETRESUID
2531           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2532 #else
2533           PerlProc_setuid((Uid_t)PL_uid);
2534 #endif
2535 #endif
2536 #endif
2537             if (PerlProc_geteuid() != PL_uid)
2538                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2539         }
2540         init_ids();
2541         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2542             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
2543     }
2544 #ifdef IAMSUID
2545     else if (PL_preprocess)
2546         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2547     else if (fdscript >= 0)
2548         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2549     else
2550         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2551
2552     /* We absolutely must clear out any saved ids here, so we */
2553     /* exec the real perl, substituting fd script for scriptname. */
2554     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2555     PerlIO_rewind(PL_rsfp);
2556     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2557     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2558     if (!PL_origargv[which])
2559         Perl_croak(aTHX_ "Permission denied");
2560     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2561                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2562 #if defined(HAS_FCNTL) && defined(F_SETFD)
2563     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
2564 #endif
2565     PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2566     Perl_croak(aTHX_ "Can't do setuid\n");
2567 #endif /* IAMSUID */
2568 #else /* !DOSUID */
2569     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
2570 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2571         dTHR;
2572         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
2573         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2574             ||
2575             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2576            )
2577             if (!PL_do_undump)
2578                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2579 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2580 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2581         /* not set-id, must be wrapped */
2582     }
2583 #endif /* DOSUID */
2584 }
2585
2586 STATIC void
2587 S_find_beginning(pTHX)
2588 {
2589     register char *s, *s2;
2590
2591     /* skip forward in input to the real script? */
2592
2593     forbid_setid("-x");
2594     while (PL_doextract) {
2595         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2596             Perl_croak(aTHX_ "No Perl script found in input\n");
2597         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2598             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
2599             PL_doextract = FALSE;
2600             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2601             s2 = s;
2602             while (*s == ' ' || *s == '\t') s++;
2603             if (*s++ == '-') {
2604                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2605                 if (strnEQ(s2-4,"perl",4))
2606                     /*SUPPRESS 530*/
2607                     while (s = moreswitches(s)) ;
2608             }
2609         }
2610     }
2611 }
2612
2613
2614 STATIC void
2615 S_init_ids(pTHX)
2616 {
2617     PL_uid = PerlProc_getuid();
2618     PL_euid = PerlProc_geteuid();
2619     PL_gid = PerlProc_getgid();
2620     PL_egid = PerlProc_getegid();
2621 #ifdef VMS
2622     PL_uid |= PL_gid << 16;
2623     PL_euid |= PL_egid << 16;
2624 #endif
2625     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2626 }
2627
2628 STATIC void
2629 S_forbid_setid(pTHX_ char *s)
2630 {
2631     if (PL_euid != PL_uid)
2632         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2633     if (PL_egid != PL_gid)
2634         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2635 }
2636
2637 void
2638 Perl_init_debugger(pTHX)
2639 {
2640     dTHR;
2641     HV *ostash = PL_curstash;
2642
2643     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2644     PL_curstash = PL_debstash;
2645     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2646     AvREAL_off(PL_dbargs);
2647     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2648     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2649     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2650     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2651     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2652     sv_setiv(PL_DBsingle, 0);
2653     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2654     sv_setiv(PL_DBtrace, 0);
2655     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2656     sv_setiv(PL_DBsignal, 0);
2657     PL_curstash = ostash;
2658 }
2659
2660 #ifndef STRESS_REALLOC
2661 #define REASONABLE(size) (size)
2662 #else
2663 #define REASONABLE(size) (1) /* unreasonable */
2664 #endif
2665
2666 void
2667 Perl_init_stacks(pTHX)
2668 {
2669     /* start with 128-item stack and 8K cxstack */
2670     PL_curstackinfo = new_stackinfo(REASONABLE(128),
2671                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2672     PL_curstackinfo->si_type = PERLSI_MAIN;
2673     PL_curstack = PL_curstackinfo->si_stack;
2674     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
2675
2676     PL_stack_base = AvARRAY(PL_curstack);
2677     PL_stack_sp = PL_stack_base;
2678     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2679
2680     New(50,PL_tmps_stack,REASONABLE(128),SV*);
2681     PL_tmps_floor = -1;
2682     PL_tmps_ix = -1;
2683     PL_tmps_max = REASONABLE(128);
2684
2685     New(54,PL_markstack,REASONABLE(32),I32);
2686     PL_markstack_ptr = PL_markstack;
2687     PL_markstack_max = PL_markstack + REASONABLE(32);
2688
2689     SET_MARKBASE;
2690
2691     New(54,PL_scopestack,REASONABLE(32),I32);
2692     PL_scopestack_ix = 0;
2693     PL_scopestack_max = REASONABLE(32);
2694
2695     New(54,PL_savestack,REASONABLE(128),ANY);
2696     PL_savestack_ix = 0;
2697     PL_savestack_max = REASONABLE(128);
2698
2699     New(54,PL_retstack,REASONABLE(16),OP*);
2700     PL_retstack_ix = 0;
2701     PL_retstack_max = REASONABLE(16);
2702 }
2703
2704 #undef REASONABLE
2705
2706 STATIC void
2707 S_nuke_stacks(pTHX)
2708 {
2709     dTHR;
2710     while (PL_curstackinfo->si_next)
2711         PL_curstackinfo = PL_curstackinfo->si_next;
2712     while (PL_curstackinfo) {
2713         PERL_SI *p = PL_curstackinfo->si_prev;
2714         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2715         Safefree(PL_curstackinfo->si_cxstack);
2716         Safefree(PL_curstackinfo);
2717         PL_curstackinfo = p;
2718     }
2719     Safefree(PL_tmps_stack);
2720     Safefree(PL_markstack);
2721     Safefree(PL_scopestack);
2722     Safefree(PL_savestack);
2723     Safefree(PL_retstack);
2724 }
2725
2726 #ifndef PERL_OBJECT
2727 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2728 #endif
2729
2730 STATIC void
2731 S_init_lexer(pTHX)
2732 {
2733 #ifdef PERL_OBJECT
2734         PerlIO *tmpfp;
2735 #endif
2736     tmpfp = PL_rsfp;
2737     PL_rsfp = Nullfp;
2738     lex_start(PL_linestr);
2739     PL_rsfp = tmpfp;
2740     PL_subname = newSVpvn("main",4);
2741 }
2742
2743 STATIC void
2744 S_init_predump_symbols(pTHX)
2745 {
2746     dTHR;
2747     GV *tmpgv;
2748     GV *othergv;
2749     IO *io;
2750
2751     sv_setpvn(get_sv("\"", TRUE), " ", 1);
2752     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2753     GvMULTI_on(PL_stdingv);
2754     io = GvIOp(PL_stdingv);
2755     IoIFP(io) = PerlIO_stdin();
2756     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2757     GvMULTI_on(tmpgv);
2758     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2759
2760     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2761     GvMULTI_on(tmpgv);
2762     io = GvIOp(tmpgv);
2763     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2764     setdefout(tmpgv);
2765     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2766     GvMULTI_on(tmpgv);
2767     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2768
2769     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2770     GvMULTI_on(PL_stderrgv);
2771     io = GvIOp(PL_stderrgv);
2772     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2773     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2774     GvMULTI_on(tmpgv);
2775     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2776
2777     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
2778
2779     if (!PL_osname)
2780         PL_osname = savepv(OSNAME);
2781 }
2782
2783 STATIC void
2784 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2785 {
2786     dTHR;
2787     char *s;
2788     SV *sv;
2789     GV* tmpgv;
2790
2791     argc--,argv++;      /* skip name of script */
2792     if (PL_doswitches) {
2793         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2794             if (!argv[0][1])
2795                 break;
2796             if (argv[0][1] == '-') {
2797                 argc--,argv++;
2798                 break;
2799             }
2800             if (s = strchr(argv[0], '=')) {
2801                 *s++ = '\0';
2802                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2803             }
2804             else
2805                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2806         }
2807     }
2808     PL_toptarget = NEWSV(0,0);
2809     sv_upgrade(PL_toptarget, SVt_PVFM);
2810     sv_setpvn(PL_toptarget, "", 0);
2811     PL_bodytarget = NEWSV(0,0);
2812     sv_upgrade(PL_bodytarget, SVt_PVFM);
2813     sv_setpvn(PL_bodytarget, "", 0);
2814     PL_formtarget = PL_bodytarget;
2815
2816     TAINT;
2817     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2818         sv_setpv(GvSV(tmpgv),PL_origfilename);
2819         magicname("0", "0", 1);
2820     }
2821     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2822 #ifdef OS2
2823         sv_setpv(GvSV(tmpgv), os2_execname());
2824 #else
2825         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2826 #endif
2827     if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2828         GvMULTI_on(PL_argvgv);
2829         (void)gv_AVadd(PL_argvgv);
2830         av_clear(GvAVn(PL_argvgv));
2831         for (; argc > 0; argc--,argv++) {
2832             av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2833         }
2834     }
2835     if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2836         HV *hv;
2837         GvMULTI_on(PL_envgv);
2838         hv = GvHVn(PL_envgv);
2839         hv_magic(hv, PL_envgv, 'E');
2840 #if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
2841         /* Note that if the supplied env parameter is actually a copy
2842            of the global environ then it may now point to free'd memory
2843            if the environment has been modified since. To avoid this
2844            problem we treat env==NULL as meaning 'use the default'
2845         */
2846         if (!env)
2847             env = environ;
2848         if (env != environ)
2849             environ[0] = Nullch;
2850         for (; *env; env++) {
2851             if (!(s = strchr(*env,'=')))
2852                 continue;
2853             *s++ = '\0';
2854 #if defined(MSDOS)
2855             (void)strupr(*env);
2856 #endif
2857             sv = newSVpv(s--,0);
2858             (void)hv_store(hv, *env, s - *env, sv, 0);
2859             *s = '=';
2860 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2861             /* Sins of the RTL. See note in my_setenv(). */
2862             (void)PerlEnv_putenv(savepv(*env));
2863 #endif
2864         }
2865 #endif
2866 #ifdef DYNAMIC_ENV_FETCH
2867         HvNAME(hv) = savepv(ENV_HV_NAME);
2868 #endif
2869     }
2870     TAINT_NOT;
2871     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2872         sv_setiv(GvSV(tmpgv), (IV)getpid());
2873 }
2874
2875 STATIC void
2876 S_init_perllib(pTHX)
2877 {
2878     char *s;
2879     if (!PL_tainting) {
2880 #ifndef VMS
2881         s = PerlEnv_getenv("PERL5LIB");
2882         if (s)
2883             incpush(s, TRUE);
2884         else
2885             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2886 #else /* VMS */
2887         /* Treat PERL5?LIB as a possible search list logical name -- the
2888          * "natural" VMS idiom for a Unix path string.  We allow each
2889          * element to be a set of |-separated directories for compatibility.
2890          */
2891         char buf[256];
2892         int idx = 0;
2893         if (my_trnlnm("PERL5LIB",buf,0))
2894             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2895         else
2896             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2897 #endif /* VMS */
2898     }
2899
2900 /* Use the ~-expanded versions of APPLLIB (undocumented),
2901     ARCHLIB PRIVLIB SITEARCH and SITELIB
2902 */
2903 #ifdef APPLLIB_EXP
2904     incpush(APPLLIB_EXP, TRUE);
2905 #endif
2906
2907 #ifdef ARCHLIB_EXP
2908     incpush(ARCHLIB_EXP, FALSE);
2909 #endif
2910 #ifndef PRIVLIB_EXP
2911 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2912 #endif
2913 #if defined(WIN32)
2914     incpush(PRIVLIB_EXP, TRUE);
2915 #else
2916     incpush(PRIVLIB_EXP, FALSE);
2917 #endif
2918
2919 #ifdef SITEARCH_EXP
2920     incpush(SITEARCH_EXP, FALSE);
2921 #endif
2922 #ifdef SITELIB_EXP
2923 #if defined(WIN32)
2924     incpush(SITELIB_EXP, TRUE);
2925 #else
2926     incpush(SITELIB_EXP, FALSE);
2927 #endif
2928 #endif
2929 #if defined(PERL_VENDORLIB_EXP)
2930 #if defined(WIN32)
2931     incpush(PERL_VENDORLIB_EXP, TRUE);
2932 #else
2933     incpush(PERL_VENDORLIB_EXP, FALSE);
2934 #endif
2935 #endif
2936     if (!PL_tainting)
2937         incpush(".", FALSE);
2938 }
2939
2940 #if defined(DOSISH)
2941 #    define PERLLIB_SEP ';'
2942 #else
2943 #  if defined(VMS)
2944 #    define PERLLIB_SEP '|'
2945 #  else
2946 #    define PERLLIB_SEP ':'
2947 #  endif
2948 #endif
2949 #ifndef PERLLIB_MANGLE
2950 #  define PERLLIB_MANGLE(s,n) (s)
2951 #endif
2952
2953 STATIC void
2954 S_incpush(pTHX_ char *p, int addsubdirs)
2955 {
2956     SV *subdir = Nullsv;
2957
2958     if (!p)
2959         return;
2960
2961     if (addsubdirs) {
2962         subdir = sv_newmortal();
2963         if (!PL_archpat_auto) {
2964             STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2965                           + sizeof("//auto"));
2966             New(55, PL_archpat_auto, len, char);
2967             sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2968 #ifdef VMS
2969         for (len = sizeof(ARCHNAME) + 2;
2970              PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2971                 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2972 #endif
2973         }
2974     }
2975
2976     /* Break at all separators */
2977     while (p && *p) {
2978         SV *libdir = NEWSV(55,0);
2979         char *s;
2980
2981         /* skip any consecutive separators */
2982         while ( *p == PERLLIB_SEP ) {
2983             /* Uncomment the next line for PATH semantics */
2984             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2985             p++;
2986         }
2987
2988         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2989             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2990                       (STRLEN)(s - p));
2991             p = s + 1;
2992         }
2993         else {
2994             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2995             p = Nullch; /* break out */
2996         }
2997
2998         /*
2999          * BEFORE pushing libdir onto @INC we may first push version- and
3000          * archname-specific sub-directories.
3001          */
3002         if (addsubdirs) {
3003             struct stat tmpstatbuf;
3004 #ifdef VMS
3005             char *unix;
3006             STRLEN len;
3007
3008             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3009                 len = strlen(unix);
3010                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3011                 sv_usepvn(libdir,unix,len);
3012             }
3013             else
3014                 PerlIO_printf(Perl_error_log,
3015                               "Failed to unixify @INC element \"%s\"\n",
3016                               SvPV(libdir,len));
3017 #endif
3018             /* .../archname/version if -d .../archname/version/auto */
3019             sv_setsv(subdir, libdir);
3020             sv_catpv(subdir, PL_archpat_auto);
3021             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3022                   S_ISDIR(tmpstatbuf.st_mode))
3023                 av_push(GvAVn(PL_incgv),
3024                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3025
3026             /* .../archname if -d .../archname/auto */
3027             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3028                       strlen(PL_patchlevel) + 1, "", 0);
3029             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3030                   S_ISDIR(tmpstatbuf.st_mode))
3031                 av_push(GvAVn(PL_incgv),
3032                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3033         }
3034
3035         /* finally push this lib directory on the end of @INC */
3036         av_push(GvAVn(PL_incgv), libdir);
3037     }
3038 }
3039
3040 #ifdef USE_THREADS
3041 STATIC struct perl_thread *
3042 S_init_main_thread(pTHX)
3043 {
3044 #if !defined(PERL_IMPLICIT_CONTEXT)
3045     struct perl_thread *thr;
3046 #endif
3047     XPV *xpv;
3048
3049     Newz(53, thr, 1, struct perl_thread);
3050     PL_curcop = &PL_compiling;
3051     thr->interp = PERL_GET_INTERP;
3052     thr->cvcache = newHV();
3053     thr->threadsv = newAV();
3054     /* thr->threadsvp is set when find_threadsv is called */
3055     thr->specific = newAV();
3056     thr->flags = THRf_R_JOINABLE;
3057     MUTEX_INIT(&thr->mutex);
3058     /* Handcraft thrsv similarly to mess_sv */
3059     New(53, PL_thrsv, 1, SV);
3060     Newz(53, xpv, 1, XPV);
3061     SvFLAGS(PL_thrsv) = SVt_PV;
3062     SvANY(PL_thrsv) = (void*)xpv;
3063     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3064     SvPVX(PL_thrsv) = (char*)thr;
3065     SvCUR_set(PL_thrsv, sizeof(thr));
3066     SvLEN_set(PL_thrsv, sizeof(thr));
3067     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3068     thr->oursv = PL_thrsv;
3069     PL_chopset = " \n-";
3070     PL_dumpindent = 4;
3071
3072     MUTEX_LOCK(&PL_threads_mutex);
3073     PL_nthreads++;
3074     thr->tid = 0;
3075     thr->next = thr;
3076     thr->prev = thr;
3077     MUTEX_UNLOCK(&PL_threads_mutex);
3078
3079 #ifdef HAVE_THREAD_INTERN
3080     Perl_init_thread_intern(thr);
3081 #endif
3082
3083 #ifdef SET_THREAD_SELF
3084     SET_THREAD_SELF(thr);
3085 #else
3086     thr->self = pthread_self();
3087 #endif /* SET_THREAD_SELF */
3088     SET_THR(thr);
3089
3090     /*
3091      * These must come after the SET_THR because sv_setpvn does
3092      * SvTAINT and the taint fields require dTHR.
3093      */
3094     PL_toptarget = NEWSV(0,0);
3095     sv_upgrade(PL_toptarget, SVt_PVFM);
3096     sv_setpvn(PL_toptarget, "", 0);
3097     PL_bodytarget = NEWSV(0,0);
3098     sv_upgrade(PL_bodytarget, SVt_PVFM);
3099     sv_setpvn(PL_bodytarget, "", 0);
3100     PL_formtarget = PL_bodytarget;
3101     thr->errsv = newSVpvn("", 0);
3102     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3103
3104     PL_maxscream = -1;
3105     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3106     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3107     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3108     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3109     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3110     PL_regindent = 0;
3111     PL_reginterp_cnt = 0;
3112
3113     return thr;
3114 }
3115 #endif /* USE_THREADS */
3116
3117 void
3118 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3119 {
3120     dTHR;
3121     SV *atsv = ERRSV;
3122     line_t oldline = PL_curcop->cop_line;
3123     CV *cv;
3124     STRLEN len;
3125     int ret;
3126     dJMPENV;
3127
3128     while (AvFILL(paramList) >= 0) {
3129         cv = (CV*)av_shift(paramList);
3130         SAVEFREESV(cv);
3131         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3132         switch (ret) {
3133         case 0:
3134             (void)SvPV(atsv, len);
3135             if (len) {
3136                 PL_curcop = &PL_compiling;
3137                 PL_curcop->cop_line = oldline;
3138                 if (paramList == PL_beginav)
3139                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3140                 else
3141                     Perl_sv_catpvf(aTHX_ atsv,
3142                                    "%s failed--call queue aborted",
3143                                    paramList == PL_stopav ? "STOP"
3144                                    : paramList == PL_initav ? "INIT"
3145                                    : "END");
3146                 while (PL_scopestack_ix > oldscope)
3147                     LEAVE;
3148                 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3149             }
3150             break;
3151         case 1:
3152             STATUS_ALL_FAILURE;
3153             /* FALL THROUGH */
3154         case 2:
3155             /* my_exit() was called */
3156             while (PL_scopestack_ix > oldscope)
3157                 LEAVE;
3158             FREETMPS;
3159             PL_curstash = PL_defstash;
3160             PL_curcop = &PL_compiling;
3161             PL_curcop->cop_line = oldline;
3162             if (PL_statusvalue) {
3163                 if (paramList == PL_beginav)
3164                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3165                 else
3166                     Perl_croak(aTHX_ "%s failed--call queue aborted",
3167                                paramList == PL_stopav ? "STOP"
3168                                : paramList == PL_initav ? "INIT"
3169                                : "END");
3170             }
3171             my_exit_jump();
3172             /* NOTREACHED */
3173         case 3:
3174             if (PL_restartop) {
3175                 PL_curcop = &PL_compiling;
3176                 PL_curcop->cop_line = oldline;
3177                 JMPENV_JUMP(3);
3178             }
3179             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3180             FREETMPS;
3181             break;
3182         }
3183     }
3184 }
3185
3186 STATIC void *
3187 S_call_list_body(pTHX_ va_list args)
3188 {
3189     dTHR;
3190     CV *cv = va_arg(args, CV*);
3191
3192     PUSHMARK(PL_stack_sp);
3193     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3194     return NULL;
3195 }
3196
3197 void
3198 Perl_my_exit(pTHX_ U32 status)
3199 {
3200     dTHR;
3201
3202     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3203                           thr, (unsigned long) status));
3204     switch (status) {
3205     case 0:
3206         STATUS_ALL_SUCCESS;
3207         break;
3208     case 1:
3209         STATUS_ALL_FAILURE;
3210         break;
3211     default:
3212         STATUS_NATIVE_SET(status);
3213         break;
3214     }
3215     my_exit_jump();
3216 }
3217
3218 void
3219 Perl_my_failure_exit(pTHX)
3220 {
3221 #ifdef VMS
3222     if (vaxc$errno & 1) {
3223         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3224             STATUS_NATIVE_SET(44);
3225     }
3226     else {
3227         if (!vaxc$errno && errno)       /* unlikely */
3228             STATUS_NATIVE_SET(44);
3229         else
3230             STATUS_NATIVE_SET(vaxc$errno);
3231     }
3232 #else
3233     int exitstatus;
3234     if (errno & 255)
3235         STATUS_POSIX_SET(errno);
3236     else {
3237         exitstatus = STATUS_POSIX >> 8;
3238         if (exitstatus & 255)
3239             STATUS_POSIX_SET(exitstatus);
3240         else
3241             STATUS_POSIX_SET(255);
3242     }
3243 #endif
3244     my_exit_jump();
3245 }
3246
3247 STATIC void
3248 S_my_exit_jump(pTHX)
3249 {
3250     dTHR;
3251     register PERL_CONTEXT *cx;
3252     I32 gimme;
3253     SV **newsp;
3254
3255     if (PL_e_script) {
3256         SvREFCNT_dec(PL_e_script);
3257         PL_e_script = Nullsv;
3258     }
3259
3260     POPSTACK_TO(PL_mainstack);
3261     if (cxstack_ix >= 0) {
3262         if (cxstack_ix > 0)
3263             dounwind(0);
3264         POPBLOCK(cx,PL_curpm);
3265         LEAVE;
3266     }
3267
3268     JMPENV_JUMP(2);
3269 }
3270
3271 #ifdef PERL_OBJECT
3272 #include "XSUB.h"
3273 #endif
3274
3275 static I32
3276 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3277 {
3278     char *p, *nl;
3279     p  = SvPVX(PL_e_script);
3280     nl = strchr(p, '\n');
3281     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3282     if (nl-p == 0) {
3283         filter_del(read_e_script);
3284         return 0;
3285     }
3286     sv_catpvn(buf_sv, p, nl-p);
3287     sv_chop(PL_e_script, nl);
3288     return 1;
3289 }