perl.c

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