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         INIT_THREADS;
 123 #ifdef USE_THREADS
 124 #ifdef ALLOC_THREAD_KEY
 125         ALLOC_THREAD_KEY;
 126 #else
 127         if (pthread_key_create(&PL_thr_key, 0))
 128             Perl_croak(aTHX_ "panic: pthread_key_create");
 129 #endif
 130         MUTEX_INIT(&PL_sv_mutex);
 131         /*
 132          * Safe to use basic SV functions from now on (though
 133          * not things like mortals or tainting yet).
 134          */
 135         MUTEX_INIT(&PL_eval_mutex);
 136         COND_INIT(&PL_eval_cond);
 137         MUTEX_INIT(&PL_threads_mutex);
 138         COND_INIT(&PL_nthreads_cond);
 139 #ifdef EMULATE_ATOMIC_REFCOUNTS
 140         MUTEX_INIT(&PL_svref_mutex);
 141 #endif /* EMULATE_ATOMIC_REFCOUNTS */
 142
 143         MUTEX_INIT(&PL_cred_mutex);
 144
 145         thr = init_main_thread();
 146 #endif /* USE_THREADS */
 147
 148         PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
 149
 150         PL_curcop = &PL_compiling;      /* needed by ckWARN, right away */
 151
 152         PL_linestr = NEWSV(65,79);
 153         sv_upgrade(PL_linestr,SVt_PVIV);
 154
 155         if (!SvREADONLY(&PL_sv_undef)) {
 156             /* set read-only and try to insure than we wont see REFCNT==0
 157                very often */
 158
 159             SvREADONLY_on(&PL_sv_undef);
 160             SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
 161
 162             sv_setpv(&PL_sv_no,PL_No);
 163             SvNV(&PL_sv_no);
 164             SvREADONLY_on(&PL_sv_no);
 165             SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
 166
 167             sv_setpv(&PL_sv_yes,PL_Yes);
 168             SvNV(&PL_sv_yes);
 169             SvREADONLY_on(&PL_sv_yes);
 170             SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
 171         }
 172
 173 #ifdef PERL_OBJECT
 174         /* TODO: */
 175         /* PL_sighandlerp = sighandler; */
 176 #else
 177         PL_sighandlerp = Perl_sighandler;
 178 #endif
 179         PL_pidstatus = newHV();
 180
 181 #ifdef MSDOS
 182         /*
 183          * There is no way we can refer to them from Perl so close them to save
 184          * space.  The other alternative would be to provide STDAUX and STDPRN
 185          * filehandles.
 186          */
 187         (void)fclose(stdaux);
 188         (void)fclose(stdprn);
 189 #endif
 190     }
 191
 192     PL_nrs = newSVpvn("\n", 1);
 193     PL_rs = SvREFCNT_inc(PL_nrs);
 194
 195     init_stacks();
 196
 197     init_ids();
 198     PL_lex_state = LEX_NOTPARSING;
 199
 200     JMPENV_BOOTSTRAP;
 201     STATUS_ALL_SUCCESS;
 202
 203     init_i18nl10n(1);
 204     SET_NUMERIC_STANDARD();
 205
 206     {
 207         U8 *s;
 208         PL_patchlevel = NEWSV(0,4);
 209         SvUPGRADE(PL_patchlevel, SVt_PVNV);
 210         if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
 211             SvGROW(PL_patchlevel,24);
 212         s = (U8*)SvPVX(PL_patchlevel);
 213         s = uv_to_utf8(s, (UV)PERL_REVISION);
 214         s = uv_to_utf8(s, (UV)PERL_VERSION);
 215         s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
 216         *s = '\0';
 217         SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
 218         SvPOK_on(PL_patchlevel);
 219         SvNVX(PL_patchlevel) = (NV)PERL_REVISION
 220                                 + ((NV)PERL_VERSION / (NV)1000)
 221 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
 222                                 + ((NV)PERL_SUBVERSION / (NV)1000000)
 223 #endif
 224                                 ;
 225         SvNOK_on(PL_patchlevel);        /* dual valued */
 226         SvUTF8_on(PL_patchlevel);
 227         SvREADONLY_on(PL_patchlevel);
 228     }
 229
 230 #if defined(LOCAL_PATCH_COUNT)
 231     PL_localpatches = local_patches;    /* For possible -v */
 232 #endif
 233
 234     PerlIO_init();                      /* Hook to IO system */
 235
 236     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
 237     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
 238
 239     ENTER;
 240 }
 241
 242 void
 243 perl_destruct(pTHXx)
 244 {
 245     dTHR;
 246     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 247     I32 last_sv_count;
 248     HV *hv;
 249 #ifdef USE_THREADS
 250     Thread t;
 251     dTHX;
 252 #endif /* USE_THREADS */
 253
 254     /* wait for all pseudo-forked children to finish */
 255     PERL_WAIT_FOR_CHILDREN;
 256
 257 #ifdef USE_THREADS
 258 #ifndef FAKE_THREADS
 259     /* Pass 1 on any remaining threads: detach joinables, join zombies */
 260   retry_cleanup:
 261     MUTEX_LOCK(&PL_threads_mutex);
 262     DEBUG_S(PerlIO_printf(Perl_debug_log,
 263                           "perl_destruct: waiting for %d threads...\n",
 264                           PL_nthreads - 1));
 265     for (t = thr->next; t != thr; t = t->next) {
 266         MUTEX_LOCK(&t->mutex);
 267         switch (ThrSTATE(t)) {
 268             AV *av;
 269         case THRf_ZOMBIE:
 270             DEBUG_S(PerlIO_printf(Perl_debug_log,
 271                                   "perl_destruct: joining zombie %p\n", t));
 272             ThrSETSTATE(t, THRf_DEAD);
 273             MUTEX_UNLOCK(&t->mutex);
 274             PL_nthreads--;
 275             /*
 276              * The SvREFCNT_dec below may take a long time (e.g. av
 277              * may contain an object scalar whose destructor gets
 278              * called) so we have to unlock threads_mutex and start
 279              * all over again.
 280              */
 281             MUTEX_UNLOCK(&PL_threads_mutex);
 282             JOIN(t, &av);
 283             SvREFCNT_dec((SV*)av);
 284             DEBUG_S(PerlIO_printf(Perl_debug_log,
 285                                   "perl_destruct: joined zombie %p OK\n", t));
 286             goto retry_cleanup;
 287         case THRf_R_JOINABLE:
 288             DEBUG_S(PerlIO_printf(Perl_debug_log,
 289                                   "perl_destruct: detaching thread %p\n", t));
 290             ThrSETSTATE(t, THRf_R_DETACHED);
 291             /*
 292              * We unlock threads_mutex and t->mutex in the opposite order
 293              * from which we locked them just so that DETACH won't
 294              * deadlock if it panics. It's only a breach of good style
 295              * not a bug since they are unlocks not locks.
 296              */
 297             MUTEX_UNLOCK(&PL_threads_mutex);
 298             DETACH(t);
 299             MUTEX_UNLOCK(&t->mutex);
 300             goto retry_cleanup;
 301         default:
 302             DEBUG_S(PerlIO_printf(Perl_debug_log,
 303                                   "perl_destruct: ignoring %p (state %u)\n",
 304                                   t, ThrSTATE(t)));
 305             MUTEX_UNLOCK(&t->mutex);
 306             /* fall through and out */
 307         }
 308     }
 309     /* We leave the above "Pass 1" loop with threads_mutex still locked */
 310
 311     /* Pass 2 on remaining threads: wait for the thread count to drop to one */
 312     while (PL_nthreads > 1)
 313     {
 314         DEBUG_S(PerlIO_printf(Perl_debug_log,
 315                               "perl_destruct: final wait for %d threads\n",
 316                               PL_nthreads - 1));
 317         COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
 318     }
 319     /* At this point, we're the last thread */
 320     MUTEX_UNLOCK(&PL_threads_mutex);
 321     DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
 322     MUTEX_DESTROY(&PL_threads_mutex);
 323     COND_DESTROY(&PL_nthreads_cond);
 324 #endif /* !defined(FAKE_THREADS) */
 325 #endif /* USE_THREADS */
 326
 327     destruct_level = PL_perl_destruct_level;
 328 #ifdef DEBUGGING
 329     {
 330         char *s;
 331         if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
 332             int i = atoi(s);
 333             if (destruct_level < i)
 334                 destruct_level = i;
 335         }
 336     }
 337 #endif
 338
 339     LEAVE;
 340     FREETMPS;
 341
 342     /* We must account for everything.  */
 343
 344     /* Destroy the main CV and syntax tree */
 345     if (PL_main_root) {
 346         PL_curpad = AvARRAY(PL_comppad);
 347         op_free(PL_main_root);
 348         PL_main_root = Nullop;
 349     }
 350     PL_curcop = &PL_compiling;
 351     PL_main_start = Nullop;
 352     SvREFCNT_dec(PL_main_cv);
 353     PL_main_cv = Nullcv;
 354     PL_dirty = TRUE;
 355
 356     if (PL_sv_objcount) {
 357         /*
 358          * Try to destruct global references.  We do this first so that the
 359          * destructors and destructees still exist.  Some sv's might remain.
 360          * Non-referenced objects are on their own.
 361          */
 362         sv_clean_objs();
 363     }
 364
 365     /* unhook hooks which will soon be, or use, destroyed data */
 366     SvREFCNT_dec(PL_warnhook);
 367     PL_warnhook = Nullsv;
 368     SvREFCNT_dec(PL_diehook);
 369     PL_diehook = Nullsv;
 370
 371     /* call exit list functions */
 372     while (PL_exitlistlen-- > 0)
 373         PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
 374
 375     Safefree(PL_exitlist);
 376
 377     if (destruct_level == 0){
 378
 379         DEBUG_P(debprofdump());
 380
 381         /* The exit() function will do everything that needs doing. */
 382         return;
 383     }
 384
 385     /* loosen bonds of global variables */
 386
 387     if(PL_rsfp) {
 388         (void)PerlIO_close(PL_rsfp);
 389         PL_rsfp = Nullfp;
 390     }
 391
 392     /* Filters for program text */
 393     SvREFCNT_dec(PL_rsfp_filters);
 394     PL_rsfp_filters = Nullav;
 395
 396     /* switches */
 397     PL_preprocess   = FALSE;
 398     PL_minus_n      = FALSE;
 399     PL_minus_p      = FALSE;
 400     PL_minus_l      = FALSE;
 401     PL_minus_a      = FALSE;
 402     PL_minus_F      = FALSE;
 403     PL_doswitches   = FALSE;
 404     PL_dowarn       = G_WARN_OFF;
 405     PL_doextract    = FALSE;
 406     PL_sawampersand = FALSE;    /* must save all match strings */
 407     PL_unsafe       = FALSE;
 408
 409     Safefree(PL_inplace);
 410     PL_inplace = Nullch;
 411     SvREFCNT_dec(PL_patchlevel);
 412
 413     if (PL_e_script) {
 414         SvREFCNT_dec(PL_e_script);
 415         PL_e_script = Nullsv;
 416     }
 417
 418     /* magical thingies */
 419
 420     Safefree(PL_ofs);   /* $, */
 421     PL_ofs = Nullch;
 422
 423     Safefree(PL_ors);   /* $\ */
 424     PL_ors = Nullch;
 425
 426     SvREFCNT_dec(PL_rs);        /* $/ */
 427     PL_rs = Nullsv;
 428
 429     SvREFCNT_dec(PL_nrs);       /* $/ helper */
 430     PL_nrs = Nullsv;
 431
 432     PL_multiline = 0;   /* $* */
 433
 434     SvREFCNT_dec(PL_statname);
 435     PL_statname = Nullsv;
 436     PL_statgv = Nullgv;
 437
 438     /* defgv, aka *_ should be taken care of elsewhere */
 439
 440     /* clean up after study() */
 441     SvREFCNT_dec(PL_lastscream);
 442     PL_lastscream = Nullsv;
 443     Safefree(PL_screamfirst);
 444     PL_screamfirst = 0;
 445     Safefree(PL_screamnext);
 446     PL_screamnext  = 0;
 447
 448     /* float buffer */
 449     Safefree(PL_efloatbuf);
 450     PL_efloatbuf = Nullch;
 451     PL_efloatsize = 0;
 452
 453     /* startup and shutdown function lists */
 454     SvREFCNT_dec(PL_beginav);
 455     SvREFCNT_dec(PL_endav);
 456     SvREFCNT_dec(PL_stopav);
 457     SvREFCNT_dec(PL_initav);
 458     PL_beginav = Nullav;
 459     PL_endav = Nullav;
 460     PL_stopav = Nullav;
 461     PL_initav = Nullav;
 462
 463     /* shortcuts just get cleared */
 464     PL_envgv = Nullgv;
 465     PL_incgv = Nullgv;
 466     PL_hintgv = Nullgv;
 467     PL_errgv = Nullgv;
 468     PL_argvgv = Nullgv;
 469     PL_argvoutgv = Nullgv;
 470     PL_stdingv = Nullgv;
 471     PL_stderrgv = Nullgv;
 472     PL_last_in_gv = Nullgv;
 473     PL_replgv = Nullgv;
 474     PL_debstash = Nullhv;
 475
 476     /* reset so print() ends up where we expect */
 477     setdefout(Nullgv);
 478
 479     SvREFCNT_dec(PL_argvout_stack);
 480     PL_argvout_stack = Nullav;
 481
 482     SvREFCNT_dec(PL_fdpid);
 483     PL_fdpid = Nullav;
 484     SvREFCNT_dec(PL_modglobal);
 485     PL_modglobal = Nullhv;
 486     SvREFCNT_dec(PL_preambleav);
 487     PL_preambleav = Nullav;
 488     SvREFCNT_dec(PL_subname);
 489     PL_subname = Nullsv;
 490     SvREFCNT_dec(PL_linestr);
 491     PL_linestr = Nullsv;
 492     SvREFCNT_dec(PL_pidstatus);
 493     PL_pidstatus = Nullhv;
 494     SvREFCNT_dec(PL_toptarget);
 495     PL_toptarget = Nullsv;
 496     SvREFCNT_dec(PL_bodytarget);
 497     PL_bodytarget = Nullsv;
 498     PL_formtarget = Nullsv;
 499
 500     /* clear utf8 character classes */
 501     SvREFCNT_dec(PL_utf8_alnum);
 502     SvREFCNT_dec(PL_utf8_alnumc);
 503     SvREFCNT_dec(PL_utf8_ascii);
 504     SvREFCNT_dec(PL_utf8_alpha);
 505     SvREFCNT_dec(PL_utf8_space);
 506     SvREFCNT_dec(PL_utf8_cntrl);
 507     SvREFCNT_dec(PL_utf8_graph);
 508     SvREFCNT_dec(PL_utf8_digit);
 509     SvREFCNT_dec(PL_utf8_upper);
 510     SvREFCNT_dec(PL_utf8_lower);
 511     SvREFCNT_dec(PL_utf8_print);
 512     SvREFCNT_dec(PL_utf8_punct);
 513     SvREFCNT_dec(PL_utf8_xdigit);
 514     SvREFCNT_dec(PL_utf8_mark);
 515     SvREFCNT_dec(PL_utf8_toupper);
 516     SvREFCNT_dec(PL_utf8_tolower);
 517     PL_utf8_alnum       = Nullsv;
 518     PL_utf8_alnumc      = Nullsv;
 519     PL_utf8_ascii       = Nullsv;
 520     PL_utf8_alpha       = Nullsv;
 521     PL_utf8_space       = Nullsv;
 522     PL_utf8_cntrl       = Nullsv;
 523     PL_utf8_graph       = Nullsv;
 524     PL_utf8_digit       = Nullsv;
 525     PL_utf8_upper       = Nullsv;
 526     PL_utf8_lower       = Nullsv;
 527     PL_utf8_print       = Nullsv;
 528     PL_utf8_punct       = Nullsv;
 529     PL_utf8_xdigit      = Nullsv;
 530     PL_utf8_mark        = Nullsv;
 531     PL_utf8_toupper     = Nullsv;
 532     PL_utf8_totitle     = Nullsv;
 533     PL_utf8_tolower     = Nullsv;
 534
 535     if (!specialWARN(PL_compiling.cop_warnings))
 536         SvREFCNT_dec(PL_compiling.cop_warnings);
 537     PL_compiling.cop_warnings = Nullsv;
 538
 539     /* Prepare to destruct main symbol table.  */
 540
 541     hv = PL_defstash;
 542     PL_defstash = 0;
 543     SvREFCNT_dec(hv);
 544     SvREFCNT_dec(PL_curstname);
 545     PL_curstname = Nullsv;
 546
 547     /* clear queued errors */
 548     SvREFCNT_dec(PL_errors);
 549     PL_errors = Nullsv;
 550
 551     FREETMPS;
 552     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 553         if (PL_scopestack_ix != 0)
 554             Perl_warner(aTHX_ WARN_INTERNAL,
 555                  "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 556                  (long)PL_scopestack_ix);
 557         if (PL_savestack_ix != 0)
 558             Perl_warner(aTHX_ WARN_INTERNAL,
 559                  "Unbalanced saves: %ld more saves than restores\n",
 560                  (long)PL_savestack_ix);
 561         if (PL_tmps_floor != -1)
 562             Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
 563                  (long)PL_tmps_floor + 1);
 564         if (cxstack_ix != -1)
 565             Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
 566                  (long)cxstack_ix + 1);
 567     }
 568
 569     /* Now absolutely destruct everything, somehow or other, loops or no. */
 570     last_sv_count = 0;
 571     SvFLAGS(PL_strtab) |= SVTYPEMASK;           /* don't clean out strtab now */
 572     while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
 573         last_sv_count = PL_sv_count;
 574         sv_clean_all();
 575     }
 576     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
 577     SvFLAGS(PL_strtab) |= SVt_PVHV;
 578
 579     /* Destruct the global string table. */
 580     {
 581         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 582          * so that sv_free() won't fail on them.
 583          */
 584         I32 riter;
 585         I32 max;
 586         HE *hent;
 587         HE **array;
 588
 589         riter = 0;
 590         max = HvMAX(PL_strtab);
 591         array = HvARRAY(PL_strtab);
 592         hent = array[0];
 593         for (;;) {
 594             if (hent && ckWARN_d(WARN_INTERNAL)) {
 595                 Perl_warner(aTHX_ WARN_INTERNAL,
 596                      "Unbalanced string table refcount: (%d) for \"%s\"",
 597                      HeVAL(hent) - Nullsv, HeKEY(hent));
 598                 HeVAL(hent) = Nullsv;
 599                 hent = HeNEXT(hent);
 600             }
 601             if (!hent) {
 602                 if (++riter > max)
 603                     break;
 604                 hent = array[riter];
 605             }
 606         }
 607     }
 608     SvREFCNT_dec(PL_strtab);
 609
 610     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 611         Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
 612
 613     sv_free_arenas();
 614
 615     /* No SVs have survived, need to clean out */
 616     Safefree(PL_origfilename);
 617     Safefree(PL_reg_start_tmp);
 618     if (PL_reg_curpm)
 619         Safefree(PL_reg_curpm);
 620     Safefree(PL_reg_poscache);
 621     Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
 622     Safefree(PL_op_mask);
 623     nuke_stacks();
 624     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
 625
 626     DEBUG_P(debprofdump());
 627 #ifdef USE_THREADS
 628     MUTEX_DESTROY(&PL_strtab_mutex);
 629     MUTEX_DESTROY(&PL_sv_mutex);
 630     MUTEX_DESTROY(&PL_eval_mutex);
 631     MUTEX_DESTROY(&PL_cred_mutex);
 632     COND_DESTROY(&PL_eval_cond);
 633 #ifdef EMULATE_ATOMIC_REFCOUNTS
 634     MUTEX_DESTROY(&PL_svref_mutex);
 635 #endif /* EMULATE_ATOMIC_REFCOUNTS */
 636
 637     /* As the penultimate thing, free the non-arena SV for thrsv */
 638     Safefree(SvPVX(PL_thrsv));
 639     Safefree(SvANY(PL_thrsv));
 640     Safefree(PL_thrsv);
 641     PL_thrsv = Nullsv;
 642 #endif /* USE_THREADS */
 643
 644     /* As the absolutely last thing, free the non-arena SV for mess() */
 645
 646     if (PL_mess_sv) {
 647         /* it could have accumulated taint magic */
 648         if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
 649             MAGIC* mg;
 650             MAGIC* moremagic;
 651             for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
 652                 moremagic = mg->mg_moremagic;
 653                 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
 654                     Safefree(mg->mg_ptr);
 655                 Safefree(mg);
 656             }
 657         }
 658         /* we know that type >= SVt_PV */
 659         SvOOK_off(PL_mess_sv);
 660         Safefree(SvPVX(PL_mess_sv));
 661         Safefree(SvANY(PL_mess_sv));
 662         Safefree(PL_mess_sv);
 663         PL_mess_sv = Nullsv;
 664     }
 665 }
 666
 667 void
 668 perl_free(pTHXx)
 669 {
 670 #if defined(PERL_OBJECT)
 671     PerlMem_free(this);
 672 #else
 673     PerlMem_free(aTHXx);
 674 #endif
 675 }
 676
 677 void
 678 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
 679 {
 680     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
 681     PL_exitlist[PL_exitlistlen].fn = fn;
 682     PL_exitlist[PL_exitlistlen].ptr = ptr;
 683     ++PL_exitlistlen;
 684 }
 685
 686 int
 687 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
 688 {
 689     dTHR;
 690     I32 oldscope;
 691     int ret;
 692     dJMPENV;
 693 #ifdef USE_THREADS
 694     dTHX;
 695 #endif
 696
 697 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 698 #ifdef IAMSUID
 699 #undef IAMSUID
 700     Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
 701 setuid perl scripts securely.\n");
 702 #endif
 703 #endif
 704
 705 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
 706     _dyld_lookup_and_bind
 707         ("__environ", (unsigned long *) &environ_pointer, NULL);
 708 #endif /* environ */
 709
 710     PL_origargv = argv;
 711     PL_origargc = argc;
 712 #ifndef VMS  /* VMS doesn't have environ array */
 713     PL_origenviron = environ;
 714 #endif
 715
 716     if (PL_do_undump) {
 717
 718         /* Come here if running an undumped a.out. */
 719
 720         PL_origfilename = savepv(argv[0]);
 721         PL_do_undump = FALSE;
 722         cxstack_ix = -1;                /* start label stack again */
 723         init_ids();
 724         init_postdump_symbols(argc,argv,env);
 725         return 0;
 726     }
 727
 728     if (PL_main_root) {
 729         PL_curpad = AvARRAY(PL_comppad);
 730         op_free(PL_main_root);
 731         PL_main_root = Nullop;
 732     }
 733     PL_main_start = Nullop;
 734     SvREFCNT_dec(PL_main_cv);
 735     PL_main_cv = Nullcv;
 736
 737     time(&PL_basetime);
 738     oldscope = PL_scopestack_ix;
 739     PL_dowarn = G_WARN_OFF;
 740
 741     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
 742                 env, xsinit);
 743     switch (ret) {
 744     case 0:
 745         if (PL_stopav)
 746             call_list(oldscope, PL_stopav);
 747         return 0;
 748     case 1:
 749         STATUS_ALL_FAILURE;
 750         /* FALL THROUGH */
 751     case 2:
 752         /* my_exit() was called */
 753         while (PL_scopestack_ix > oldscope)
 754             LEAVE;
 755         FREETMPS;
 756         PL_curstash = PL_defstash;
 757         if (PL_stopav)
 758             call_list(oldscope, PL_stopav);
 759         return STATUS_NATIVE_EXPORT;
 760     case 3:
 761         PerlIO_printf(Perl_error_log, "panic: top_env\n");
 762         return 1;
 763     }
 764     return 0;
 765 }
 766
 767 STATIC void *
 768 S_parse_body(pTHX_ va_list args)
 769 {
 770     dTHR;
 771     int argc = PL_origargc;
 772     char **argv = PL_origargv;
 773     char **env = va_arg(args, char**);
 774     char *scriptname = NULL;
 775     int fdscript = -1;
 776     VOL bool dosearch = FALSE;
 777     char *validarg = "";
 778     AV* comppadlist;
 779     register SV *sv;
 780     register char *s;
 781     char *cddir = Nullch;
 782
 783     XSINIT_t xsinit = va_arg(args, XSINIT_t);
 784
 785     sv_setpvn(PL_linestr,"",0);
 786     sv = newSVpvn("",0);                /* first used for -I flags */
 787     SAVEFREESV(sv);
 788     init_main_stash();
 789
 790     for (argc--,argv++; argc > 0; argc--,argv++) {
 791         if (argv[0][0] != '-' || !argv[0][1])
 792             break;
 793 #ifdef DOSUID
 794     if (*validarg)
 795         validarg = " PHOOEY ";
 796     else
 797         validarg = argv[0];
 798 #endif
 799         s = argv[0]+1;
 800       reswitch:
 801         switch (*s) {
 802 #ifndef PERL_STRICT_CR
 803         case '\r':
 804 #endif
 805         case ' ':
 806         case '0':
 807         case 'F':
 808         case 'a':
 809         case 'c':
 810         case 'd':
 811         case 'D':
 812         case 'h':
 813         case 'i':
 814         case 'l':
 815         case 'M':
 816         case 'm':
 817         case 'n':
 818         case 'p':
 819         case 's':
 820         case 'u':
 821         case 'U':
 822         case 'v':
 823         case 'W':
 824         case 'X':
 825         case 'w':
 826             if (s = moreswitches(s))
 827                 goto reswitch;
 828             break;
 829
 830         case 'T':
 831             PL_tainting = TRUE;
 832             s++;
 833             goto reswitch;
 834
 835         case 'e':
 836             if (PL_euid != PL_uid || PL_egid != PL_gid)
 837                 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
 838             if (!PL_e_script) {
 839                 PL_e_script = newSVpvn("",0);
 840                 filter_add(read_e_script, NULL);
 841             }
 842             if (*++s)
 843                 sv_catpv(PL_e_script, s);
 844             else if (argv[1]) {
 845                 sv_catpv(PL_e_script, argv[1]);
 846                 argc--,argv++;
 847             }
 848             else
 849                 Perl_croak(aTHX_ "No code specified for -e");
 850             sv_catpv(PL_e_script, "\n");
 851             break;
 852
 853         case 'I':       /* -I handled both here and in moreswitches() */
 854             forbid_setid("-I");
 855             if (!*++s && (s=argv[1]) != Nullch) {
 856                 argc--,argv++;
 857             }
 858             if (s && *s) {
 859                 char *p;
 860                 STRLEN len = strlen(s);
 861                 p = savepvn(s, len);
 862                 incpush(p, TRUE);
 863                 sv_catpvn(sv, "-I", 2);
 864                 sv_catpvn(sv, p, len);
 865                 sv_catpvn(sv, " ", 1);
 866                 Safefree(p);
 867             }
 868             else
 869                 Perl_croak(aTHX_ "No directory specified for -I");
 870             break;
 871         case 'P':
 872             forbid_setid("-P");
 873             PL_preprocess = TRUE;
 874             s++;
 875             goto reswitch;
 876         case 'S':
 877             forbid_setid("-S");
 878             dosearch = TRUE;
 879             s++;
 880             goto reswitch;
 881         case 'V':
 882             if (!PL_preambleav)
 883                 PL_preambleav = newAV();
 884             av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
 885             if (*++s != ':')  {
 886                 PL_Sv = newSVpv("print myconfig();",0);
 887 #ifdef VMS
 888                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
 889 #else
 890                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 891 #endif
 892                 sv_catpv(PL_Sv,"\"  Compile-time options:");
 893 #  ifdef DEBUGGING
 894                 sv_catpv(PL_Sv," DEBUGGING");
 895 #  endif
 896 #  ifdef MULTIPLICITY
 897                 sv_catpv(PL_Sv," MULTIPLICITY");
 898 #  endif
 899 #  ifdef USE_THREADS
 900                 sv_catpv(PL_Sv," USE_THREADS");
 901 #  endif
 902 #  ifdef PERL_OBJECT
 903                 sv_catpv(PL_Sv," PERL_OBJECT");
 904 #  endif
 905 #  ifdef PERL_IMPLICIT_CONTEXT
 906                 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
 907 #  endif
 908 #  ifdef PERL_IMPLICIT_SYS
 909                 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
 910 #  endif
 911                 sv_catpv(PL_Sv,"\\n\",");
 912
 913 #if defined(LOCAL_PATCH_COUNT)
 914                 if (LOCAL_PATCH_COUNT > 0) {
 915                     int i;
 916                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
 917                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
 918                         if (PL_localpatches[i])
 919                             Perl_sv_catpvf(aTHX_ PL_Sv,"q\"  \t%s\n\",",PL_localpatches[i]);
 920                     }
 921                 }
 922 #endif
 923                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
 924 #ifdef __DATE__
 925 #  ifdef __TIME__
 926                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 927 #  else
 928                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
 929 #  endif
 930 #endif
 931                 sv_catpv(PL_Sv, "; \
 932 $\"=\"\\n    \"; \
 933 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
 934 print \"  \\%ENV:\\n    @env\\n\" if @env; \
 935 print \"  \\@INC:\\n    @INC\\n\";");
 936             }
 937             else {
 938                 PL_Sv = newSVpv("config_vars(qw(",0);
 939                 sv_catpv(PL_Sv, ++s);
 940                 sv_catpv(PL_Sv, "))");
 941                 s += strlen(s);
 942             }
 943             av_push(PL_preambleav, PL_Sv);
 944             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
 945             goto reswitch;
 946         case 'x':
 947             PL_doextract = TRUE;
 948             s++;
 949             if (*s)
 950                 cddir = s;
 951             break;
 952         case 0:
 953             break;
 954         case '-':
 955             if (!*++s || isSPACE(*s)) {
 956                 argc--,argv++;
 957                 goto switch_end;
 958             }
 959             /* catch use of gnu style long options */
 960             if (strEQ(s, "version")) {
 961                 s = "v";
 962                 goto reswitch;
 963             }
 964             if (strEQ(s, "help")) {
 965                 s = "h";
 966                 goto reswitch;
 967             }
 968             s--;
 969             /* FALL THROUGH */
 970         default:
 971             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
 972         }
 973     }
 974   switch_end:
 975
 976     if (
 977 #ifndef SECURE_INTERNAL_GETENV
 978         !PL_tainting &&
 979 #endif
 980         (s = PerlEnv_getenv("PERL5OPT")))
 981     {
 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             p = s;
1766             /* ignore trailing spaces (possibly followed by other switches) */
1767             do {
1768                 for (e = p; *e && !isSPACE(*e); e++) ;
1769                 p = e;
1770                 while (isSPACE(*p))
1771                     p++;
1772             } while (*p && *p != '-');
1773             e = savepvn(s, e-s);
1774             incpush(e, TRUE);
1775             Safefree(e);
1776             s = p;
1777             if (*s == '-')
1778                 s++;
1779         }
1780         else
1781             Perl_croak(aTHX_ "No directory specified for -I");
1782         return s;
1783     case 'l':
1784         PL_minus_l = TRUE;
1785         s++;
1786         if (PL_ors)
1787             Safefree(PL_ors);
1788         if (isDIGIT(*s)) {
1789             PL_ors = savepv("\n");
1790             PL_orslen = 1;
1791             *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1792             s += numlen;
1793         }
1794         else {
1795             dTHR;
1796             if (RsPARA(PL_nrs)) {
1797                 PL_ors = "\n\n";
1798                 PL_orslen = 2;
1799             }
1800             else
1801                 PL_ors = SvPV(PL_nrs, PL_orslen);
1802             PL_ors = savepvn(PL_ors, PL_orslen);
1803         }
1804         return s;
1805     case 'M':
1806         forbid_setid("-M");     /* XXX ? */
1807         /* FALL THROUGH */
1808     case 'm':
1809         forbid_setid("-m");     /* XXX ? */
1810         if (*++s) {
1811             char *start;
1812             SV *sv;
1813             char *use = "use ";
1814             /* -M-foo == 'no foo'       */
1815             if (*s == '-') { use = "no "; ++s; }
1816             sv = newSVpv(use,0);
1817             start = s;
1818             /* We allow -M'Module qw(Foo Bar)'  */
1819             while(isALNUM(*s) || *s==':') ++s;
1820             if (*s != '=') {
1821                 sv_catpv(sv, start);
1822                 if (*(start-1) == 'm') {
1823                     if (*s != '\0')
1824                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1825                     sv_catpv( sv, " ()");
1826                 }
1827             } else {
1828                 sv_catpvn(sv, start, s-start);
1829                 sv_catpv(sv, " split(/,/,q{");
1830                 sv_catpv(sv, ++s);
1831                 sv_catpv(sv,    "})");
1832             }
1833             s += strlen(s);
1834             if (!PL_preambleav)
1835                 PL_preambleav = newAV();
1836             av_push(PL_preambleav, sv);
1837         }
1838         else
1839             Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1840         return s;
1841     case 'n':
1842         PL_minus_n = TRUE;
1843         s++;
1844         return s;
1845     case 'p':
1846         PL_minus_p = TRUE;
1847         s++;
1848         return s;
1849     case 's':
1850         forbid_setid("-s");
1851         PL_doswitches = TRUE;
1852         s++;
1853         return s;
1854     case 'T':
1855         if (!PL_tainting)
1856             Perl_croak(aTHX_ "Too late for \"-T\" option");
1857         s++;
1858         return s;
1859     case 'u':
1860         PL_do_undump = TRUE;
1861         s++;
1862         return s;
1863     case 'U':
1864         PL_unsafe = TRUE;
1865         s++;
1866         return s;
1867     case 'v':
1868         printf("\nThis is perl, v%"UVuf".%"UVuf".%"UVuf" built for %s",
1869                (UV)PERL_REVISION, (UV)PERL_VERSION, (UV)PERL_SUBVERSION, ARCHNAME);
1870 #if defined(LOCAL_PATCH_COUNT)
1871         if (LOCAL_PATCH_COUNT > 0)
1872             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1873                 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1874 #endif
1875
1876         printf("\n\nCopyright 1987-1999, Larry Wall\n");
1877 #ifdef MSDOS
1878         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1879 #endif
1880 #ifdef DJGPP
1881         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1882         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1883 #endif
1884 #ifdef OS2
1885         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1886             "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1887 #endif
1888 #ifdef atarist
1889         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1890 #endif
1891 #ifdef __BEOS__
1892         printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1893 #endif
1894 #ifdef MPE
1895         printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1896 #endif
1897 #ifdef OEMVS
1898         printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1899 #endif
1900 #ifdef __VOS__
1901         printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1902 #endif
1903 #ifdef __OPEN_VM
1904         printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1905 #endif
1906 #ifdef POSIX_BC
1907         printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1908 #endif
1909 #ifdef __MINT__
1910         printf("MiNT port by Guido Flohr, 1997-1999\n");
1911 #endif
1912 #ifdef BINARY_BUILD_NOTICE
1913         BINARY_BUILD_NOTICE;
1914 #endif
1915         printf("\n\
1916 Perl may be copied only under the terms of either the Artistic License or the\n\
1917 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1918 Complete documentation for Perl, including FAQ lists, should be found on\n\
1919 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
1920 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1921         PerlProc_exit(0);
1922     case 'w':
1923         if (! (PL_dowarn & G_WARN_ALL_MASK))
1924             PL_dowarn |= G_WARN_ON;
1925         s++;
1926         return s;
1927     case 'W':
1928         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1929         PL_compiling.cop_warnings = WARN_ALL ;
1930         s++;
1931         return s;
1932     case 'X':
1933         PL_dowarn = G_WARN_ALL_OFF;
1934         PL_compiling.cop_warnings = WARN_NONE ;
1935         s++;
1936         return s;
1937     case '*':
1938     case ' ':
1939         if (s[1] == '-')        /* Additional switches on #! line. */
1940             return s+2;
1941         break;
1942     case '-':
1943     case 0:
1944 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1945     case '\r':
1946 #endif
1947     case '\n':
1948     case '\t':
1949         break;
1950 #ifdef ALTERNATE_SHEBANG
1951     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1952         break;
1953 #endif
1954     case 'P':
1955         if (PL_preprocess)
1956             return s+1;
1957         /* FALL THROUGH */
1958     default:
1959         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1960     }
1961     return Nullch;
1962 }
1963
1964 /* compliments of Tom Christiansen */
1965
1966 /* unexec() can be found in the Gnu emacs distribution */
1967 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1968
1969 void
1970 Perl_my_unexec(pTHX)
1971 {
1972 #ifdef UNEXEC
1973     SV*    prog;
1974     SV*    file;
1975     int    status = 1;
1976     extern int etext;
1977
1978     prog = newSVpv(BIN_EXP, 0);
1979     sv_catpv(prog, "/perl");
1980     file = newSVpv(PL_origfilename, 0);
1981     sv_catpv(file, ".perldump");
1982
1983     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1984     /* unexec prints msg to stderr in case of failure */
1985     PerlProc_exit(status);
1986 #else
1987 #  ifdef VMS
1988 #    include <lib$routines.h>
1989      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1990 #  else
1991     ABORT();            /* for use with undump */
1992 #  endif
1993 #endif
1994 }
1995
1996 /* initialize curinterp */
1997 STATIC void
1998 S_init_interp(pTHX)
1999 {
2000
2001 #ifdef PERL_OBJECT              /* XXX kludge */
2002 #define I_REINIT \
2003   STMT_START {                          \
2004     PL_chopset          = " \n-";       \
2005     PL_copline          = NOLINE;       \
2006     PL_curcop           = &PL_compiling;\
2007     PL_curcopdb         = NULL;         \
2008     PL_dbargs           = 0;            \
2009     PL_dumpindent       = 4;            \
2010     PL_laststatval      = -1;           \
2011     PL_laststype        = OP_STAT;      \
2012     PL_maxscream        = -1;           \
2013     PL_maxsysfd         = MAXSYSFD;     \
2014     PL_statname         = Nullsv;       \
2015     PL_tmps_floor       = -1;           \
2016     PL_tmps_ix          = -1;           \
2017     PL_op_mask          = NULL;         \
2018     PL_laststatval      = -1;           \
2019     PL_laststype        = OP_STAT;      \
2020     PL_mess_sv          = Nullsv;       \
2021     PL_splitstr         = " ";          \
2022     PL_generation       = 100;          \
2023     PL_exitlist         = NULL;         \
2024     PL_exitlistlen      = 0;            \
2025     PL_regindent        = 0;            \
2026     PL_in_clean_objs    = FALSE;        \
2027     PL_in_clean_all     = FALSE;        \
2028     PL_profiledata      = NULL;         \
2029     PL_rsfp             = Nullfp;       \
2030     PL_rsfp_filters     = Nullav;       \
2031     PL_dirty            = FALSE;        \
2032   } STMT_END
2033     I_REINIT;
2034 #else
2035 #  ifdef MULTIPLICITY
2036 #    define PERLVAR(var,type)
2037 #    define PERLVARA(var,n,type)
2038 #    if defined(PERL_IMPLICIT_CONTEXT)
2039 #      if defined(USE_THREADS)
2040 #        define PERLVARI(var,type,init)         PERL_GET_INTERP->var = init;
2041 #        define PERLVARIC(var,type,init)        PERL_GET_INTERP->var = init;
2042 #      else /* !USE_THREADS */
2043 #        define PERLVARI(var,type,init)         aTHX->var = init;
2044 #        define PERLVARIC(var,type,init)        aTHX->var = init;
2045 #      endif /* USE_THREADS */
2046 #    else
2047 #      define PERLVARI(var,type,init)   PERL_GET_INTERP->var = init;
2048 #      define PERLVARIC(var,type,init)  PERL_GET_INTERP->var = init;
2049 #    endif
2050 #    include "intrpvar.h"
2051 #    ifndef USE_THREADS
2052 #      include "thrdvar.h"
2053 #    endif
2054 #    undef PERLVAR
2055 #    undef PERLVARA
2056 #    undef PERLVARI
2057 #    undef PERLVARIC
2058 #  else
2059 #    define PERLVAR(var,type)
2060 #    define PERLVARA(var,n,type)
2061 #    define PERLVARI(var,type,init)     PL_##var = init;
2062 #    define PERLVARIC(var,type,init)    PL_##var = init;
2063 #    include "intrpvar.h"
2064 #    ifndef USE_THREADS
2065 #      include "thrdvar.h"
2066 #    endif
2067 #    undef PERLVAR
2068 #    undef PERLVARA
2069 #    undef PERLVARI
2070 #    undef PERLVARIC
2071 #  endif
2072 #endif
2073
2074 }
2075
2076 STATIC void
2077 S_init_main_stash(pTHX)
2078 {
2079     dTHR;
2080     GV *gv;
2081
2082     /* Note that strtab is a rather special HV.  Assumptions are made
2083        about not iterating on it, and not adding tie magic to it.
2084        It is properly deallocated in perl_destruct() */
2085     PL_strtab = newHV();
2086 #ifdef USE_THREADS
2087     MUTEX_INIT(&PL_strtab_mutex);
2088 #endif
2089     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
2090     hv_ksplit(PL_strtab, 512);
2091
2092     PL_curstash = PL_defstash = newHV();
2093     PL_curstname = newSVpvn("main",4);
2094     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2095     SvREFCNT_dec(GvHV(gv));
2096     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2097     SvREADONLY_on(gv);
2098     HvNAME(PL_defstash) = savepv("main");
2099     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2100     GvMULTI_on(PL_incgv);
2101     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2102     GvMULTI_on(PL_hintgv);
2103     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2104     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2105     GvMULTI_on(PL_errgv);
2106     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2107     GvMULTI_on(PL_replgv);
2108     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
2109     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
2110     sv_setpvn(ERRSV, "", 0);
2111     PL_curstash = PL_defstash;
2112     CopSTASH_set(&PL_compiling, PL_defstash);
2113     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2114     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2115     /* We must init $/ before switches are processed. */
2116     sv_setpvn(get_sv("/", TRUE), "\n", 1);
2117 }
2118
2119 STATIC void
2120 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2121 {
2122     dTHR;
2123     register char *s;
2124
2125     *fdscript = -1;
2126
2127     if (PL_e_script) {
2128         PL_origfilename = savepv("-e");
2129     }
2130     else {
2131         /* if find_script() returns, it returns a malloc()-ed value */
2132         PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2133
2134         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2135             char *s = scriptname + 8;
2136             *fdscript = atoi(s);
2137             while (isDIGIT(*s))
2138                 s++;
2139             if (*s) {
2140                 scriptname = savepv(s + 1);
2141                 Safefree(PL_origfilename);
2142                 PL_origfilename = scriptname;
2143             }
2144         }
2145     }
2146
2147     CopFILE_set(PL_curcop, PL_origfilename);
2148     if (strEQ(PL_origfilename,"-"))
2149         scriptname = "";
2150     if (*fdscript >= 0) {
2151         PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2152 #if defined(HAS_FCNTL) && defined(F_SETFD)
2153         if (PL_rsfp)
2154             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2155 #endif
2156     }
2157     else if (PL_preprocess) {
2158         char *cpp_cfg = CPPSTDIN;
2159         SV *cpp = newSVpvn("",0);
2160         SV *cmd = NEWSV(0,0);
2161
2162         if (strEQ(cpp_cfg, "cppstdin"))
2163             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2164         sv_catpv(cpp, cpp_cfg);
2165
2166         sv_catpvn(sv, "-I", 2);
2167         sv_catpv(sv,PRIVLIB_EXP);
2168
2169 #ifdef MSDOS
2170         Perl_sv_setpvf(aTHX_ cmd, "\
2171 sed %s -e \"/^[^#]/b\" \
2172  -e \"/^#[      ]*include[      ]/b\" \
2173  -e \"/^#[      ]*define[       ]/b\" \
2174  -e \"/^#[      ]*if[   ]/b\" \
2175  -e \"/^#[      ]*ifdef[        ]/b\" \
2176  -e \"/^#[      ]*ifndef[       ]/b\" \
2177  -e \"/^#[      ]*else/b\" \
2178  -e \"/^#[      ]*elif[         ]/b\" \
2179  -e \"/^#[      ]*undef[        ]/b\" \
2180  -e \"/^#[      ]*endif/b\" \
2181  -e \"s/^#.*//\" \
2182  %s | %_ -C %_ %s",
2183           (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2184 #else
2185 #  ifdef __OPEN_VM
2186         Perl_sv_setpvf(aTHX_ cmd, "\
2187 %s %s -e '/^[^#]/b' \
2188  -e '/^#[       ]*include[      ]/b' \
2189  -e '/^#[       ]*define[       ]/b' \
2190  -e '/^#[       ]*if[   ]/b' \
2191  -e '/^#[       ]*ifdef[        ]/b' \
2192  -e '/^#[       ]*ifndef[       ]/b' \
2193  -e '/^#[       ]*else/b' \
2194  -e '/^#[       ]*elif[         ]/b' \
2195  -e '/^#[       ]*undef[        ]/b' \
2196  -e '/^#[       ]*endif/b' \
2197  -e 's/^[       ]*#.*//' \
2198  %s | %_ %_ %s",
2199 #  else
2200         Perl_sv_setpvf(aTHX_ cmd, "\
2201 %s %s -e '/^[^#]/b' \
2202  -e '/^#[       ]*include[      ]/b' \
2203  -e '/^#[       ]*define[       ]/b' \
2204  -e '/^#[       ]*if[   ]/b' \
2205  -e '/^#[       ]*ifdef[        ]/b' \
2206  -e '/^#[       ]*ifndef[       ]/b' \
2207  -e '/^#[       ]*else/b' \
2208  -e '/^#[       ]*elif[         ]/b' \
2209  -e '/^#[       ]*undef[        ]/b' \
2210  -e '/^#[       ]*endif/b' \
2211  -e 's/^[       ]*#.*//' \
2212  %s | %_ -C %_ %s",
2213 #  endif
2214 #ifdef LOC_SED
2215           LOC_SED,
2216 #else
2217           "sed",
2218 #endif
2219           (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2220 #endif
2221           scriptname, cpp, sv, CPPMINUS);
2222         PL_doextract = FALSE;
2223 #ifdef IAMSUID                          /* actually, this is caught earlier */
2224         if (PL_euid != PL_uid && !PL_euid) {    /* if running suidperl */
2225 #ifdef HAS_SETEUID
2226             (void)seteuid(PL_uid);              /* musn't stay setuid root */
2227 #else
2228 #ifdef HAS_SETREUID
2229             (void)setreuid((Uid_t)-1, PL_uid);
2230 #else
2231 #ifdef HAS_SETRESUID
2232             (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2233 #else
2234             PerlProc_setuid(PL_uid);
2235 #endif
2236 #endif
2237 #endif
2238             if (PerlProc_geteuid() != PL_uid)
2239                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2240         }
2241 #endif /* IAMSUID */
2242         PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2243         SvREFCNT_dec(cmd);
2244         SvREFCNT_dec(cpp);
2245     }
2246     else if (!*scriptname) {
2247         forbid_setid("program input from stdin");
2248         PL_rsfp = PerlIO_stdin();
2249     }
2250     else {
2251         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2252 #if defined(HAS_FCNTL) && defined(F_SETFD)
2253         if (PL_rsfp)
2254             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
2255 #endif
2256     }
2257     if (!PL_rsfp) {
2258 #ifdef DOSUID
2259 #ifndef IAMSUID         /* in case script is not readable before setuid */
2260         if (PL_euid &&
2261             PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2262             PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2263         {
2264             /* try again */
2265             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2266                                      (int)PERL_REVISION, (int)PERL_VERSION,
2267                                      (int)PERL_SUBVERSION), PL_origargv);
2268             Perl_croak(aTHX_ "Can't do setuid\n");
2269         }
2270 #endif
2271 #endif
2272         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2273                    CopFILE(PL_curcop), Strerror(errno));
2274     }
2275 }
2276
2277 /* Mention
2278  * I_SYSSTATVFS HAS_FSTATVFS
2279  * I_SYSMOUNT
2280  * I_STATFS     HAS_FSTATFS
2281  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
2282  * here so that metaconfig picks them up. */
2283
2284 #ifdef IAMSUID
2285 STATIC int
2286 S_fd_on_nosuid_fs(pTHX_ int fd)
2287 {
2288     int check_okay = 0; /* able to do all the required sys/libcalls */
2289     int on_nosuid  = 0; /* the fd is on a nosuid fs */
2290 /*
2291  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2292  * fstatvfs() is UNIX98.
2293  * fstatfs() is 4.3 BSD.
2294  * ustat()+getmnt() is pre-4.3 BSD.
2295  * getmntent() is O(number-of-mounted-filesystems) and can hang on
2296  * an irrelevant filesystem while trying to reach the right one.
2297  */
2298
2299 #   ifdef HAS_FSTATVFS
2300     struct statvfs stfs;
2301     check_okay = fstatvfs(fd, &stfs) == 0;
2302     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
2303 #   else
2304 #       ifdef PERL_MOUNT_NOSUID
2305 #           if defined(HAS_FSTATFS) && \
2306                defined(HAS_STRUCT_STATFS) && \
2307                defined(HAS_STRUCT_STATFS_F_FLAGS)
2308     struct statfs  stfs;
2309     check_okay = fstatfs(fd, &stfs)  == 0;
2310     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2311 #           else
2312 #               if defined(HAS_FSTAT) && \
2313                    defined(HAS_USTAT) && \
2314                    defined(HAS_GETMNT) && \
2315                    defined(HAS_STRUCT_FS_DATA) && \
2316                    defined(NOSTAT_ONE)
2317     struct stat fdst;
2318     if (fstat(fd, &fdst) == 0) {
2319         struct ustat us;
2320         if (ustat(fdst.st_dev, &us) == 0) {
2321             struct fs_data fsd;
2322             /* NOSTAT_ONE here because we're not examining fields which
2323              * vary between that case and STAT_ONE. */
2324             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2325                 size_t cmplen = sizeof(us.f_fname);
2326                 if (sizeof(fsd.fd_req.path) < cmplen)
2327                     cmplen = sizeof(fsd.fd_req.path);
2328                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2329                     fdst.st_dev == fsd.fd_req.dev) {
2330                         check_okay = 1;
2331                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2332                     }
2333                 }
2334             }
2335         }
2336     }
2337 #               endif /* fstat+ustat+getmnt */
2338 #           endif /* fstatfs */
2339 #       else
2340 #           if defined(HAS_GETMNTENT) && \
2341                defined(HAS_HASMNTOPT) && \
2342                defined(MNTOPT_NOSUID)
2343     FILE                *mtab = fopen("/etc/mtab", "r");
2344     struct mntent       *entry;
2345     struct stat         stb, fsb;
2346
2347     if (mtab && (fstat(fd, &stb) == 0)) {
2348         while (entry = getmntent(mtab)) {
2349             if (stat(entry->mnt_dir, &fsb) == 0
2350                 && fsb.st_dev == stb.st_dev)
2351             {
2352                 /* found the filesystem */
2353                 check_okay = 1;
2354                 if (hasmntopt(entry, MNTOPT_NOSUID))
2355                     on_nosuid = 1;
2356                 break;
2357             } /* A single fs may well fail its stat(). */
2358         }
2359     }
2360     if (mtab)
2361         fclose(mtab);
2362 #           endif /* getmntent+hasmntopt */
2363 #       endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2364 #   endif /* statvfs */
2365
2366     if (!check_okay)
2367         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2368     return on_nosuid;
2369 }
2370 #endif /* IAMSUID */
2371
2372 STATIC void
2373 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2374 {
2375     int which;
2376
2377     /* do we need to emulate setuid on scripts? */
2378
2379     /* This code is for those BSD systems that have setuid #! scripts disabled
2380      * in the kernel because of a security problem.  Merely defining DOSUID
2381      * in perl will not fix that problem, but if you have disabled setuid
2382      * scripts in the kernel, this will attempt to emulate setuid and setgid
2383      * on scripts that have those now-otherwise-useless bits set.  The setuid
2384      * root version must be called suidperl or sperlN.NNN.  If regular perl
2385      * discovers that it has opened a setuid script, it calls suidperl with
2386      * the same argv that it had.  If suidperl finds that the script it has
2387      * just opened is NOT setuid root, it sets the effective uid back to the
2388      * uid.  We don't just make perl setuid root because that loses the
2389      * effective uid we had before invoking perl, if it was different from the
2390      * uid.
2391      *
2392      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2393      * be defined in suidperl only.  suidperl must be setuid root.  The
2394      * Configure script will set this up for you if you want it.
2395      */
2396
2397 #ifdef DOSUID
2398     dTHR;
2399     char *s, *s2;
2400
2401     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
2402         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2403     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2404         I32 len;
2405         STRLEN n_a;
2406
2407 #ifdef IAMSUID
2408 #ifndef HAS_SETREUID
2409         /* On this access check to make sure the directories are readable,
2410          * there is actually a small window that the user could use to make
2411          * filename point to an accessible directory.  So there is a faint
2412          * chance that someone could execute a setuid script down in a
2413          * non-accessible directory.  I don't know what to do about that.
2414          * But I don't think it's too important.  The manual lies when
2415          * it says access() is useful in setuid programs.
2416          */
2417         if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2418             Perl_croak(aTHX_ "Permission denied");
2419 #else
2420         /* If we can swap euid and uid, then we can determine access rights
2421          * with a simple stat of the file, and then compare device and
2422          * inode to make sure we did stat() on the same file we opened.
2423          * Then we just have to make sure he or she can execute it.
2424          */
2425         {
2426             struct stat tmpstatbuf;
2427
2428             if (
2429 #ifdef HAS_SETREUID
2430                 setreuid(PL_euid,PL_uid) < 0
2431 #else
2432 # if HAS_SETRESUID
2433                 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2434 # endif
2435 #endif
2436                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2437                 Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
2438             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2439                 Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
2440 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2441             if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2442                 Perl_croak(aTHX_ "Permission denied");
2443 #endif
2444             if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2445                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2446                 (void)PerlIO_close(PL_rsfp);
2447                 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
2448                     PerlIO_printf(PL_rsfp,
2449 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2450 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2451                         PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2452                         (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2453                         CopFILE(PL_curcop),
2454                         PL_statbuf.st_uid, PL_statbuf.st_gid);
2455                     (void)PerlProc_pclose(PL_rsfp);
2456                 }
2457                 Perl_croak(aTHX_ "Permission denied\n");
2458             }
2459             if (
2460 #ifdef HAS_SETREUID
2461               setreuid(PL_uid,PL_euid) < 0
2462 #else
2463 # if defined(HAS_SETRESUID)
2464               setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2465 # endif
2466 #endif
2467               || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2468                 Perl_croak(aTHX_ "Can't reswap uid and euid");
2469             if (!cando(S_IXUSR,FALSE,&PL_statbuf))              /* can real uid exec? */
2470                 Perl_croak(aTHX_ "Permission denied\n");
2471         }
2472 #endif /* HAS_SETREUID */
2473 #endif /* IAMSUID */
2474
2475         if (!S_ISREG(PL_statbuf.st_mode))
2476             Perl_croak(aTHX_ "Permission denied");
2477         if (PL_statbuf.st_mode & S_IWOTH)
2478             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2479         PL_doswitches = FALSE;          /* -s is insecure in suid */
2480         CopLINE_inc(PL_curcop);
2481         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2482           strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2483             Perl_croak(aTHX_ "No #! line");
2484         s = SvPV(PL_linestr,n_a)+2;
2485         if (*s == ' ') s++;
2486         while (!isSPACE(*s)) s++;
2487         for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
2488                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2489         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2490             Perl_croak(aTHX_ "Not a perl script");
2491         while (*s == ' ' || *s == '\t') s++;
2492         /*
2493          * #! arg must be what we saw above.  They can invoke it by
2494          * mentioning suidperl explicitly, but they may not add any strange
2495          * arguments beyond what #! says if they do invoke suidperl that way.
2496          */
2497         len = strlen(validarg);
2498         if (strEQ(validarg," PHOOEY ") ||
2499             strnNE(s,validarg,len) || !isSPACE(s[len]))
2500             Perl_croak(aTHX_ "Args must match #! line");
2501
2502 #ifndef IAMSUID
2503         if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2504             PL_euid == PL_statbuf.st_uid)
2505             if (!PL_do_undump)
2506                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2507 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2508 #endif /* IAMSUID */
2509
2510         if (PL_euid) {  /* oops, we're not the setuid root perl */
2511             (void)PerlIO_close(PL_rsfp);
2512 #ifndef IAMSUID
2513             /* try again */
2514             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2515                                      (int)PERL_REVISION, (int)PERL_VERSION,
2516                                      (int)PERL_SUBVERSION), PL_origargv);
2517 #endif
2518             Perl_croak(aTHX_ "Can't do setuid\n");
2519         }
2520
2521         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2522 #ifdef HAS_SETEGID
2523             (void)setegid(PL_statbuf.st_gid);
2524 #else
2525 #ifdef HAS_SETREGID
2526            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2527 #else
2528 #ifdef HAS_SETRESGID
2529            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2530 #else
2531             PerlProc_setgid(PL_statbuf.st_gid);
2532 #endif
2533 #endif
2534 #endif
2535             if (PerlProc_getegid() != PL_statbuf.st_gid)
2536                 Perl_croak(aTHX_ "Can't do setegid!\n");
2537         }
2538         if (PL_statbuf.st_mode & S_ISUID) {
2539             if (PL_statbuf.st_uid != PL_euid)
2540 #ifdef HAS_SETEUID
2541                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
2542 #else
2543 #ifdef HAS_SETREUID
2544                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2545 #else
2546 #ifdef HAS_SETRESUID
2547                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2548 #else
2549                 PerlProc_setuid(PL_statbuf.st_uid);
2550 #endif
2551 #endif
2552 #endif
2553             if (PerlProc_geteuid() != PL_statbuf.st_uid)
2554                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2555         }
2556         else if (PL_uid) {                      /* oops, mustn't run as root */
2557 #ifdef HAS_SETEUID
2558           (void)seteuid((Uid_t)PL_uid);
2559 #else
2560 #ifdef HAS_SETREUID
2561           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2562 #else
2563 #ifdef HAS_SETRESUID
2564           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2565 #else
2566           PerlProc_setuid((Uid_t)PL_uid);
2567 #endif
2568 #endif
2569 #endif
2570             if (PerlProc_geteuid() != PL_uid)
2571                 Perl_croak(aTHX_ "Can't do seteuid!\n");
2572         }
2573         init_ids();
2574         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2575             Perl_croak(aTHX_ "Permission denied\n");    /* they can't do this */
2576     }
2577 #ifdef IAMSUID
2578     else if (PL_preprocess)
2579         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2580     else if (fdscript >= 0)
2581         Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2582     else
2583         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2584
2585     /* We absolutely must clear out any saved ids here, so we */
2586     /* exec the real perl, substituting fd script for scriptname. */
2587     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2588     PerlIO_rewind(PL_rsfp);
2589     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2590     for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2591     if (!PL_origargv[which])
2592         Perl_croak(aTHX_ "Permission denied");
2593     PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2594                                   PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2595 #if defined(HAS_FCNTL) && defined(F_SETFD)
2596     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
2597 #endif
2598     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2599                              (int)PERL_REVISION, (int)PERL_VERSION,
2600                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
2601     Perl_croak(aTHX_ "Can't do setuid\n");
2602 #endif /* IAMSUID */
2603 #else /* !DOSUID */
2604     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
2605 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2606         dTHR;
2607         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
2608         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2609             ||
2610             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2611            )
2612             if (!PL_do_undump)
2613                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2614 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2615 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2616         /* not set-id, must be wrapped */
2617     }
2618 #endif /* DOSUID */
2619 }
2620
2621 STATIC void
2622 S_find_beginning(pTHX)
2623 {
2624     register char *s, *s2;
2625
2626     /* skip forward in input to the real script? */
2627
2628     forbid_setid("-x");
2629     while (PL_doextract) {
2630         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2631             Perl_croak(aTHX_ "No Perl script found in input\n");
2632         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2633             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
2634             PL_doextract = FALSE;
2635             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2636             s2 = s;
2637             while (*s == ' ' || *s == '\t') s++;
2638             if (*s++ == '-') {
2639                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2640                 if (strnEQ(s2-4,"perl",4))
2641                     /*SUPPRESS 530*/
2642                     while (s = moreswitches(s)) ;
2643             }
2644         }
2645     }
2646 }
2647
2648
2649 STATIC void
2650 S_init_ids(pTHX)
2651 {
2652     PL_uid = PerlProc_getuid();
2653     PL_euid = PerlProc_geteuid();
2654     PL_gid = PerlProc_getgid();
2655     PL_egid = PerlProc_getegid();
2656 #ifdef VMS
2657     PL_uid |= PL_gid << 16;
2658     PL_euid |= PL_egid << 16;
2659 #endif
2660     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2661 }
2662
2663 STATIC void
2664 S_forbid_setid(pTHX_ char *s)
2665 {
2666     if (PL_euid != PL_uid)
2667         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2668     if (PL_egid != PL_gid)
2669         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2670 }
2671
2672 void
2673 Perl_init_debugger(pTHX)
2674 {
2675     dTHR;
2676     HV *ostash = PL_curstash;
2677
2678     PL_curstash = PL_debstash;
2679     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2680     AvREAL_off(PL_dbargs);
2681     PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2682     PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2683     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2684     sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2685     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2686     sv_setiv(PL_DBsingle, 0);
2687     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2688     sv_setiv(PL_DBtrace, 0);
2689     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2690     sv_setiv(PL_DBsignal, 0);
2691     PL_curstash = ostash;
2692 }
2693
2694 #ifndef STRESS_REALLOC
2695 #define REASONABLE(size) (size)
2696 #else
2697 #define REASONABLE(size) (1) /* unreasonable */
2698 #endif
2699
2700 void
2701 Perl_init_stacks(pTHX)
2702 {
2703     /* start with 128-item stack and 8K cxstack */
2704     PL_curstackinfo = new_stackinfo(REASONABLE(128),
2705                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2706     PL_curstackinfo->si_type = PERLSI_MAIN;
2707     PL_curstack = PL_curstackinfo->si_stack;
2708     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
2709
2710     PL_stack_base = AvARRAY(PL_curstack);
2711     PL_stack_sp = PL_stack_base;
2712     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2713
2714     New(50,PL_tmps_stack,REASONABLE(128),SV*);
2715     PL_tmps_floor = -1;
2716     PL_tmps_ix = -1;
2717     PL_tmps_max = REASONABLE(128);
2718
2719     New(54,PL_markstack,REASONABLE(32),I32);
2720     PL_markstack_ptr = PL_markstack;
2721     PL_markstack_max = PL_markstack + REASONABLE(32);
2722
2723     SET_MARK_OFFSET;
2724
2725     New(54,PL_scopestack,REASONABLE(32),I32);
2726     PL_scopestack_ix = 0;
2727     PL_scopestack_max = REASONABLE(32);
2728
2729     New(54,PL_savestack,REASONABLE(128),ANY);
2730     PL_savestack_ix = 0;
2731     PL_savestack_max = REASONABLE(128);
2732
2733     New(54,PL_retstack,REASONABLE(16),OP*);
2734     PL_retstack_ix = 0;
2735     PL_retstack_max = REASONABLE(16);
2736 }
2737
2738 #undef REASONABLE
2739
2740 STATIC void
2741 S_nuke_stacks(pTHX)
2742 {
2743     dTHR;
2744     while (PL_curstackinfo->si_next)
2745         PL_curstackinfo = PL_curstackinfo->si_next;
2746     while (PL_curstackinfo) {
2747         PERL_SI *p = PL_curstackinfo->si_prev;
2748         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2749         Safefree(PL_curstackinfo->si_cxstack);
2750         Safefree(PL_curstackinfo);
2751         PL_curstackinfo = p;
2752     }
2753     Safefree(PL_tmps_stack);
2754     Safefree(PL_markstack);
2755     Safefree(PL_scopestack);
2756     Safefree(PL_savestack);
2757     Safefree(PL_retstack);
2758 }
2759
2760 #ifndef PERL_OBJECT
2761 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2762 #endif
2763
2764 STATIC void
2765 S_init_lexer(pTHX)
2766 {
2767 #ifdef PERL_OBJECT
2768         PerlIO *tmpfp;
2769 #endif
2770     tmpfp = PL_rsfp;
2771     PL_rsfp = Nullfp;
2772     lex_start(PL_linestr);
2773     PL_rsfp = tmpfp;
2774     PL_subname = newSVpvn("main",4);
2775 }
2776
2777 STATIC void
2778 S_init_predump_symbols(pTHX)
2779 {
2780     dTHR;
2781     GV *tmpgv;
2782     GV *othergv;
2783     IO *io;
2784
2785     sv_setpvn(get_sv("\"", TRUE), " ", 1);
2786     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2787     GvMULTI_on(PL_stdingv);
2788     io = GvIOp(PL_stdingv);
2789     IoIFP(io) = PerlIO_stdin();
2790     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2791     GvMULTI_on(tmpgv);
2792     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2793
2794     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2795     GvMULTI_on(tmpgv);
2796     io = GvIOp(tmpgv);
2797     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2798     setdefout(tmpgv);
2799     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2800     GvMULTI_on(tmpgv);
2801     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2802
2803     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2804     GvMULTI_on(PL_stderrgv);
2805     io = GvIOp(PL_stderrgv);
2806     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2807     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2808     GvMULTI_on(tmpgv);
2809     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2810
2811     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
2812
2813     if (!PL_osname)
2814         PL_osname = savepv(OSNAME);
2815 }
2816
2817 STATIC void
2818 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2819 {
2820     dTHR;
2821     char *s;
2822     SV *sv;
2823     GV* tmpgv;
2824
2825     argc--,argv++;      /* skip name of script */
2826     if (PL_doswitches) {
2827         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2828             if (!argv[0][1])
2829                 break;
2830             if (argv[0][1] == '-' && !argv[0][2]) {
2831                 argc--,argv++;
2832                 break;
2833             }
2834             if (s = strchr(argv[0], '=')) {
2835                 *s++ = '\0';
2836                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2837             }
2838             else
2839                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2840         }
2841     }
2842     PL_toptarget = NEWSV(0,0);
2843     sv_upgrade(PL_toptarget, SVt_PVFM);
2844     sv_setpvn(PL_toptarget, "", 0);
2845     PL_bodytarget = NEWSV(0,0);
2846     sv_upgrade(PL_bodytarget, SVt_PVFM);
2847     sv_setpvn(PL_bodytarget, "", 0);
2848     PL_formtarget = PL_bodytarget;
2849
2850     TAINT;
2851     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2852         sv_setpv(GvSV(tmpgv),PL_origfilename);
2853         magicname("0", "0", 1);
2854     }
2855     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2856 #ifdef OS2
2857         sv_setpv(GvSV(tmpgv), os2_execname());
2858 #else
2859         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2860 #endif
2861     if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2862         GvMULTI_on(PL_argvgv);
2863         (void)gv_AVadd(PL_argvgv);
2864         av_clear(GvAVn(PL_argvgv));
2865         for (; argc > 0; argc--,argv++) {
2866             av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2867         }
2868     }
2869     if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2870         HV *hv;
2871         GvMULTI_on(PL_envgv);
2872         hv = GvHVn(PL_envgv);
2873         hv_magic(hv, PL_envgv, 'E');
2874 #if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
2875         /* Note that if the supplied env parameter is actually a copy
2876            of the global environ then it may now point to free'd memory
2877            if the environment has been modified since. To avoid this
2878            problem we treat env==NULL as meaning 'use the default'
2879         */
2880         if (!env)
2881             env = environ;
2882         if (env != environ)
2883             environ[0] = Nullch;
2884         for (; *env; env++) {
2885             if (!(s = strchr(*env,'=')))
2886                 continue;
2887             *s++ = '\0';
2888 #if defined(MSDOS)
2889             (void)strupr(*env);
2890 #endif
2891             sv = newSVpv(s--,0);
2892             (void)hv_store(hv, *env, s - *env, sv, 0);
2893             *s = '=';
2894 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2895             /* Sins of the RTL. See note in my_setenv(). */
2896             (void)PerlEnv_putenv(savepv(*env));
2897 #endif
2898         }
2899 #endif
2900 #ifdef DYNAMIC_ENV_FETCH
2901         HvNAME(hv) = savepv(ENV_HV_NAME);
2902 #endif
2903     }
2904     TAINT_NOT;
2905     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2906         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
2907 }
2908
2909 STATIC void
2910 S_init_perllib(pTHX)
2911 {
2912     char *s;
2913     if (!PL_tainting) {
2914 #ifndef VMS
2915         s = PerlEnv_getenv("PERL5LIB");
2916         if (s)
2917             incpush(s, TRUE);
2918         else
2919             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2920 #else /* VMS */
2921         /* Treat PERL5?LIB as a possible search list logical name -- the
2922          * "natural" VMS idiom for a Unix path string.  We allow each
2923          * element to be a set of |-separated directories for compatibility.
2924          */
2925         char buf[256];
2926         int idx = 0;
2927         if (my_trnlnm("PERL5LIB",buf,0))
2928             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2929         else
2930             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2931 #endif /* VMS */
2932     }
2933
2934 /* Use the ~-expanded versions of APPLLIB (undocumented),
2935     ARCHLIB PRIVLIB SITEARCH and SITELIB
2936 */
2937 #ifdef APPLLIB_EXP
2938     incpush(APPLLIB_EXP, TRUE);
2939 #endif
2940
2941 #ifdef ARCHLIB_EXP
2942     incpush(ARCHLIB_EXP, FALSE);
2943 #endif
2944 #ifndef PRIVLIB_EXP
2945 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2946 #endif
2947 #if defined(WIN32)
2948     incpush(PRIVLIB_EXP, TRUE);
2949 #else
2950     incpush(PRIVLIB_EXP, FALSE);
2951 #endif
2952
2953 #ifdef SITEARCH_EXP
2954     incpush(SITEARCH_EXP, FALSE);
2955 #endif
2956 #ifdef SITELIB_EXP
2957 #if defined(WIN32)
2958     incpush(SITELIB_EXP, TRUE);
2959 #else
2960     incpush(SITELIB_EXP, FALSE);
2961 #endif
2962 #endif
2963 #if defined(PERL_VENDORLIB_EXP)
2964 #if defined(WIN32)
2965     incpush(PERL_VENDORLIB_EXP, TRUE);
2966 #else
2967     incpush(PERL_VENDORLIB_EXP, FALSE);
2968 #endif
2969 #endif
2970     if (!PL_tainting)
2971         incpush(".", FALSE);
2972 }
2973
2974 #if defined(DOSISH)
2975 #    define PERLLIB_SEP ';'
2976 #else
2977 #  if defined(VMS)
2978 #    define PERLLIB_SEP '|'
2979 #  else
2980 #    define PERLLIB_SEP ':'
2981 #  endif
2982 #endif
2983 #ifndef PERLLIB_MANGLE
2984 #  define PERLLIB_MANGLE(s,n) (s)
2985 #endif
2986
2987 STATIC void
2988 S_incpush(pTHX_ char *p, int addsubdirs)
2989 {
2990     SV *subdir = Nullsv;
2991
2992     if (!p)
2993         return;
2994
2995     if (addsubdirs) {
2996         subdir = sv_newmortal();
2997     }
2998
2999     /* Break at all separators */
3000     while (p && *p) {
3001         SV *libdir = NEWSV(55,0);
3002         char *s;
3003
3004         /* skip any consecutive separators */
3005         while ( *p == PERLLIB_SEP ) {
3006             /* Uncomment the next line for PATH semantics */
3007             /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3008             p++;
3009         }
3010
3011         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3012             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3013                       (STRLEN)(s - p));
3014             p = s + 1;
3015         }
3016         else {
3017             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3018             p = Nullch; /* break out */
3019         }
3020
3021         /*
3022          * BEFORE pushing libdir onto @INC we may first push version- and
3023          * archname-specific sub-directories.
3024          */
3025         if (addsubdirs) {
3026             struct stat tmpstatbuf;
3027 #ifdef VMS
3028             char *unix;
3029             STRLEN len;
3030
3031             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3032                 len = strlen(unix);
3033                 while (unix[len-1] == '/') len--;  /* Cosmetic */
3034                 sv_usepvn(libdir,unix,len);
3035             }
3036             else
3037                 PerlIO_printf(Perl_error_log,
3038                               "Failed to unixify @INC element \"%s\"\n",
3039                               SvPV(libdir,len));
3040 #endif
3041             /* .../archname/version if -d .../archname/version/auto */
3042             Perl_sv_setpvf(aTHX_ subdir, "%_/%s/"PERL_FS_VER_FMT"/auto", libdir,
3043                            ARCHNAME, (int)PERL_REVISION,
3044                            (int)PERL_VERSION, (int)PERL_SUBVERSION);
3045             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3046                   S_ISDIR(tmpstatbuf.st_mode))
3047                 av_push(GvAVn(PL_incgv),
3048                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3049
3050             /* .../archname if -d .../archname/auto */
3051             Perl_sv_setpvf(aTHX_ subdir, "%_/%s/auto", libdir, ARCHNAME);
3052             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3053                   S_ISDIR(tmpstatbuf.st_mode))
3054                 av_push(GvAVn(PL_incgv),
3055                         newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3056         }
3057
3058         /* finally push this lib directory on the end of @INC */
3059         av_push(GvAVn(PL_incgv), libdir);
3060     }
3061 }
3062
3063 #ifdef USE_THREADS
3064 STATIC struct perl_thread *
3065 S_init_main_thread(pTHX)
3066 {
3067 #if !defined(PERL_IMPLICIT_CONTEXT)
3068     struct perl_thread *thr;
3069 #endif
3070     XPV *xpv;
3071
3072     Newz(53, thr, 1, struct perl_thread);
3073     PL_curcop = &PL_compiling;
3074     thr->interp = PERL_GET_INTERP;
3075     thr->cvcache = newHV();
3076     thr->threadsv = newAV();
3077     /* thr->threadsvp is set when find_threadsv is called */
3078     thr->specific = newAV();
3079     thr->flags = THRf_R_JOINABLE;
3080     MUTEX_INIT(&thr->mutex);
3081     /* Handcraft thrsv similarly to mess_sv */
3082     New(53, PL_thrsv, 1, SV);
3083     Newz(53, xpv, 1, XPV);
3084     SvFLAGS(PL_thrsv) = SVt_PV;
3085     SvANY(PL_thrsv) = (void*)xpv;
3086     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
3087     SvPVX(PL_thrsv) = (char*)thr;
3088     SvCUR_set(PL_thrsv, sizeof(thr));
3089     SvLEN_set(PL_thrsv, sizeof(thr));
3090     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
3091     thr->oursv = PL_thrsv;
3092     PL_chopset = " \n-";
3093     PL_dumpindent = 4;
3094
3095     MUTEX_LOCK(&PL_threads_mutex);
3096     PL_nthreads++;
3097     thr->tid = 0;
3098     thr->next = thr;
3099     thr->prev = thr;
3100     MUTEX_UNLOCK(&PL_threads_mutex);
3101
3102 #ifdef HAVE_THREAD_INTERN
3103     Perl_init_thread_intern(thr);
3104 #endif
3105
3106 #ifdef SET_THREAD_SELF
3107     SET_THREAD_SELF(thr);
3108 #else
3109     thr->self = pthread_self();
3110 #endif /* SET_THREAD_SELF */
3111     SET_THR(thr);
3112
3113     /*
3114      * These must come after the SET_THR because sv_setpvn does
3115      * SvTAINT and the taint fields require dTHR.
3116      */
3117     PL_toptarget = NEWSV(0,0);
3118     sv_upgrade(PL_toptarget, SVt_PVFM);
3119     sv_setpvn(PL_toptarget, "", 0);
3120     PL_bodytarget = NEWSV(0,0);
3121     sv_upgrade(PL_bodytarget, SVt_PVFM);
3122     sv_setpvn(PL_bodytarget, "", 0);
3123     PL_formtarget = PL_bodytarget;
3124     thr->errsv = newSVpvn("", 0);
3125     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
3126
3127     PL_maxscream = -1;
3128     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3129     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3130     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3131     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3132     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3133     PL_regindent = 0;
3134     PL_reginterp_cnt = 0;
3135
3136     return thr;
3137 }
3138 #endif /* USE_THREADS */
3139
3140 void
3141 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3142 {
3143     dTHR;
3144     SV *atsv;
3145     line_t oldline = CopLINE(PL_curcop);
3146     CV *cv;
3147     STRLEN len;
3148     int ret;
3149     dJMPENV;
3150
3151     while (AvFILL(paramList) >= 0) {
3152         cv = (CV*)av_shift(paramList);
3153         SAVEFREESV(cv);
3154         CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3155         switch (ret) {
3156         case 0:
3157             atsv = ERRSV;
3158             (void)SvPV(atsv, len);
3159             if (len) {
3160                 STRLEN n_a;
3161                 PL_curcop = &PL_compiling;
3162                 CopLINE_set(PL_curcop, oldline);
3163                 if (paramList == PL_beginav)
3164                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
3165                 else
3166                     Perl_sv_catpvf(aTHX_ atsv,
3167                                    "%s failed--call queue aborted",
3168                                    paramList == PL_stopav ? "STOP"
3169                                    : paramList == PL_initav ? "INIT"
3170                                    : "END");
3171                 while (PL_scopestack_ix > oldscope)
3172                     LEAVE;
3173                 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3174             }
3175             break;
3176         case 1:
3177             STATUS_ALL_FAILURE;
3178             /* FALL THROUGH */
3179         case 2:
3180             /* my_exit() was called */
3181             while (PL_scopestack_ix > oldscope)
3182                 LEAVE;
3183             FREETMPS;
3184             PL_curstash = PL_defstash;
3185             PL_curcop = &PL_compiling;
3186             CopLINE_set(PL_curcop, oldline);
3187             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3188                 if (paramList == PL_beginav)
3189                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3190                 else
3191                     Perl_croak(aTHX_ "%s failed--call queue aborted",
3192                                paramList == PL_stopav ? "STOP"
3193                                : paramList == PL_initav ? "INIT"
3194                                : "END");
3195             }
3196             my_exit_jump();
3197             /* NOTREACHED */
3198         case 3:
3199             if (PL_restartop) {
3200                 PL_curcop = &PL_compiling;
3201                 CopLINE_set(PL_curcop, oldline);
3202                 JMPENV_JUMP(3);
3203             }
3204             PerlIO_printf(Perl_error_log, "panic: restartop\n");
3205             FREETMPS;
3206             break;
3207         }
3208     }
3209 }
3210
3211 STATIC void *
3212 S_call_list_body(pTHX_ va_list args)
3213 {
3214     dTHR;
3215     CV *cv = va_arg(args, CV*);
3216
3217     PUSHMARK(PL_stack_sp);
3218     call_sv((SV*)cv, G_EVAL|G_DISCARD);
3219     return NULL;
3220 }
3221
3222 void
3223 Perl_my_exit(pTHX_ U32 status)
3224 {
3225     dTHR;
3226
3227     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3228                           thr, (unsigned long) status));
3229     switch (status) {
3230     case 0:
3231         STATUS_ALL_SUCCESS;
3232         break;
3233     case 1:
3234         STATUS_ALL_FAILURE;
3235         break;
3236     default:
3237         STATUS_NATIVE_SET(status);
3238         break;
3239     }
3240     my_exit_jump();
3241 }
3242
3243 void
3244 Perl_my_failure_exit(pTHX)
3245 {
3246 #ifdef VMS
3247     if (vaxc$errno & 1) {
3248         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
3249             STATUS_NATIVE_SET(44);
3250     }
3251     else {
3252         if (!vaxc$errno && errno)       /* unlikely */
3253             STATUS_NATIVE_SET(44);
3254         else
3255             STATUS_NATIVE_SET(vaxc$errno);
3256     }
3257 #else
3258     int exitstatus;
3259     if (errno & 255)
3260         STATUS_POSIX_SET(errno);
3261     else {
3262         exitstatus = STATUS_POSIX >> 8;
3263         if (exitstatus & 255)
3264             STATUS_POSIX_SET(exitstatus);
3265         else
3266             STATUS_POSIX_SET(255);
3267     }
3268 #endif
3269     my_exit_jump();
3270 }
3271
3272 STATIC void
3273 S_my_exit_jump(pTHX)
3274 {
3275     dTHR;
3276     register PERL_CONTEXT *cx;
3277     I32 gimme;
3278     SV **newsp;
3279
3280     if (PL_e_script) {
3281         SvREFCNT_dec(PL_e_script);
3282         PL_e_script = Nullsv;
3283     }
3284
3285     POPSTACK_TO(PL_mainstack);
3286     if (cxstack_ix >= 0) {
3287         if (cxstack_ix > 0)
3288             dounwind(0);
3289         POPBLOCK(cx,PL_curpm);
3290         LEAVE;
3291     }
3292
3293     JMPENV_JUMP(2);
3294 }
3295
3296 #ifdef PERL_OBJECT
3297 #include "XSUB.h"
3298 #endif
3299
3300 static I32
3301 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3302 {
3303     char *p, *nl;
3304     p  = SvPVX(PL_e_script);
3305     nl = strchr(p, '\n');
3306     nl = (nl) ? nl+1 : SvEND(PL_e_script);
3307     if (nl-p == 0) {
3308         filter_del(read_e_script);
3309         return 0;
3310     }
3311     sv_catpvn(buf_sv, p, nl-p);
3312     sv_chop(PL_e_script, nl);
3313     return 1;
3314 }