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