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