perl.c

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