perl.c

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