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