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