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