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