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