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     dSP;
1146     LOGOP myop;         /* fake syntax tree node */
1147     I32 oldmark;
1148     I32 retval;
1149     I32 oldscope;
1150     static CV *DBcv;
1151     bool oldcatch = CATCH_GET;
1152     dJMPENV;
1153     int ret;
1154     OP* oldop = op;
1155
1156     if (flags & G_DISCARD) {
1157         ENTER;
1158         SAVETMPS;
1159     }
1160
1161     Zero(&myop, 1, LOGOP);
1162     myop.op_next = Nullop;
1163     if (!(flags & G_NOARGS))
1164         myop.op_flags |= OPf_STACKED;
1165     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1166                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1167                       OPf_WANT_SCALAR);
1168     SAVEOP();
1169     op = (OP*)&myop;
1170
1171     EXTEND(stack_sp, 1);
1172     *++stack_sp = sv;
1173     oldmark = TOPMARK;
1174     oldscope = scopestack_ix;
1175
1176     if (PERLDB_SUB && curstash != debstash
1177            /* Handle first BEGIN of -d. */
1178           && (DBcv || (DBcv = GvCV(DBsub)))
1179            /* Try harder, since this may have been a sighandler, thus
1180             * curstash may be meaningless. */
1181           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1182         op->op_private |= OPpENTERSUB_DB;
1183
1184     if (flags & G_EVAL) {
1185         cLOGOP->op_other = op;
1186         markstack_ptr--;
1187         /* we're trying to emulate pp_entertry() here */
1188         {
1189             register PERL_CONTEXT *cx;
1190             I32 gimme = GIMME_V;
1191
1192             ENTER;
1193             SAVETMPS;
1194
1195             push_return(op->op_next);
1196             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1197             PUSHEVAL(cx, 0, 0);
1198             eval_root = op;             /* Only needed so that goto works right. */
1199
1200             in_eval = 1;
1201             if (flags & G_KEEPERR)
1202                 in_eval |= 4;
1203             else
1204                 sv_setpv(ERRSV,"");
1205         }
1206         markstack_ptr++;
1207
1208         JMPENV_PUSH(ret);
1209         switch (ret) {
1210         case 0:
1211             break;
1212         case 1:
1213             STATUS_ALL_FAILURE;
1214             /* FALL THROUGH */
1215         case 2:
1216             /* my_exit() was called */
1217             curstash = defstash;
1218             FREETMPS;
1219             JMPENV_POP;
1220             if (statusvalue)
1221                 croak("Callback called exit");
1222             my_exit_jump();
1223             /* NOTREACHED */
1224         case 3:
1225             if (restartop) {
1226                 op = restartop;
1227                 restartop = 0;
1228                 break;
1229             }
1230             stack_sp = stack_base + oldmark;
1231             if (flags & G_ARRAY)
1232                 retval = 0;
1233             else {
1234                 retval = 1;
1235                 *++stack_sp = &sv_undef;
1236             }
1237             goto cleanup;
1238         }
1239     }
1240     else
1241         CATCH_SET(TRUE);
1242
1243     if (op == (OP*)&myop)
1244         op = pp_entersub(ARGS);
1245     if (op)
1246         runops();
1247     retval = stack_sp - (stack_base + oldmark);
1248     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1249         sv_setpv(ERRSV,"");
1250
1251   cleanup:
1252     if (flags & G_EVAL) {
1253         if (scopestack_ix > oldscope) {
1254             SV **newsp;
1255             PMOP *newpm;
1256             I32 gimme;
1257             register PERL_CONTEXT *cx;
1258             I32 optype;
1259
1260             POPBLOCK(cx,newpm);
1261             POPEVAL(cx);
1262             pop_return();
1263             curpm = newpm;
1264             LEAVE;
1265         }
1266         JMPENV_POP;
1267     }
1268     else
1269         CATCH_SET(oldcatch);
1270
1271     if (flags & G_DISCARD) {
1272         stack_sp = stack_base + oldmark;
1273         retval = 0;
1274         FREETMPS;
1275         LEAVE;
1276     }
1277     op = oldop;
1278     return retval;
1279 }
1280
1281 /* Eval a string. The G_EVAL flag is always assumed. */
1282
1283 I32
1284 perl_eval_sv(SV *sv, I32 flags)
1285
1286                         /* See G_* flags in cop.h */
1287 {
1288     dSP;
1289     UNOP myop;          /* fake syntax tree node */
1290     I32 oldmark = SP - stack_base;
1291     I32 retval;
1292     I32 oldscope;
1293     dJMPENV;
1294     int ret;
1295     OP* oldop = op;
1296
1297     if (flags & G_DISCARD) {
1298         ENTER;
1299         SAVETMPS;
1300     }
1301
1302     SAVEOP();
1303     op = (OP*)&myop;
1304     Zero(op, 1, UNOP);
1305     EXTEND(stack_sp, 1);
1306     *++stack_sp = sv;
1307     oldscope = scopestack_ix;
1308
1309     if (!(flags & G_NOARGS))
1310         myop.op_flags = OPf_STACKED;
1311     myop.op_next = Nullop;
1312     myop.op_type = OP_ENTEREVAL;
1313     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1314                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1315                       OPf_WANT_SCALAR);
1316     if (flags & G_KEEPERR)
1317         myop.op_flags |= OPf_SPECIAL;
1318
1319     JMPENV_PUSH(ret);
1320     switch (ret) {
1321     case 0:
1322         break;
1323     case 1:
1324         STATUS_ALL_FAILURE;
1325         /* FALL THROUGH */
1326     case 2:
1327         /* my_exit() was called */
1328         curstash = defstash;
1329         FREETMPS;
1330         JMPENV_POP;
1331         if (statusvalue)
1332             croak("Callback called exit");
1333         my_exit_jump();
1334         /* NOTREACHED */
1335     case 3:
1336         if (restartop) {
1337             op = restartop;
1338             restartop = 0;
1339             break;
1340         }
1341         stack_sp = stack_base + oldmark;
1342         if (flags & G_ARRAY)
1343             retval = 0;
1344         else {
1345             retval = 1;
1346             *++stack_sp = &sv_undef;
1347         }
1348         goto cleanup;
1349     }
1350
1351     if (op == (OP*)&myop)
1352         op = pp_entereval(ARGS);
1353     if (op)
1354         runops();
1355     retval = stack_sp - (stack_base + oldmark);
1356     if (!(flags & G_KEEPERR))
1357         sv_setpv(ERRSV,"");
1358
1359   cleanup:
1360     JMPENV_POP;
1361     if (flags & G_DISCARD) {
1362         stack_sp = stack_base + oldmark;
1363         retval = 0;
1364         FREETMPS;
1365         LEAVE;
1366     }
1367     op = oldop;
1368     return retval;
1369 }
1370
1371 SV*
1372 perl_eval_pv(char *p, I32 croak_on_error)
1373 {
1374     dSP;
1375     SV* sv = newSVpv(p, 0);
1376
1377     PUSHMARK(SP);
1378     perl_eval_sv(sv, G_SCALAR);
1379     SvREFCNT_dec(sv);
1380
1381     SPAGAIN;
1382     sv = POPs;
1383     PUTBACK;
1384
1385     if (croak_on_error && SvTRUE(ERRSV))
1386         croak(SvPVx(ERRSV, na));
1387
1388     return sv;
1389 }
1390
1391 /* Require a module. */
1392
1393 void
1394 perl_require_pv(char *pv)
1395 {
1396     SV* sv = sv_newmortal();
1397     sv_setpv(sv, "require '");
1398     sv_catpv(sv, pv);
1399     sv_catpv(sv, "'");
1400     perl_eval_sv(sv, G_DISCARD);
1401 }
1402
1403 void
1404 magicname(char *sym, char *name, I32 namlen)
1405 {
1406     register GV *gv;
1407
1408     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1409         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1410 }
1411
1412 static void
1413 usage(char *name)               /* XXX move this out into a module ? */
1414
1415 {
1416     /* This message really ought to be max 23 lines.
1417      * Removed -h because the user already knows that opton. Others? */
1418
1419     static char *usage[] = {
1420 "-0[octal]       specify record separator (\\0, if no argument)",
1421 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1422 "-c              check syntax only (runs BEGIN and END blocks)",
1423 "-d[:debugger]   run scripts under debugger",
1424 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1425 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1426 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1427 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1428 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1429 "-l[octal]       enable line ending processing, specifies line terminator",
1430 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1431 "-n              assume 'while (<>) { ... }' loop around your script",
1432 "-p              assume loop like -n but print line also like sed",
1433 "-P              run script through C preprocessor before compilation",
1434 "-s              enable some switch parsing for switches after script name",
1435 "-S              look for the script using PATH environment variable",
1436 "-T              turn on tainting checks",
1437 "-u              dump core after parsing script",
1438 "-U              allow unsafe operations",
1439 "-v              print version number and patchlevel of perl",
1440 "-V[:variable]   print perl configuration information",
1441 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1442 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1443 "\n",
1444 NULL
1445 };
1446     char **p = usage;
1447
1448     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1449     while (*p)
1450         printf("\n  %s", *p++);
1451 }
1452
1453 /* This routine handles any switches that can be given during run */
1454
1455 char *
1456 moreswitches(char *s)
1457 {
1458     I32 numlen;
1459     U32 rschar;
1460
1461     switch (*s) {
1462     case '0':
1463     {
1464         dTHR;
1465         rschar = scan_oct(s, 4, &numlen);
1466         SvREFCNT_dec(nrs);
1467         if (rschar & ~((U8)~0))
1468             nrs = &sv_undef;
1469         else if (!rschar && numlen >= 2)
1470             nrs = newSVpv("", 0);
1471         else {
1472             char ch = rschar;
1473             nrs = newSVpv(&ch, 1);
1474         }
1475         return s + numlen;
1476     }
1477     case 'F':
1478         minus_F = TRUE;
1479         splitstr = savepv(s + 1);
1480         s += strlen(s);
1481         return s;
1482     case 'a':
1483         minus_a = TRUE;
1484         s++;
1485         return s;
1486     case 'c':
1487         minus_c = TRUE;
1488         s++;
1489         return s;
1490     case 'd':
1491         forbid_setid("-d");
1492         s++;
1493         if (*s == ':' || *s == '=')  {
1494             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1495             s += strlen(s);
1496         }
1497         if (!perldb) {
1498             perldb = PERLDB_ALL;
1499             init_debugger();
1500         }
1501         return s;
1502     case 'D':
1503 #ifdef DEBUGGING
1504         forbid_setid("-D");
1505         if (isALPHA(s[1])) {
1506             static char debopts[] = "psltocPmfrxuLHXD";
1507             char *d;
1508
1509             for (s++; *s && (d = strchr(debopts,*s)); s++)
1510                 debug |= 1 << (d - debopts);
1511         }
1512         else {
1513             debug = atoi(s+1);
1514             for (s++; isDIGIT(*s); s++) ;
1515         }
1516         debug |= 0x80000000;
1517 #else
1518         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1519         for (s++; isALNUM(*s); s++) ;
1520 #endif
1521         /*SUPPRESS 530*/
1522         return s;
1523     case 'h':
1524         usage(origargv[0]);
1525         PerlProc_exit(0);
1526     case 'i':
1527         if (inplace)
1528             Safefree(inplace);
1529         inplace = savepv(s+1);
1530         /*SUPPRESS 530*/
1531         for (s = inplace; *s && !isSPACE(*s); s++) ;
1532         if (*s)
1533             *s++ = '\0';
1534         return s;
1535     case 'I':   /* -I handled both here and in parse_perl() */
1536         forbid_setid("-I");
1537         ++s;
1538         while (*s && isSPACE(*s))
1539             ++s;
1540         if (*s) {
1541             char *e, *p;
1542             for (e = s; *e && !isSPACE(*e); e++) ;
1543             p = savepvn(s, e-s);
1544             incpush(p, TRUE);
1545             Safefree(p);
1546             s = e;
1547         }
1548         else
1549             croak("No space allowed after -I");
1550         return s;
1551     case 'l':
1552         minus_l = TRUE;
1553         s++;
1554         if (ors)
1555             Safefree(ors);
1556         if (isDIGIT(*s)) {
1557             ors = savepv("\n");
1558             orslen = 1;
1559             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1560             s += numlen;
1561         }
1562         else {
1563             dTHR;
1564             if (RsPARA(nrs)) {
1565                 ors = "\n\n";
1566                 orslen = 2;
1567             }
1568             else
1569                 ors = SvPV(nrs, orslen);
1570             ors = savepvn(ors, orslen);
1571         }
1572         return s;
1573     case 'M':
1574         forbid_setid("-M");     /* XXX ? */
1575         /* FALL THROUGH */
1576     case 'm':
1577         forbid_setid("-m");     /* XXX ? */
1578         if (*++s) {
1579             char *start;
1580             SV *sv;
1581             char *use = "use ";
1582             /* -M-foo == 'no foo'       */
1583             if (*s == '-') { use = "no "; ++s; }
1584             sv = newSVpv(use,0);
1585             start = s;
1586             /* We allow -M'Module qw(Foo Bar)'  */
1587             while(isALNUM(*s) || *s==':') ++s;
1588             if (*s != '=') {
1589                 sv_catpv(sv, start);
1590                 if (*(start-1) == 'm') {
1591                     if (*s != '\0')
1592                         croak("Can't use '%c' after -mname", *s);
1593                     sv_catpv( sv, " ()");
1594                 }
1595             } else {
1596                 sv_catpvn(sv, start, s-start);
1597                 sv_catpv(sv, " split(/,/,q{");
1598                 sv_catpv(sv, ++s);
1599                 sv_catpv(sv,    "})");
1600             }
1601             s += strlen(s);
1602             if (preambleav == NULL)
1603                 preambleav = newAV();
1604             av_push(preambleav, sv);
1605         }
1606         else
1607             croak("No space allowed after -%c", *(s-1));
1608         return s;
1609     case 'n':
1610         minus_n = TRUE;
1611         s++;
1612         return s;
1613     case 'p':
1614         minus_p = TRUE;
1615         s++;
1616         return s;
1617     case 's':
1618         forbid_setid("-s");
1619         doswitches = TRUE;
1620         s++;
1621         return s;
1622     case 'T':
1623         if (!tainting)
1624             croak("Too late for \"-T\" option");
1625         s++;
1626         return s;
1627     case 'u':
1628         do_undump = TRUE;
1629         s++;
1630         return s;
1631     case 'U':
1632         unsafe = TRUE;
1633         s++;
1634         return s;
1635     case 'v':
1636 #if defined(SUBVERSION) && SUBVERSION > 0
1637         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1638             PATCHLEVEL, SUBVERSION, ARCHNAME);
1639 #else
1640         printf("\nThis is perl, version %s built for %s",
1641                 patchlevel, ARCHNAME);
1642 #endif
1643 #if defined(LOCAL_PATCH_COUNT)
1644         if (LOCAL_PATCH_COUNT > 0)
1645             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1646                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1647 #endif
1648
1649         printf("\n\nCopyright 1987-1998, Larry Wall\n");
1650 #ifdef MSDOS
1651         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1652 #endif
1653 #ifdef DJGPP
1654         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1655         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1656 #endif
1657 #ifdef OS2
1658         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1659             "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1660 #endif
1661 #ifdef atarist
1662         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1663 #endif
1664         printf("\n\
1665 Perl may be copied only under the terms of either the Artistic License or the\n\
1666 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1667         PerlProc_exit(0);
1668     case 'w':
1669         dowarn = TRUE;
1670         s++;
1671         return s;
1672     case '*':
1673     case ' ':
1674         if (s[1] == '-')        /* Additional switches on #! line. */
1675             return s+2;
1676         break;
1677     case '-':
1678     case 0:
1679 #ifdef WIN32
1680     case '\r':
1681 #endif
1682     case '\n':
1683     case '\t':
1684         break;
1685 #ifdef ALTERNATE_SHEBANG
1686     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1687         break;
1688 #endif
1689     case 'P':
1690         if (preprocess)
1691             return s+1;
1692         /* FALL THROUGH */
1693     default:
1694         croak("Can't emulate -%.1s on #! line",s);
1695     }
1696     return Nullch;
1697 }
1698
1699 /* compliments of Tom Christiansen */
1700
1701 /* unexec() can be found in the Gnu emacs distribution */
1702
1703 void
1704 my_unexec(void)
1705 {
1706 #ifdef UNEXEC
1707     SV*    prog;
1708     SV*    file;
1709     int    status;
1710     extern int etext;
1711
1712     prog = newSVpv(BIN_EXP);
1713     sv_catpv(prog, "/perl");
1714     file = newSVpv(origfilename);
1715     sv_catpv(file, ".perldump");
1716
1717     status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1718     if (status)
1719         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1720                       SvPVX(prog), SvPVX(file));
1721     PerlProc_exit(status);
1722 #else
1723 #  ifdef VMS
1724 #    include <lib$routines.h>
1725      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1726 #  else
1727     ABORT();            /* for use with undump */
1728 #  endif
1729 #endif
1730 }
1731
1732 static void
1733 init_main_stash(void)
1734 {
1735     dTHR;
1736     GV *gv;
1737
1738     /* Note that strtab is a rather special HV.  Assumptions are made
1739        about not iterating on it, and not adding tie magic to it.
1740        It is properly deallocated in perl_destruct() */
1741     strtab = newHV();
1742     HvSHAREKEYS_off(strtab);                    /* mandatory */
1743     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1744          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1745
1746     curstash = defstash = newHV();
1747     curstname = newSVpv("main",4);
1748     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1749     SvREFCNT_dec(GvHV(gv));
1750     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1751     SvREADONLY_on(gv);
1752     HvNAME(defstash) = savepv("main");
1753     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1754     GvMULTI_on(incgv);
1755     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1756     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1757     GvMULTI_on(errgv);
1758     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1759     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1760     sv_setpvn(ERRSV, "", 0);
1761     curstash = defstash;
1762     compiling.cop_stash = defstash;
1763     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1764     globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1765     /* We must init $/ before switches are processed. */
1766     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1767 }
1768
1769 static void
1770 open_script(char *scriptname, bool dosearch, SV *sv)
1771 {
1772     dTHR;
1773     char *xfound = Nullch;
1774     char *xfailed = Nullch;
1775     register char *s;
1776     I32 len;
1777     int retval;
1778 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1779 #  define SEARCH_EXTS ".bat", ".cmd", NULL
1780 #  define MAX_EXT_LEN 4
1781 #endif
1782 #ifdef OS2
1783 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1784 #  define MAX_EXT_LEN 4
1785 #endif
1786 #ifdef VMS
1787 #  define SEARCH_EXTS ".pl", ".com", NULL
1788 #  define MAX_EXT_LEN 4
1789 #endif
1790     /* additional extensions to try in each dir if scriptname not found */
1791 #ifdef SEARCH_EXTS
1792     char *ext[] = { SEARCH_EXTS };
1793     int extidx = 0, i = 0;
1794     char *curext = Nullch;
1795 #else
1796 #  define MAX_EXT_LEN 0
1797 #endif
1798
1799     /*
1800      * If dosearch is true and if scriptname does not contain path
1801      * delimiters, search the PATH for scriptname.
1802      *
1803      * If SEARCH_EXTS is also defined, will look for each
1804      * scriptname{SEARCH_EXTS} whenever scriptname is not found
1805      * while searching the PATH.
1806      *
1807      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1808      * proceeds as follows:
1809      *   If DOSISH or VMSISH:
1810      *     + look for ./scriptname{,.foo,.bar}
1811      *     + search the PATH for scriptname{,.foo,.bar}
1812      *
1813      *   If !DOSISH:
1814      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
1815      *       this will not look in '.' if it's not in the PATH)
1816      */
1817
1818 #ifdef VMS
1819 #  ifdef ALWAYS_DEFTYPES
1820     len = strlen(scriptname);
1821     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1822         int hasdir, idx = 0, deftypes = 1;
1823         bool seen_dot = 1;
1824
1825         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1826 #  else
1827     if (dosearch) {
1828         int hasdir, idx = 0, deftypes = 1;
1829         bool seen_dot = 1;
1830
1831         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1832 #  endif
1833         /* The first time through, just add SEARCH_EXTS to whatever we
1834          * already have, so we can check for default file types. */
1835         while (deftypes ||
1836                (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1837         {
1838             if (deftypes) {
1839                 deftypes = 0;
1840                 *tokenbuf = '\0';
1841             }
1842             if ((strlen(tokenbuf) + strlen(scriptname)
1843                  + MAX_EXT_LEN) >= sizeof tokenbuf)
1844                 continue;       /* don't search dir with too-long name */
1845             strcat(tokenbuf, scriptname);
1846 #else  /* !VMS */
1847
1848 #ifdef DOSISH
1849     if (strEQ(scriptname, "-"))
1850         dosearch = 0;
1851     if (dosearch) {             /* Look in '.' first. */
1852         char *cur = scriptname;
1853 #ifdef SEARCH_EXTS
1854         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1855             while (ext[i])
1856                 if (strEQ(ext[i++],curext)) {
1857                     extidx = -1;                /* already has an ext */
1858                     break;
1859                 }
1860         do {
1861 #endif
1862             DEBUG_p(PerlIO_printf(Perl_debug_log,
1863                                   "Looking for %s\n",cur));
1864             if (Stat(cur,&statbuf) >= 0) {
1865                 dosearch = 0;
1866                 scriptname = cur;
1867 #ifdef SEARCH_EXTS
1868                 break;
1869 #endif
1870             }
1871 #ifdef SEARCH_EXTS
1872             if (cur == scriptname) {
1873                 len = strlen(scriptname);
1874                 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1875                     break;
1876                 cur = strcpy(tokenbuf, scriptname);
1877             }
1878         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
1879                  && strcpy(tokenbuf+len, ext[extidx++]));
1880 #endif
1881     }
1882 #endif
1883
1884     if (dosearch && !strchr(scriptname, '/')
1885 #ifdef DOSISH
1886                  && !strchr(scriptname, '\\')
1887 #endif
1888                  && (s = PerlEnv_getenv("PATH"))) {
1889         bool seen_dot = 0;
1890
1891         bufend = s + strlen(s);
1892         while (s < bufend) {
1893 #if defined(atarist) || defined(DOSISH)
1894             for (len = 0; *s
1895 #  ifdef atarist
1896                     && *s != ','
1897 #  endif
1898                     && *s != ';'; len++, s++) {
1899                 if (len < sizeof tokenbuf)
1900                     tokenbuf[len] = *s;
1901             }
1902             if (len < sizeof tokenbuf)
1903                 tokenbuf[len] = '\0';
1904 #else  /* ! (atarist || DOSISH) */
1905             s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1906                         ':',
1907                         &len);
1908 #endif /* ! (atarist || DOSISH) */
1909             if (s < bufend)
1910                 s++;
1911             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1912                 continue;       /* don't search dir with too-long name */
1913             if (len
1914 #if defined(atarist) || defined(DOSISH)
1915                 && tokenbuf[len - 1] != '/'
1916                 && tokenbuf[len - 1] != '\\'
1917 #endif
1918                )
1919                 tokenbuf[len++] = '/';
1920             if (len == 2 && tokenbuf[0] == '.')
1921                 seen_dot = 1;
1922             (void)strcpy(tokenbuf + len, scriptname);
1923 #endif  /* !VMS */
1924
1925 #ifdef SEARCH_EXTS
1926             len = strlen(tokenbuf);
1927             if (extidx > 0)     /* reset after previous loop */
1928                 extidx = 0;
1929             do {
1930 #endif
1931                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1932                 retval = Stat(tokenbuf,&statbuf);
1933 #ifdef SEARCH_EXTS
1934             } while (  retval < 0               /* not there */
1935                     && extidx>=0 && ext[extidx] /* try an extension? */
1936                     && strcpy(tokenbuf+len, ext[extidx++])
1937                 );
1938 #endif
1939             if (retval < 0)
1940                 continue;
1941             if (S_ISREG(statbuf.st_mode)
1942                 && cando(S_IRUSR,TRUE,&statbuf)
1943 #ifndef DOSISH
1944                 && cando(S_IXUSR,TRUE,&statbuf)
1945 #endif
1946                 )
1947             {
1948                 xfound = tokenbuf;              /* bingo! */
1949                 break;
1950             }
1951             if (!xfailed)
1952                 xfailed = savepv(tokenbuf);
1953         }
1954 #ifndef DOSISH
1955         if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1956 #endif
1957             seen_dot = 1;                       /* Disable message. */
1958         if (!xfound)
1959             croak("Can't %s %s%s%s",
1960                   (xfailed ? "execute" : "find"),
1961                   (xfailed ? xfailed : scriptname),
1962                   (xfailed ? "" : " on PATH"),
1963                   (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1964         if (xfailed)
1965             Safefree(xfailed);
1966         scriptname = xfound;
1967     }
1968
1969     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1970         char *s = scriptname + 8;
1971         fdscript = atoi(s);
1972         while (isDIGIT(*s))
1973             s++;
1974         if (*s)
1975             scriptname = s + 1;
1976     }
1977     else
1978         fdscript = -1;
1979     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1980     curcop->cop_filegv = gv_fetchfile(origfilename);
1981     if (strEQ(origfilename,"-"))
1982         scriptname = "";
1983     if (fdscript >= 0) {
1984         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1985 #if defined(HAS_FCNTL) && defined(F_SETFD)
1986         if (rsfp)
1987             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1988 #endif
1989     }
1990     else if (preprocess) {
1991         char *cpp_cfg = CPPSTDIN;
1992         SV *cpp = NEWSV(0,0);
1993         SV *cmd = NEWSV(0,0);
1994
1995         if (strEQ(cpp_cfg, "cppstdin"))
1996             sv_catpvf(cpp, "%s/", BIN_EXP);
1997         sv_catpv(cpp, cpp_cfg);
1998
1999         sv_catpv(sv,"-I");
2000         sv_catpv(sv,PRIVLIB_EXP);
2001
2002 #ifdef MSDOS
2003         sv_setpvf(cmd, "\
2004 sed %s -e \"/^[^#]/b\" \
2005  -e \"/^#[      ]*include[      ]/b\" \
2006  -e \"/^#[      ]*define[       ]/b\" \
2007  -e \"/^#[      ]*if[   ]/b\" \
2008  -e \"/^#[      ]*ifdef[        ]/b\" \
2009  -e \"/^#[      ]*ifndef[       ]/b\" \
2010  -e \"/^#[      ]*else/b\" \
2011  -e \"/^#[      ]*elif[         ]/b\" \
2012  -e \"/^#[      ]*undef[        ]/b\" \
2013  -e \"/^#[      ]*endif/b\" \
2014  -e \"s/^#.*//\" \
2015  %s | %_ -C %_ %s",
2016           (doextract ? "-e \"1,/^#/d\n\"" : ""),
2017 #else
2018         sv_setpvf(cmd, "\
2019 %s %s -e '/^[^#]/b' \
2020  -e '/^#[       ]*include[      ]/b' \
2021  -e '/^#[       ]*define[       ]/b' \
2022  -e '/^#[       ]*if[   ]/b' \
2023  -e '/^#[       ]*ifdef[        ]/b' \
2024  -e '/^#[       ]*ifndef[       ]/b' \
2025  -e '/^#[       ]*else/b' \
2026  -e '/^#[       ]*elif[         ]/b' \
2027  -e '/^#[       ]*undef[        ]/b' \
2028  -e '/^#[       ]*endif/b' \
2029  -e 's/^[       ]*#.*//' \
2030  %s | %_ -C %_ %s",
2031 #ifdef LOC_SED
2032           LOC_SED,
2033 #else
2034           "sed",
2035 #endif
2036           (doextract ? "-e '1,/^#/d\n'" : ""),
2037 #endif
2038           scriptname, cpp, sv, CPPMINUS);
2039         doextract = FALSE;
2040 #ifdef IAMSUID                          /* actually, this is caught earlier */
2041         if (euid != uid && !euid) {     /* if running suidperl */
2042 #ifdef HAS_SETEUID
2043             (void)seteuid(uid);         /* musn't stay setuid root */
2044 #else
2045 #ifdef HAS_SETREUID
2046             (void)setreuid((Uid_t)-1, uid);
2047 #else
2048 #ifdef HAS_SETRESUID
2049             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2050 #else
2051             setuid(uid);
2052 #endif
2053 #endif
2054 #endif
2055             if (geteuid() != uid)
2056                 croak("Can't do seteuid!\n");
2057         }
2058 #endif /* IAMSUID */
2059         rsfp = PerlProc_popen(SvPVX(cmd), "r");
2060         SvREFCNT_dec(cmd);
2061         SvREFCNT_dec(cpp);
2062     }
2063     else if (!*scriptname) {
2064         forbid_setid("program input from stdin");
2065         rsfp = PerlIO_stdin();
2066     }
2067     else {
2068         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2069 #if defined(HAS_FCNTL) && defined(F_SETFD)
2070         if (rsfp)
2071             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2072 #endif
2073     }
2074     if (e_tmpname) {
2075         e_fp = rsfp;
2076     }
2077     if (!rsfp) {
2078 #ifdef DOSUID
2079 #ifndef IAMSUID         /* in case script is not readable before setuid */
2080         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2081           statbuf.st_mode & (S_ISUID|S_ISGID)) {
2082             /* try again */
2083             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2084             croak("Can't do setuid\n");
2085         }
2086 #endif
2087 #endif
2088         croak("Can't open perl script \"%s\": %s\n",
2089           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2090     }
2091 }
2092
2093 static void
2094 validate_suid(char *validarg, char *scriptname)
2095 {
2096     int which;
2097
2098     /* do we need to emulate setuid on scripts? */
2099
2100     /* This code is for those BSD systems that have setuid #! scripts disabled
2101      * in the kernel because of a security problem.  Merely defining DOSUID
2102      * in perl will not fix that problem, but if you have disabled setuid
2103      * scripts in the kernel, this will attempt to emulate setuid and setgid
2104      * on scripts that have those now-otherwise-useless bits set.  The setuid
2105      * root version must be called suidperl or sperlN.NNN.  If regular perl
2106      * discovers that it has opened a setuid script, it calls suidperl with
2107      * the same argv that it had.  If suidperl finds that the script it has
2108      * just opened is NOT setuid root, it sets the effective uid back to the
2109      * uid.  We don't just make perl setuid root because that loses the
2110      * effective uid we had before invoking perl, if it was different from the
2111      * uid.
2112      *
2113      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2114      * be defined in suidperl only.  suidperl must be setuid root.  The
2115      * Configure script will set this up for you if you want it.
2116      */
2117
2118 #ifdef DOSUID
2119     dTHR;
2120     char *s, *s2;
2121
2122     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2123         croak("Can't stat script \"%s\"",origfilename);
2124     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2125         I32 len;
2126
2127 #ifdef IAMSUID
2128 #ifndef HAS_SETREUID
2129         /* On this access check to make sure the directories are readable,
2130          * there is actually a small window that the user could use to make
2131          * filename point to an accessible directory.  So there is a faint
2132          * chance that someone could execute a setuid script down in a
2133          * non-accessible directory.  I don't know what to do about that.
2134          * But I don't think it's too important.  The manual lies when
2135          * it says access() is useful in setuid programs.
2136          */
2137         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2138             croak("Permission denied");
2139 #else
2140         /* If we can swap euid and uid, then we can determine access rights
2141          * with a simple stat of the file, and then compare device and
2142          * inode to make sure we did stat() on the same file we opened.
2143          * Then we just have to make sure he or she can execute it.
2144          */
2145         {
2146             struct stat tmpstatbuf;
2147
2148             if (
2149 #ifdef HAS_SETREUID
2150                 setreuid(euid,uid) < 0
2151 #else
2152 # if HAS_SETRESUID
2153                 setresuid(euid,uid,(Uid_t)-1) < 0
2154 # endif
2155 #endif
2156                 || getuid() != euid || geteuid() != uid)
2157                 croak("Can't swap uid and euid");       /* really paranoid */
2158             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2159                 croak("Permission denied");     /* testing full pathname here */
2160             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2161                 tmpstatbuf.st_ino != statbuf.st_ino) {
2162                 (void)PerlIO_close(rsfp);
2163                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2164                     PerlIO_printf(rsfp,
2165 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2166 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2167                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2168                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2169                         SvPVX(GvSV(curcop->cop_filegv)),
2170                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2171                     (void)PerlProc_pclose(rsfp);
2172                 }
2173                 croak("Permission denied\n");
2174             }
2175             if (
2176 #ifdef HAS_SETREUID
2177               setreuid(uid,euid) < 0
2178 #else
2179 # if defined(HAS_SETRESUID)
2180               setresuid(uid,euid,(Uid_t)-1) < 0
2181 # endif
2182 #endif
2183               || getuid() != uid || geteuid() != euid)
2184                 croak("Can't reswap uid and euid");
2185             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2186                 croak("Permission denied\n");
2187         }
2188 #endif /* HAS_SETREUID */
2189 #endif /* IAMSUID */
2190
2191         if (!S_ISREG(statbuf.st_mode))
2192             croak("Permission denied");
2193         if (statbuf.st_mode & S_IWOTH)
2194             croak("Setuid/gid script is writable by world");
2195         doswitches = FALSE;             /* -s is insecure in suid */
2196         curcop->cop_line++;
2197         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2198           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2199             croak("No #! line");
2200         s = SvPV(linestr,na)+2;
2201         if (*s == ' ') s++;
2202         while (!isSPACE(*s)) s++;
2203         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2204                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2205         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2206             croak("Not a perl script");
2207         while (*s == ' ' || *s == '\t') s++;
2208         /*
2209          * #! arg must be what we saw above.  They can invoke it by
2210          * mentioning suidperl explicitly, but they may not add any strange
2211          * arguments beyond what #! says if they do invoke suidperl that way.
2212          */
2213         len = strlen(validarg);
2214         if (strEQ(validarg," PHOOEY ") ||
2215             strnNE(s,validarg,len) || !isSPACE(s[len]))
2216             croak("Args must match #! line");
2217
2218 #ifndef IAMSUID
2219         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2220             euid == statbuf.st_uid)
2221             if (!do_undump)
2222                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2223 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2224 #endif /* IAMSUID */
2225
2226         if (euid) {     /* oops, we're not the setuid root perl */
2227             (void)PerlIO_close(rsfp);
2228 #ifndef IAMSUID
2229             /* try again */
2230             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2231 #endif
2232             croak("Can't do setuid\n");
2233         }
2234
2235         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2236 #ifdef HAS_SETEGID
2237             (void)setegid(statbuf.st_gid);
2238 #else
2239 #ifdef HAS_SETREGID
2240            (void)setregid((Gid_t)-1,statbuf.st_gid);
2241 #else
2242 #ifdef HAS_SETRESGID
2243            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2244 #else
2245             setgid(statbuf.st_gid);
2246 #endif
2247 #endif
2248 #endif
2249             if (getegid() != statbuf.st_gid)
2250                 croak("Can't do setegid!\n");
2251         }
2252         if (statbuf.st_mode & S_ISUID) {
2253             if (statbuf.st_uid != euid)
2254 #ifdef HAS_SETEUID
2255                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2256 #else
2257 #ifdef HAS_SETREUID
2258                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2259 #else
2260 #ifdef HAS_SETRESUID
2261                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2262 #else
2263                 setuid(statbuf.st_uid);
2264 #endif
2265 #endif
2266 #endif
2267             if (geteuid() != statbuf.st_uid)
2268                 croak("Can't do seteuid!\n");
2269         }
2270         else if (uid) {                 /* oops, mustn't run as root */
2271 #ifdef HAS_SETEUID
2272           (void)seteuid((Uid_t)uid);
2273 #else
2274 #ifdef HAS_SETREUID
2275           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2276 #else
2277 #ifdef HAS_SETRESUID
2278           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2279 #else
2280           setuid((Uid_t)uid);
2281 #endif
2282 #endif
2283 #endif
2284             if (geteuid() != uid)
2285                 croak("Can't do seteuid!\n");
2286         }
2287         init_ids();
2288         if (!cando(S_IXUSR,TRUE,&statbuf))
2289             croak("Permission denied\n");       /* they can't do this */
2290     }
2291 #ifdef IAMSUID
2292     else if (preprocess)
2293         croak("-P not allowed for setuid/setgid script\n");
2294     else if (fdscript >= 0)
2295         croak("fd script not allowed in suidperl\n");
2296     else
2297         croak("Script is not setuid/setgid in suidperl\n");
2298
2299     /* We absolutely must clear out any saved ids here, so we */
2300     /* exec the real perl, substituting fd script for scriptname. */
2301     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2302     PerlIO_rewind(rsfp);
2303     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2304     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2305     if (!origargv[which])
2306         croak("Permission denied");
2307     origargv[which] = savepv(form("/dev/fd/%d/%s",
2308                                   PerlIO_fileno(rsfp), origargv[which]));
2309 #if defined(HAS_FCNTL) && defined(F_SETFD)
2310     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2311 #endif
2312     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2313     croak("Can't do setuid\n");
2314 #endif /* IAMSUID */
2315 #else /* !DOSUID */
2316     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2317 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2318         dTHR;
2319         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2320         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2321             ||
2322             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2323            )
2324             if (!do_undump)
2325                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2326 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2327 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2328         /* not set-id, must be wrapped */
2329     }
2330 #endif /* DOSUID */
2331 }
2332
2333 static void
2334 find_beginning(void)
2335 {
2336     register char *s, *s2;
2337
2338     /* skip forward in input to the real script? */
2339
2340     forbid_setid("-x");
2341     while (doextract) {
2342         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2343             croak("No Perl script found in input\n");
2344         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2345             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2346             doextract = FALSE;
2347             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2348             s2 = s;
2349             while (*s == ' ' || *s == '\t') s++;
2350             if (*s++ == '-') {
2351                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2352                 if (strnEQ(s2-4,"perl",4))
2353                     /*SUPPRESS 530*/
2354                     while (s = moreswitches(s)) ;
2355             }
2356             if (cddir && PerlDir_chdir(cddir) < 0)
2357                 croak("Can't chdir to %s",cddir);
2358         }
2359     }
2360 }
2361
2362 static void
2363 init_ids(void)
2364 {
2365     uid = (int)getuid();
2366     euid = (int)geteuid();
2367     gid = (int)getgid();
2368     egid = (int)getegid();
2369 #ifdef VMS
2370     uid |= gid << 16;
2371     euid |= egid << 16;
2372 #endif
2373     tainting |= (uid && (euid != uid || egid != gid));
2374 }
2375
2376 static void
2377 forbid_setid(char *s)
2378 {
2379     if (euid != uid)
2380         croak("No %s allowed while running setuid", s);
2381     if (egid != gid)
2382         croak("No %s allowed while running setgid", s);
2383 }
2384
2385 static void
2386 init_debugger(void)
2387 {
2388     dTHR;
2389     curstash = debstash;
2390     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2391     AvREAL_off(dbargs);
2392     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2393     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2394     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2395     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2396     sv_setiv(DBsingle, 0);
2397     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2398     sv_setiv(DBtrace, 0);
2399     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2400     sv_setiv(DBsignal, 0);
2401     curstash = defstash;
2402 }
2403
2404 #ifndef STRESS_REALLOC
2405 #define REASONABLE(size) (size)
2406 #else
2407 #define REASONABLE(size) (1) /* unreasonable */
2408 #endif
2409
2410 void
2411 init_stacks(ARGSproto)
2412 {
2413     curstack = newAV();
2414     mainstack = curstack;               /* remember in case we switch stacks */
2415     AvREAL_off(curstack);               /* not a real array */
2416     av_extend(curstack,REASONABLE(127));
2417
2418     stack_base = AvARRAY(curstack);
2419     stack_sp = stack_base;
2420     stack_max = stack_base + REASONABLE(127);
2421
2422     /* Use most of 8K. */
2423     cxstack_max = REASONABLE(8192 / sizeof(PERL_CONTEXT) - 2);
2424     New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
2425     cxstack_ix  = -1;
2426
2427     New(50,tmps_stack,REASONABLE(128),SV*);
2428     tmps_floor = -1;
2429     tmps_ix = -1;
2430     tmps_max = REASONABLE(128);
2431
2432     /*
2433      * The following stacks almost certainly should be per-interpreter,
2434      * but for now they're not.  XXX
2435      */
2436
2437     if (markstack) {
2438         markstack_ptr = markstack;
2439     } else {
2440         New(54,markstack,REASONABLE(32),I32);
2441         markstack_ptr = markstack;
2442         markstack_max = markstack + REASONABLE(32);
2443     }
2444
2445     if (scopestack) {
2446         scopestack_ix = 0;
2447     } else {
2448         New(54,scopestack,REASONABLE(32),I32);
2449         scopestack_ix = 0;
2450         scopestack_max = REASONABLE(32);
2451     }
2452
2453     if (savestack) {
2454         savestack_ix = 0;
2455     } else {
2456         New(54,savestack,REASONABLE(128),ANY);
2457         savestack_ix = 0;
2458         savestack_max = REASONABLE(128);
2459     }
2460
2461     if (retstack) {
2462         retstack_ix = 0;
2463     } else {
2464         New(54,retstack,REASONABLE(16),OP*);
2465         retstack_ix = 0;
2466         retstack_max = REASONABLE(16);
2467     }
2468 }
2469
2470 #undef REASONABLE
2471
2472 static void
2473 nuke_stacks(void)
2474 {
2475     dTHR;
2476     Safefree(cxstack);
2477     Safefree(tmps_stack);
2478     DEBUG( {
2479         Safefree(debname);
2480         Safefree(debdelim);
2481     } )
2482 }
2483
2484 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2485
2486 static void
2487 init_lexer(void)
2488 {
2489     tmpfp = rsfp;
2490     rsfp = Nullfp;
2491     lex_start(linestr);
2492     rsfp = tmpfp;
2493     subname = newSVpv("main",4);
2494 }
2495
2496 static void
2497 init_predump_symbols(void)
2498 {
2499     dTHR;
2500     GV *tmpgv;
2501     GV *othergv;
2502
2503     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2504     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2505     GvMULTI_on(stdingv);
2506     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2507     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2508     GvMULTI_on(tmpgv);
2509     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2510
2511     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2512     GvMULTI_on(tmpgv);
2513     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2514     setdefout(tmpgv);
2515     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2516     GvMULTI_on(tmpgv);
2517     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2518
2519     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2520     GvMULTI_on(othergv);
2521     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2522     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2523     GvMULTI_on(tmpgv);
2524     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2525
2526     statname = NEWSV(66,0);             /* last filename we did stat on */
2527
2528     if (!osname)
2529         osname = savepv(OSNAME);
2530 }
2531
2532 static void
2533 init_postdump_symbols(register int argc, register char **argv, register char **env)
2534 {
2535     dTHR;
2536     char *s;
2537     SV *sv;
2538     GV* tmpgv;
2539
2540     argc--,argv++;      /* skip name of script */
2541     if (doswitches) {
2542         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2543             if (!argv[0][1])
2544                 break;
2545             if (argv[0][1] == '-') {
2546                 argc--,argv++;
2547                 break;
2548             }
2549             if (s = strchr(argv[0], '=')) {
2550                 *s++ = '\0';
2551                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2552             }
2553             else
2554                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2555         }
2556     }
2557     toptarget = NEWSV(0,0);
2558     sv_upgrade(toptarget, SVt_PVFM);
2559     sv_setpvn(toptarget, "", 0);
2560     bodytarget = NEWSV(0,0);
2561     sv_upgrade(bodytarget, SVt_PVFM);
2562     sv_setpvn(bodytarget, "", 0);
2563     formtarget = bodytarget;
2564
2565     TAINT;
2566     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2567         sv_setpv(GvSV(tmpgv),origfilename);
2568         magicname("0", "0", 1);
2569     }
2570     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2571         sv_setpv(GvSV(tmpgv),origargv[0]);
2572     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2573         GvMULTI_on(argvgv);
2574         (void)gv_AVadd(argvgv);
2575         av_clear(GvAVn(argvgv));
2576         for (; argc > 0; argc--,argv++) {
2577             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2578         }
2579     }
2580     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2581         HV *hv;
2582         GvMULTI_on(envgv);
2583         hv = GvHVn(envgv);
2584         hv_magic(hv, envgv, 'E');
2585 #ifndef VMS  /* VMS doesn't have environ array */
2586         /* Note that if the supplied env parameter is actually a copy
2587            of the global environ then it may now point to free'd memory
2588            if the environment has been modified since. To avoid this
2589            problem we treat env==NULL as meaning 'use the default'
2590         */
2591         if (!env)
2592             env = environ;
2593         if (env != environ)
2594             environ[0] = Nullch;
2595         for (; *env; env++) {
2596             if (!(s = strchr(*env,'=')))
2597                 continue;
2598             *s++ = '\0';
2599 #if defined(WIN32) || defined(MSDOS)
2600             (void)strupr(*env);
2601 #endif
2602             sv = newSVpv(s--,0);
2603             (void)hv_store(hv, *env, s - *env, sv, 0);
2604             *s = '=';
2605 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2606             /* Sins of the RTL. See note in my_setenv(). */
2607             (void)PerlEnv_putenv(savepv(*env));
2608 #endif
2609         }
2610 #endif
2611 #ifdef DYNAMIC_ENV_FETCH
2612         HvNAME(hv) = savepv(ENV_HV_NAME);
2613 #endif
2614     }
2615     TAINT_NOT;
2616     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2617         sv_setiv(GvSV(tmpgv), (IV)getpid());
2618 }
2619
2620 static void
2621 init_perllib(void)
2622 {
2623     char *s;
2624     if (!tainting) {
2625 #ifndef VMS
2626         s = PerlEnv_getenv("PERL5LIB");
2627         if (s)
2628             incpush(s, TRUE);
2629         else
2630             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2631 #else /* VMS */
2632         /* Treat PERL5?LIB as a possible search list logical name -- the
2633          * "natural" VMS idiom for a Unix path string.  We allow each
2634          * element to be a set of |-separated directories for compatibility.
2635          */
2636         char buf[256];
2637         int idx = 0;
2638         if (my_trnlnm("PERL5LIB",buf,0))
2639             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2640         else
2641             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2642 #endif /* VMS */
2643     }
2644
2645 /* Use the ~-expanded versions of APPLLIB (undocumented),
2646     ARCHLIB PRIVLIB SITEARCH and SITELIB
2647 */
2648 #ifdef APPLLIB_EXP
2649     incpush(APPLLIB_EXP, FALSE);
2650 #endif
2651
2652 #ifdef ARCHLIB_EXP
2653     incpush(ARCHLIB_EXP, FALSE);
2654 #endif
2655 #ifndef PRIVLIB_EXP
2656 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2657 #endif
2658     incpush(PRIVLIB_EXP, FALSE);
2659
2660 #ifdef SITEARCH_EXP
2661     incpush(SITEARCH_EXP, FALSE);
2662 #endif
2663 #ifdef SITELIB_EXP
2664     incpush(SITELIB_EXP, FALSE);
2665 #endif
2666     if (!tainting)
2667         incpush(".", FALSE);
2668 }
2669
2670 #if defined(DOSISH)
2671 #    define PERLLIB_SEP ';'
2672 #else
2673 #  if defined(VMS)
2674 #    define PERLLIB_SEP '|'
2675 #  else
2676 #    define PERLLIB_SEP ':'
2677 #  endif
2678 #endif
2679 #ifndef PERLLIB_MANGLE
2680 #  define PERLLIB_MANGLE(s,n) (s)
2681 #endif
2682
2683 static void
2684 incpush(char *p, int addsubdirs)
2685 {
2686     SV *subdir = Nullsv;
2687     static char *archpat_auto;
2688
2689     if (!p)
2690         return;
2691
2692     if (addsubdirs) {
2693         subdir = NEWSV(55,0);
2694         if (!archpat_auto) {
2695             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2696                           + sizeof("//auto"));
2697             New(55, archpat_auto, len, char);
2698             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2699 #ifdef VMS
2700         for (len = sizeof(ARCHNAME) + 2;
2701              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2702                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2703 #endif
2704         }
2705     }
2706
2707     /* Break at all separators */
2708     while (p && *p) {
2709         SV *libdir = NEWSV(55,0);
2710         char *s;
2711
2712         /* skip any consecutive separators */
2713         while ( *p == PERLLIB_SEP ) {
2714             /* Uncomment the next line for PATH semantics */
2715             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2716             p++;
2717         }
2718
2719         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2720             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2721                       (STRLEN)(s - p));
2722             p = s + 1;
2723         }
2724         else {
2725             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2726             p = Nullch; /* break out */
2727         }
2728
2729         /*
2730          * BEFORE pushing libdir onto @INC we may first push version- and
2731          * archname-specific sub-directories.
2732          */
2733         if (addsubdirs) {
2734             struct stat tmpstatbuf;
2735 #ifdef VMS
2736             char *unix;
2737             STRLEN len;
2738
2739             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2740                 len = strlen(unix);
2741                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2742                 sv_usepvn(libdir,unix,len);
2743             }
2744             else
2745                 PerlIO_printf(PerlIO_stderr(),
2746                               "Failed to unixify @INC element \"%s\"\n",
2747                               SvPV(libdir,na));
2748 #endif
2749             /* .../archname/version if -d .../archname/version/auto */
2750             sv_setsv(subdir, libdir);
2751             sv_catpv(subdir, archpat_auto);
2752             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2753                   S_ISDIR(tmpstatbuf.st_mode))
2754                 av_push(GvAVn(incgv),
2755                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2756
2757             /* .../archname if -d .../archname/auto */
2758             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2759                       strlen(patchlevel) + 1, "", 0);
2760             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2761                   S_ISDIR(tmpstatbuf.st_mode))
2762                 av_push(GvAVn(incgv),
2763                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2764         }
2765
2766         /* finally push this lib directory on the end of @INC */
2767         av_push(GvAVn(incgv), libdir);
2768     }
2769
2770     SvREFCNT_dec(subdir);
2771 }
2772
2773 #ifdef USE_THREADS
2774 static struct perl_thread *
2775 init_main_thread()
2776 {
2777     struct perl_thread *thr;
2778     XPV *xpv;
2779
2780     Newz(53, thr, 1, struct perl_thread);
2781     curcop = &compiling;
2782     thr->cvcache = newHV();
2783     thr->threadsv = newAV();
2784     /* thr->threadsvp is set when find_threadsv is called */
2785     thr->specific = newAV();
2786     thr->errhv = newHV();
2787     thr->flags = THRf_R_JOINABLE;
2788     MUTEX_INIT(&thr->mutex);
2789     /* Handcraft thrsv similarly to mess_sv */
2790     New(53, thrsv, 1, SV);
2791     Newz(53, xpv, 1, XPV);
2792     SvFLAGS(thrsv) = SVt_PV;
2793     SvANY(thrsv) = (void*)xpv;
2794     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2795     SvPVX(thrsv) = (char*)thr;
2796     SvCUR_set(thrsv, sizeof(thr));
2797     SvLEN_set(thrsv, sizeof(thr));
2798     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2799     thr->oursv = thrsv;
2800     curcop = &compiling;
2801     chopset = " \n-";
2802
2803     MUTEX_LOCK(&threads_mutex);
2804     nthreads++;
2805     thr->tid = 0;
2806     thr->next = thr;
2807     thr->prev = thr;
2808     MUTEX_UNLOCK(&threads_mutex);
2809
2810 #ifdef HAVE_THREAD_INTERN
2811     init_thread_intern(thr);
2812 #endif
2813
2814 #ifdef SET_THREAD_SELF
2815     SET_THREAD_SELF(thr);
2816 #else
2817     thr->self = pthread_self();
2818 #endif /* SET_THREAD_SELF */
2819     SET_THR(thr);
2820
2821     /*
2822      * These must come after the SET_THR because sv_setpvn does
2823      * SvTAINT and the taint fields require dTHR.
2824      */
2825     toptarget = NEWSV(0,0);
2826     sv_upgrade(toptarget, SVt_PVFM);
2827     sv_setpvn(toptarget, "", 0);
2828     bodytarget = NEWSV(0,0);
2829     sv_upgrade(bodytarget, SVt_PVFM);
2830     sv_setpvn(bodytarget, "", 0);
2831     formtarget = bodytarget;
2832     thr->errsv = newSVpv("", 0);
2833     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2834     return thr;
2835 }
2836 #endif /* USE_THREADS */
2837
2838 void
2839 call_list(I32 oldscope, AV *list)
2840 {
2841     dTHR;
2842     line_t oldline = curcop->cop_line;
2843     STRLEN len;
2844     dJMPENV;
2845     int ret;
2846
2847     while (AvFILL(list) >= 0) {
2848         CV *cv = (CV*)av_shift(list);
2849
2850         SAVEFREESV(cv);
2851
2852         JMPENV_PUSH(ret);
2853         switch (ret) {
2854         case 0: {
2855                 SV* atsv = ERRSV;
2856                 PUSHMARK(stack_sp);
2857                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2858                 (void)SvPV(atsv, len);
2859                 if (len) {
2860                     JMPENV_POP;
2861                     curcop = &compiling;
2862                     curcop->cop_line = oldline;
2863                     if (list == beginav)
2864                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2865                     else
2866                         sv_catpv(atsv, "END failed--cleanup aborted");
2867                     while (scopestack_ix > oldscope)
2868                         LEAVE;
2869                     croak("%s", SvPVX(atsv));
2870                 }
2871             }
2872             break;
2873         case 1:
2874             STATUS_ALL_FAILURE;
2875             /* FALL THROUGH */
2876         case 2:
2877             /* my_exit() was called */
2878             while (scopestack_ix > oldscope)
2879                 LEAVE;
2880             FREETMPS;
2881             curstash = defstash;
2882             if (endav)
2883                 call_list(oldscope, endav);
2884             JMPENV_POP;
2885             curcop = &compiling;
2886             curcop->cop_line = oldline;
2887             if (statusvalue) {
2888                 if (list == beginav)
2889                     croak("BEGIN failed--compilation aborted");
2890                 else
2891                     croak("END failed--cleanup aborted");
2892             }
2893             my_exit_jump();
2894             /* NOTREACHED */
2895         case 3:
2896             if (!restartop) {
2897                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2898                 FREETMPS;
2899                 break;
2900             }
2901             JMPENV_POP;
2902             curcop = &compiling;
2903             curcop->cop_line = oldline;
2904             JMPENV_JUMP(3);
2905         }
2906         JMPENV_POP;
2907     }
2908 }
2909
2910 void
2911 my_exit(U32 status)
2912 {
2913     dTHR;
2914
2915 #ifdef USE_THREADS
2916     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2917                           thr, (unsigned long) status));
2918 #endif /* USE_THREADS */
2919     switch (status) {
2920     case 0:
2921         STATUS_ALL_SUCCESS;
2922         break;
2923     case 1:
2924         STATUS_ALL_FAILURE;
2925         break;
2926     default:
2927         STATUS_NATIVE_SET(status);
2928         break;
2929     }
2930     my_exit_jump();
2931 }
2932
2933 void
2934 my_failure_exit(void)
2935 {
2936 #ifdef VMS
2937     if (vaxc$errno & 1) {
2938         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2939             STATUS_NATIVE_SET(44);
2940     }
2941     else {
2942         if (!vaxc$errno && errno)       /* unlikely */
2943             STATUS_NATIVE_SET(44);
2944         else
2945             STATUS_NATIVE_SET(vaxc$errno);
2946     }
2947 #else
2948     if (errno & 255)
2949         STATUS_POSIX_SET(errno);
2950     else if (STATUS_POSIX == 0)
2951         STATUS_POSIX_SET(255);
2952 #endif
2953     my_exit_jump();
2954 }
2955
2956 static void
2957 my_exit_jump(void)
2958 {
2959     dTHR;
2960     register PERL_CONTEXT *cx;
2961     I32 gimme;
2962     SV **newsp;
2963
2964     if (e_tmpname) {
2965         if (e_fp) {
2966             PerlIO_close(e_fp);
2967             e_fp = Nullfp;
2968         }
2969         (void)UNLINK(e_tmpname);
2970         Safefree(e_tmpname);
2971         e_tmpname = Nullch;
2972     }
2973
2974     if (cxstack_ix >= 0) {
2975         if (cxstack_ix > 0)
2976             dounwind(0);
2977         POPBLOCK(cx,curpm);
2978         LEAVE;
2979     }
2980
2981     JMPENV_JUMP(2);
2982 }
2983
2984
2985