perl.c

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