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