perl.c

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