perl.c

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