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