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(PERLSI_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     *fdscript = -1;
1904
1905     if (e_script) {
1906         origfilename = savepv("-e");
1907     }
1908     else {
1909         /* if find_script() returns, it returns a malloc()-ed value */
1910         origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1911
1912         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1913             char *s = scriptname + 8;
1914             *fdscript = atoi(s);
1915             while (isDIGIT(*s))
1916                 s++;
1917             if (*s) {
1918                 scriptname = savepv(s + 1);
1919                 Safefree(origfilename);
1920                 origfilename = scriptname;
1921             }
1922         }
1923     }
1924
1925     curcop->cop_filegv = gv_fetchfile(origfilename);
1926     if (strEQ(origfilename,"-"))
1927         scriptname = "";
1928     if (*fdscript >= 0) {
1929         rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1930 #if defined(HAS_FCNTL) && defined(F_SETFD)
1931         if (rsfp)
1932             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1933 #endif
1934     }
1935     else if (preprocess) {
1936         char *cpp_cfg = CPPSTDIN;
1937         SV *cpp = newSVpv("",0);
1938         SV *cmd = NEWSV(0,0);
1939
1940         if (strEQ(cpp_cfg, "cppstdin"))
1941             sv_catpvf(cpp, "%s/", BIN_EXP);
1942         sv_catpv(cpp, cpp_cfg);
1943
1944         sv_catpv(sv,"-I");
1945         sv_catpv(sv,PRIVLIB_EXP);
1946
1947 #ifdef MSDOS
1948         sv_setpvf(cmd, "\
1949 sed %s -e \"/^[^#]/b\" \
1950  -e \"/^#[      ]*include[      ]/b\" \
1951  -e \"/^#[      ]*define[       ]/b\" \
1952  -e \"/^#[      ]*if[   ]/b\" \
1953  -e \"/^#[      ]*ifdef[        ]/b\" \
1954  -e \"/^#[      ]*ifndef[       ]/b\" \
1955  -e \"/^#[      ]*else/b\" \
1956  -e \"/^#[      ]*elif[         ]/b\" \
1957  -e \"/^#[      ]*undef[        ]/b\" \
1958  -e \"/^#[      ]*endif/b\" \
1959  -e \"s/^#.*//\" \
1960  %s | %_ -C %_ %s",
1961           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1962 #else
1963         sv_setpvf(cmd, "\
1964 %s %s -e '/^[^#]/b' \
1965  -e '/^#[       ]*include[      ]/b' \
1966  -e '/^#[       ]*define[       ]/b' \
1967  -e '/^#[       ]*if[   ]/b' \
1968  -e '/^#[       ]*ifdef[        ]/b' \
1969  -e '/^#[       ]*ifndef[       ]/b' \
1970  -e '/^#[       ]*else/b' \
1971  -e '/^#[       ]*elif[         ]/b' \
1972  -e '/^#[       ]*undef[        ]/b' \
1973  -e '/^#[       ]*endif/b' \
1974  -e 's/^[       ]*#.*//' \
1975  %s | %_ -C %_ %s",
1976 #ifdef LOC_SED
1977           LOC_SED,
1978 #else
1979           "sed",
1980 #endif
1981           (doextract ? "-e '1,/^#/d\n'" : ""),
1982 #endif
1983           scriptname, cpp, sv, CPPMINUS);
1984         doextract = FALSE;
1985 #ifdef IAMSUID                          /* actually, this is caught earlier */
1986         if (euid != uid && !euid) {     /* if running suidperl */
1987 #ifdef HAS_SETEUID
1988             (void)seteuid(uid);         /* musn't stay setuid root */
1989 #else
1990 #ifdef HAS_SETREUID
1991             (void)setreuid((Uid_t)-1, uid);
1992 #else
1993 #ifdef HAS_SETRESUID
1994             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1995 #else
1996             PerlProc_setuid(uid);
1997 #endif
1998 #endif
1999 #endif
2000             if (PerlProc_geteuid() != uid)
2001                 croak("Can't do seteuid!\n");
2002         }
2003 #endif /* IAMSUID */
2004         rsfp = PerlProc_popen(SvPVX(cmd), "r");
2005         SvREFCNT_dec(cmd);
2006         SvREFCNT_dec(cpp);
2007     }
2008     else if (!*scriptname) {
2009         forbid_setid("program input from stdin");
2010         rsfp = PerlIO_stdin();
2011     }
2012     else {
2013         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2014 #if defined(HAS_FCNTL) && defined(F_SETFD)
2015         if (rsfp)
2016             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2017 #endif
2018     }
2019     if (!rsfp) {
2020 #ifdef DOSUID
2021 #ifndef IAMSUID         /* in case script is not readable before setuid */
2022         if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2023           statbuf.st_mode & (S_ISUID|S_ISGID)) {
2024             /* try again */
2025             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2026             croak("Can't do setuid\n");
2027         }
2028 #endif
2029 #endif
2030         croak("Can't open perl script \"%s\": %s\n",
2031           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2032     }
2033 }
2034
2035 STATIC void
2036 validate_suid(char *validarg, char *scriptname, int fdscript)
2037 {
2038     int which;
2039
2040     /* do we need to emulate setuid on scripts? */
2041
2042     /* This code is for those BSD systems that have setuid #! scripts disabled
2043      * in the kernel because of a security problem.  Merely defining DOSUID
2044      * in perl will not fix that problem, but if you have disabled setuid
2045      * scripts in the kernel, this will attempt to emulate setuid and setgid
2046      * on scripts that have those now-otherwise-useless bits set.  The setuid
2047      * root version must be called suidperl or sperlN.NNN.  If regular perl
2048      * discovers that it has opened a setuid script, it calls suidperl with
2049      * the same argv that it had.  If suidperl finds that the script it has
2050      * just opened is NOT setuid root, it sets the effective uid back to the
2051      * uid.  We don't just make perl setuid root because that loses the
2052      * effective uid we had before invoking perl, if it was different from the
2053      * uid.
2054      *
2055      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2056      * be defined in suidperl only.  suidperl must be setuid root.  The
2057      * Configure script will set this up for you if you want it.
2058      */
2059
2060 #ifdef DOSUID
2061     dTHR;
2062     char *s, *s2;
2063
2064     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2065         croak("Can't stat script \"%s\"",origfilename);
2066     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2067         I32 len;
2068
2069 #ifdef IAMSUID
2070 #ifndef HAS_SETREUID
2071         /* On this access check to make sure the directories are readable,
2072          * there is actually a small window that the user could use to make
2073          * filename point to an accessible directory.  So there is a faint
2074          * chance that someone could execute a setuid script down in a
2075          * non-accessible directory.  I don't know what to do about that.
2076          * But I don't think it's too important.  The manual lies when
2077          * it says access() is useful in setuid programs.
2078          */
2079         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2080             croak("Permission denied");
2081 #else
2082         /* If we can swap euid and uid, then we can determine access rights
2083          * with a simple stat of the file, and then compare device and
2084          * inode to make sure we did stat() on the same file we opened.
2085          * Then we just have to make sure he or she can execute it.
2086          */
2087         {
2088             struct stat tmpstatbuf;
2089
2090             if (
2091 #ifdef HAS_SETREUID
2092                 setreuid(euid,uid) < 0
2093 #else
2094 # if HAS_SETRESUID
2095                 setresuid(euid,uid,(Uid_t)-1) < 0
2096 # endif
2097 #endif
2098                 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
2099                 croak("Can't swap uid and euid");       /* really paranoid */
2100             if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2101                 croak("Permission denied");     /* testing full pathname here */
2102             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2103                 tmpstatbuf.st_ino != statbuf.st_ino) {
2104                 (void)PerlIO_close(rsfp);
2105                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2106                     PerlIO_printf(rsfp,
2107 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2108 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2109                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2110                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2111                         SvPVX(GvSV(curcop->cop_filegv)),
2112                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2113                     (void)PerlProc_pclose(rsfp);
2114                 }
2115                 croak("Permission denied\n");
2116             }
2117             if (
2118 #ifdef HAS_SETREUID
2119               setreuid(uid,euid) < 0
2120 #else
2121 # if defined(HAS_SETRESUID)
2122               setresuid(uid,euid,(Uid_t)-1) < 0
2123 # endif
2124 #endif
2125               || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
2126                 croak("Can't reswap uid and euid");
2127             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2128                 croak("Permission denied\n");
2129         }
2130 #endif /* HAS_SETREUID */
2131 #endif /* IAMSUID */
2132
2133         if (!S_ISREG(statbuf.st_mode))
2134             croak("Permission denied");
2135         if (statbuf.st_mode & S_IWOTH)
2136             croak("Setuid/gid script is writable by world");
2137         doswitches = FALSE;             /* -s is insecure in suid */
2138         curcop->cop_line++;
2139         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2140           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2141             croak("No #! line");
2142         s = SvPV(linestr,na)+2;
2143         if (*s == ' ') s++;
2144         while (!isSPACE(*s)) s++;
2145         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2146                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2147         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2148             croak("Not a perl script");
2149         while (*s == ' ' || *s == '\t') s++;
2150         /*
2151          * #! arg must be what we saw above.  They can invoke it by
2152          * mentioning suidperl explicitly, but they may not add any strange
2153          * arguments beyond what #! says if they do invoke suidperl that way.
2154          */
2155         len = strlen(validarg);
2156         if (strEQ(validarg," PHOOEY ") ||
2157             strnNE(s,validarg,len) || !isSPACE(s[len]))
2158             croak("Args must match #! line");
2159
2160 #ifndef IAMSUID
2161         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2162             euid == statbuf.st_uid)
2163             if (!do_undump)
2164                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2165 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2166 #endif /* IAMSUID */
2167
2168         if (euid) {     /* oops, we're not the setuid root perl */
2169             (void)PerlIO_close(rsfp);
2170 #ifndef IAMSUID
2171             /* try again */
2172             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2173 #endif
2174             croak("Can't do setuid\n");
2175         }
2176
2177         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2178 #ifdef HAS_SETEGID
2179             (void)setegid(statbuf.st_gid);
2180 #else
2181 #ifdef HAS_SETREGID
2182            (void)setregid((Gid_t)-1,statbuf.st_gid);
2183 #else
2184 #ifdef HAS_SETRESGID
2185            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2186 #else
2187             PerlProc_setgid(statbuf.st_gid);
2188 #endif
2189 #endif
2190 #endif
2191             if (PerlProc_getegid() != statbuf.st_gid)
2192                 croak("Can't do setegid!\n");
2193         }
2194         if (statbuf.st_mode & S_ISUID) {
2195             if (statbuf.st_uid != euid)
2196 #ifdef HAS_SETEUID
2197                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2198 #else
2199 #ifdef HAS_SETREUID
2200                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2201 #else
2202 #ifdef HAS_SETRESUID
2203                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2204 #else
2205                 PerlProc_setuid(statbuf.st_uid);
2206 #endif
2207 #endif
2208 #endif
2209             if (PerlProc_geteuid() != statbuf.st_uid)
2210                 croak("Can't do seteuid!\n");
2211         }
2212         else if (uid) {                 /* oops, mustn't run as root */
2213 #ifdef HAS_SETEUID
2214           (void)seteuid((Uid_t)uid);
2215 #else
2216 #ifdef HAS_SETREUID
2217           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2218 #else
2219 #ifdef HAS_SETRESUID
2220           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2221 #else
2222           PerlProc_setuid((Uid_t)uid);
2223 #endif
2224 #endif
2225 #endif
2226             if (PerlProc_geteuid() != uid)
2227                 croak("Can't do seteuid!\n");
2228         }
2229         init_ids();
2230         if (!cando(S_IXUSR,TRUE,&statbuf))
2231             croak("Permission denied\n");       /* they can't do this */
2232     }
2233 #ifdef IAMSUID
2234     else if (preprocess)
2235         croak("-P not allowed for setuid/setgid script\n");
2236     else if (fdscript >= 0)
2237         croak("fd script not allowed in suidperl\n");
2238     else
2239         croak("Script is not setuid/setgid in suidperl\n");
2240
2241     /* We absolutely must clear out any saved ids here, so we */
2242     /* exec the real perl, substituting fd script for scriptname. */
2243     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2244     PerlIO_rewind(rsfp);
2245     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2246     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2247     if (!origargv[which])
2248         croak("Permission denied");
2249     origargv[which] = savepv(form("/dev/fd/%d/%s",
2250                                   PerlIO_fileno(rsfp), origargv[which]));
2251 #if defined(HAS_FCNTL) && defined(F_SETFD)
2252     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2253 #endif
2254     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2255     croak("Can't do setuid\n");
2256 #endif /* IAMSUID */
2257 #else /* !DOSUID */
2258     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2259 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2260         dTHR;
2261         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2262         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2263             ||
2264             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2265            )
2266             if (!do_undump)
2267                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2268 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2269 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2270         /* not set-id, must be wrapped */
2271     }
2272 #endif /* DOSUID */
2273 }
2274
2275 STATIC void
2276 find_beginning(void)
2277 {
2278     register char *s, *s2;
2279
2280     /* skip forward in input to the real script? */
2281
2282     forbid_setid("-x");
2283     while (doextract) {
2284         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2285             croak("No Perl script found in input\n");
2286         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2287             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2288             doextract = FALSE;
2289             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2290             s2 = s;
2291             while (*s == ' ' || *s == '\t') s++;
2292             if (*s++ == '-') {
2293                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2294                 if (strnEQ(s2-4,"perl",4))
2295                     /*SUPPRESS 530*/
2296                     while (s = moreswitches(s)) ;
2297             }
2298             if (cddir && PerlDir_chdir(cddir) < 0)
2299                 croak("Can't chdir to %s",cddir);
2300         }
2301     }
2302 }
2303
2304
2305 STATIC void
2306 init_ids(void)
2307 {
2308     uid = (int)PerlProc_getuid();
2309     euid = (int)PerlProc_geteuid();
2310     gid = (int)PerlProc_getgid();
2311     egid = (int)PerlProc_getegid();
2312 #ifdef VMS
2313     uid |= gid << 16;
2314     euid |= egid << 16;
2315 #endif
2316     tainting |= (uid && (euid != uid || egid != gid));
2317 }
2318
2319 STATIC void
2320 forbid_setid(char *s)
2321 {
2322     if (euid != uid)
2323         croak("No %s allowed while running setuid", s);
2324     if (egid != gid)
2325         croak("No %s allowed while running setgid", s);
2326 }
2327
2328 STATIC void
2329 init_debugger(void)
2330 {
2331     dTHR;
2332     curstash = debstash;
2333     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2334     AvREAL_off(dbargs);
2335     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2336     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2337     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2338     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2339     sv_setiv(DBsingle, 0);
2340     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2341     sv_setiv(DBtrace, 0);
2342     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2343     sv_setiv(DBsignal, 0);
2344     curstash = defstash;
2345 }
2346
2347 #ifndef STRESS_REALLOC
2348 #define REASONABLE(size) (size)
2349 #else
2350 #define REASONABLE(size) (1) /* unreasonable */
2351 #endif
2352
2353 void
2354 init_stacks(ARGSproto)
2355 {
2356     /* start with 128-item stack and 8K cxstack */
2357     curstackinfo = new_stackinfo(REASONABLE(128),
2358                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2359     curstackinfo->si_type = PERLSI_MAIN;
2360     curstack = curstackinfo->si_stack;
2361     mainstack = curstack;               /* remember in case we switch stacks */
2362
2363     stack_base = AvARRAY(curstack);
2364     stack_sp = stack_base;
2365     stack_max = stack_base + AvMAX(curstack);
2366
2367     New(50,tmps_stack,REASONABLE(128),SV*);
2368     tmps_floor = -1;
2369     tmps_ix = -1;
2370     tmps_max = REASONABLE(128);
2371
2372     New(54,markstack,REASONABLE(32),I32);
2373     markstack_ptr = markstack;
2374     markstack_max = markstack + REASONABLE(32);
2375
2376     SET_MARKBASE;
2377
2378     New(54,scopestack,REASONABLE(32),I32);
2379     scopestack_ix = 0;
2380     scopestack_max = REASONABLE(32);
2381
2382     New(54,savestack,REASONABLE(128),ANY);
2383     savestack_ix = 0;
2384     savestack_max = REASONABLE(128);
2385
2386     New(54,retstack,REASONABLE(16),OP*);
2387     retstack_ix = 0;
2388     retstack_max = REASONABLE(16);
2389 }
2390
2391 #undef REASONABLE
2392
2393 STATIC void
2394 nuke_stacks(void)
2395 {
2396     dTHR;
2397     while (curstackinfo->si_next)
2398         curstackinfo = curstackinfo->si_next;
2399     while (curstackinfo) {
2400         PERL_SI *p = curstackinfo->si_prev;
2401         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2402         Safefree(curstackinfo->si_cxstack);
2403         Safefree(curstackinfo);
2404         curstackinfo = p;
2405     }
2406     Safefree(tmps_stack);
2407     Safefree(markstack);
2408     Safefree(scopestack);
2409     Safefree(savestack);
2410     Safefree(retstack);
2411     DEBUG( {
2412         Safefree(debname);
2413         Safefree(debdelim);
2414     } )
2415 }
2416
2417 #ifndef PERL_OBJECT
2418 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2419 #endif
2420
2421 STATIC void
2422 init_lexer(void)
2423 {
2424 #ifdef PERL_OBJECT
2425         PerlIO *tmpfp;
2426 #endif
2427     tmpfp = rsfp;
2428     rsfp = Nullfp;
2429     lex_start(linestr);
2430     rsfp = tmpfp;
2431     subname = newSVpv("main",4);
2432 }
2433
2434 STATIC void
2435 init_predump_symbols(void)
2436 {
2437     dTHR;
2438     GV *tmpgv;
2439     GV *othergv;
2440
2441     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2442     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2443     GvMULTI_on(stdingv);
2444     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2445     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2446     GvMULTI_on(tmpgv);
2447     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2448
2449     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2450     GvMULTI_on(tmpgv);
2451     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2452     setdefout(tmpgv);
2453     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2454     GvMULTI_on(tmpgv);
2455     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2456
2457     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2458     GvMULTI_on(othergv);
2459     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2460     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2461     GvMULTI_on(tmpgv);
2462     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2463
2464     statname = NEWSV(66,0);             /* last filename we did stat on */
2465
2466     if (!osname)
2467         osname = savepv(OSNAME);
2468 }
2469
2470 STATIC void
2471 init_postdump_symbols(register int argc, register char **argv, register char **env)
2472 {
2473     dTHR;
2474     char *s;
2475     SV *sv;
2476     GV* tmpgv;
2477
2478     argc--,argv++;      /* skip name of script */
2479     if (doswitches) {
2480         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2481             if (!argv[0][1])
2482                 break;
2483             if (argv[0][1] == '-') {
2484                 argc--,argv++;
2485                 break;
2486             }
2487             if (s = strchr(argv[0], '=')) {
2488                 *s++ = '\0';
2489                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2490             }
2491             else
2492                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2493         }
2494     }
2495     toptarget = NEWSV(0,0);
2496     sv_upgrade(toptarget, SVt_PVFM);
2497     sv_setpvn(toptarget, "", 0);
2498     bodytarget = NEWSV(0,0);
2499     sv_upgrade(bodytarget, SVt_PVFM);
2500     sv_setpvn(bodytarget, "", 0);
2501     formtarget = bodytarget;
2502
2503     TAINT;
2504     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2505         sv_setpv(GvSV(tmpgv),origfilename);
2506         magicname("0", "0", 1);
2507     }
2508     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2509         sv_setpv(GvSV(tmpgv),origargv[0]);
2510     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2511         GvMULTI_on(argvgv);
2512         (void)gv_AVadd(argvgv);
2513         av_clear(GvAVn(argvgv));
2514         for (; argc > 0; argc--,argv++) {
2515             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2516         }
2517     }
2518     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2519         HV *hv;
2520         GvMULTI_on(envgv);
2521         hv = GvHVn(envgv);
2522         hv_magic(hv, envgv, 'E');
2523 #ifndef VMS  /* VMS doesn't have environ array */
2524         /* Note that if the supplied env parameter is actually a copy
2525            of the global environ then it may now point to free'd memory
2526            if the environment has been modified since. To avoid this
2527            problem we treat env==NULL as meaning 'use the default'
2528         */
2529         if (!env)
2530             env = environ;
2531         if (env != environ)
2532             environ[0] = Nullch;
2533         for (; *env; env++) {
2534             if (!(s = strchr(*env,'=')))
2535                 continue;
2536             *s++ = '\0';
2537 #if defined(MSDOS)
2538             (void)strupr(*env);
2539 #endif
2540             sv = newSVpv(s--,0);
2541             (void)hv_store(hv, *env, s - *env, sv, 0);
2542             *s = '=';
2543 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2544             /* Sins of the RTL. See note in my_setenv(). */
2545             (void)PerlEnv_putenv(savepv(*env));
2546 #endif
2547         }
2548 #endif
2549 #ifdef DYNAMIC_ENV_FETCH
2550         HvNAME(hv) = savepv(ENV_HV_NAME);
2551 #endif
2552     }
2553     TAINT_NOT;
2554     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2555         sv_setiv(GvSV(tmpgv), (IV)getpid());
2556 }
2557
2558 STATIC void
2559 init_perllib(void)
2560 {
2561     char *s;
2562     if (!tainting) {
2563 #ifndef VMS
2564         s = PerlEnv_getenv("PERL5LIB");
2565         if (s)
2566             incpush(s, TRUE);
2567         else
2568             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2569 #else /* VMS */
2570         /* Treat PERL5?LIB as a possible search list logical name -- the
2571          * "natural" VMS idiom for a Unix path string.  We allow each
2572          * element to be a set of |-separated directories for compatibility.
2573          */
2574         char buf[256];
2575         int idx = 0;
2576         if (my_trnlnm("PERL5LIB",buf,0))
2577             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2578         else
2579             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2580 #endif /* VMS */
2581     }
2582
2583 /* Use the ~-expanded versions of APPLLIB (undocumented),
2584     ARCHLIB PRIVLIB SITEARCH and SITELIB
2585 */
2586 #ifdef APPLLIB_EXP
2587     incpush(APPLLIB_EXP, TRUE);
2588 #endif
2589
2590 #ifdef ARCHLIB_EXP
2591     incpush(ARCHLIB_EXP, FALSE);
2592 #endif
2593 #ifndef PRIVLIB_EXP
2594 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2595 #endif
2596 #if defined(WIN32)
2597     incpush(PRIVLIB_EXP, TRUE);
2598 #else
2599     incpush(PRIVLIB_EXP, FALSE);
2600 #endif
2601
2602 #ifdef SITEARCH_EXP
2603     incpush(SITEARCH_EXP, FALSE);
2604 #endif
2605 #ifdef SITELIB_EXP
2606 #if defined(WIN32)
2607     incpush(SITELIB_EXP, TRUE);
2608 #else
2609     incpush(SITELIB_EXP, FALSE);
2610 #endif
2611 #endif
2612     if (!tainting)
2613         incpush(".", FALSE);
2614 }
2615
2616 #if defined(DOSISH)
2617 #    define PERLLIB_SEP ';'
2618 #else
2619 #  if defined(VMS)
2620 #    define PERLLIB_SEP '|'
2621 #  else
2622 #    define PERLLIB_SEP ':'
2623 #  endif
2624 #endif
2625 #ifndef PERLLIB_MANGLE
2626 #  define PERLLIB_MANGLE(s,n) (s)
2627 #endif
2628
2629 STATIC void
2630 incpush(char *p, int addsubdirs)
2631 {
2632     SV *subdir = Nullsv;
2633
2634     if (!p)
2635         return;
2636
2637     if (addsubdirs) {
2638         subdir = sv_newmortal();
2639         if (!archpat_auto) {
2640             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2641                           + sizeof("//auto"));
2642             New(55, archpat_auto, len, char);
2643             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2644 #ifdef VMS
2645         for (len = sizeof(ARCHNAME) + 2;
2646              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2647                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2648 #endif
2649         }
2650     }
2651
2652     /* Break at all separators */
2653     while (p && *p) {
2654         SV *libdir = NEWSV(55,0);
2655         char *s;
2656
2657         /* skip any consecutive separators */
2658         while ( *p == PERLLIB_SEP ) {
2659             /* Uncomment the next line for PATH semantics */
2660             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2661             p++;
2662         }
2663
2664         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2665             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2666                       (STRLEN)(s - p));
2667             p = s + 1;
2668         }
2669         else {
2670             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2671             p = Nullch; /* break out */
2672         }
2673
2674         /*
2675          * BEFORE pushing libdir onto @INC we may first push version- and
2676          * archname-specific sub-directories.
2677          */
2678         if (addsubdirs) {
2679             struct stat tmpstatbuf;
2680 #ifdef VMS
2681             char *unix;
2682             STRLEN len;
2683
2684             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2685                 len = strlen(unix);
2686                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2687                 sv_usepvn(libdir,unix,len);
2688             }
2689             else
2690                 PerlIO_printf(PerlIO_stderr(),
2691                               "Failed to unixify @INC element \"%s\"\n",
2692                               SvPV(libdir,na));
2693 #endif
2694             /* .../archname/version if -d .../archname/version/auto */
2695             sv_setsv(subdir, libdir);
2696             sv_catpv(subdir, archpat_auto);
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             /* .../archname if -d .../archname/auto */
2703             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2704                       strlen(patchlevel) + 1, "", 0);
2705             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2706                   S_ISDIR(tmpstatbuf.st_mode))
2707                 av_push(GvAVn(incgv),
2708                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2709         }
2710
2711         /* finally push this lib directory on the end of @INC */
2712         av_push(GvAVn(incgv), libdir);
2713     }
2714 }
2715
2716 #ifdef USE_THREADS
2717 STATIC struct perl_thread *
2718 init_main_thread()
2719 {
2720     struct perl_thread *thr;
2721     XPV *xpv;
2722
2723     Newz(53, thr, 1, struct perl_thread);
2724     curcop = &compiling;
2725     thr->cvcache = newHV();
2726     thr->threadsv = newAV();
2727     /* thr->threadsvp is set when find_threadsv is called */
2728     thr->specific = newAV();
2729     thr->errhv = newHV();
2730     thr->flags = THRf_R_JOINABLE;
2731     MUTEX_INIT(&thr->mutex);
2732     /* Handcraft thrsv similarly to mess_sv */
2733     New(53, thrsv, 1, SV);
2734     Newz(53, xpv, 1, XPV);
2735     SvFLAGS(thrsv) = SVt_PV;
2736     SvANY(thrsv) = (void*)xpv;
2737     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2738     SvPVX(thrsv) = (char*)thr;
2739     SvCUR_set(thrsv, sizeof(thr));
2740     SvLEN_set(thrsv, sizeof(thr));
2741     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2742     thr->oursv = thrsv;
2743     chopset = " \n-";
2744
2745     MUTEX_LOCK(&threads_mutex);
2746     nthreads++;
2747     thr->tid = 0;
2748     thr->next = thr;
2749     thr->prev = thr;
2750     MUTEX_UNLOCK(&threads_mutex);
2751
2752 #ifdef HAVE_THREAD_INTERN
2753     init_thread_intern(thr);
2754 #endif
2755
2756 #ifdef SET_THREAD_SELF
2757     SET_THREAD_SELF(thr);
2758 #else
2759     thr->self = pthread_self();
2760 #endif /* SET_THREAD_SELF */
2761     SET_THR(thr);
2762
2763     /*
2764      * These must come after the SET_THR because sv_setpvn does
2765      * SvTAINT and the taint fields require dTHR.
2766      */
2767     toptarget = NEWSV(0,0);
2768     sv_upgrade(toptarget, SVt_PVFM);
2769     sv_setpvn(toptarget, "", 0);
2770     bodytarget = NEWSV(0,0);
2771     sv_upgrade(bodytarget, SVt_PVFM);
2772     sv_setpvn(bodytarget, "", 0);
2773     formtarget = bodytarget;
2774     thr->errsv = newSVpv("", 0);
2775     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2776     return thr;
2777 }
2778 #endif /* USE_THREADS */
2779
2780 void
2781 call_list(I32 oldscope, AV *paramList)
2782 {
2783     dTHR;
2784     line_t oldline = curcop->cop_line;
2785     STRLEN len;
2786     dJMPENV;
2787     int ret;
2788
2789     while (AvFILL(paramList) >= 0) {
2790         CV *cv = (CV*)av_shift(paramList);
2791
2792         SAVEFREESV(cv);
2793
2794         JMPENV_PUSH(ret);
2795         switch (ret) {
2796         case 0: {
2797                 SV* atsv = ERRSV;
2798                 PUSHMARK(stack_sp);
2799                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2800                 (void)SvPV(atsv, len);
2801                 if (len) {
2802                     JMPENV_POP;
2803                     curcop = &compiling;
2804                     curcop->cop_line = oldline;
2805                     if (paramList == beginav)
2806                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2807                     else
2808                         sv_catpv(atsv, "END failed--cleanup aborted");
2809                     while (scopestack_ix > oldscope)
2810                         LEAVE;
2811                     croak("%s", SvPVX(atsv));
2812                 }
2813             }
2814             break;
2815         case 1:
2816             STATUS_ALL_FAILURE;
2817             /* FALL THROUGH */
2818         case 2:
2819             /* my_exit() was called */
2820             while (scopestack_ix > oldscope)
2821                 LEAVE;
2822             FREETMPS;
2823             curstash = defstash;
2824             if (endav)
2825                 call_list(oldscope, endav);
2826             JMPENV_POP;
2827             curcop = &compiling;
2828             curcop->cop_line = oldline;
2829             if (statusvalue) {
2830                 if (paramList == beginav)
2831                     croak("BEGIN failed--compilation aborted");
2832                 else
2833                     croak("END failed--cleanup aborted");
2834             }
2835             my_exit_jump();
2836             /* NOTREACHED */
2837         case 3:
2838             if (!restartop) {
2839                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2840                 FREETMPS;
2841                 break;
2842             }
2843             JMPENV_POP;
2844             curcop = &compiling;
2845             curcop->cop_line = oldline;
2846             JMPENV_JUMP(3);
2847         }
2848         JMPENV_POP;
2849     }
2850 }
2851
2852 void
2853 my_exit(U32 status)
2854 {
2855     dTHR;
2856
2857 #ifdef USE_THREADS
2858     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2859                           thr, (unsigned long) status));
2860 #endif /* USE_THREADS */
2861     switch (status) {
2862     case 0:
2863         STATUS_ALL_SUCCESS;
2864         break;
2865     case 1:
2866         STATUS_ALL_FAILURE;
2867         break;
2868     default:
2869         STATUS_NATIVE_SET(status);
2870         break;
2871     }
2872     my_exit_jump();
2873 }
2874
2875 void
2876 my_failure_exit(void)
2877 {
2878 #ifdef VMS
2879     if (vaxc$errno & 1) {
2880         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2881             STATUS_NATIVE_SET(44);
2882     }
2883     else {
2884         if (!vaxc$errno && errno)       /* unlikely */
2885             STATUS_NATIVE_SET(44);
2886         else
2887             STATUS_NATIVE_SET(vaxc$errno);
2888     }
2889 #else
2890     int exitstatus;
2891     if (errno & 255)
2892         STATUS_POSIX_SET(errno);
2893     else {
2894         exitstatus = STATUS_POSIX >> 8;
2895         if (exitstatus & 255)
2896             STATUS_POSIX_SET(exitstatus);
2897         else
2898             STATUS_POSIX_SET(255);
2899     }
2900 #endif
2901     my_exit_jump();
2902 }
2903
2904 STATIC void
2905 my_exit_jump(void)
2906 {
2907     dSP;
2908     register PERL_CONTEXT *cx;
2909     I32 gimme;
2910     SV **newsp;
2911
2912     if (e_script) {
2913         SvREFCNT_dec(e_script);
2914         e_script = Nullsv;
2915     }
2916
2917     POPSTACK_TO(mainstack);
2918     if (cxstack_ix >= 0) {
2919         if (cxstack_ix > 0)
2920             dounwind(0);
2921         POPBLOCK(cx,curpm);
2922         LEAVE;
2923     }
2924
2925     JMPENV_JUMP(2);
2926 }
2927
2928
2929 #include "XSUB.h"
2930
2931 static I32
2932 #ifdef PERL_OBJECT
2933 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
2934 #else
2935 read_e_script(int idx, SV *buf_sv, int maxlen)
2936 #endif
2937 {
2938     char *p, *nl;
2939     p  = SvPVX(e_script);
2940     nl = strchr(p, '\n');
2941     nl = (nl) ? nl+1 : SvEND(e_script);
2942     if (nl-p == 0)
2943         return 0;
2944     sv_catpvn(buf_sv, p, nl-p);
2945     sv_chop(e_script, nl);
2946     return 1;
2947 }
2948
2949