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