perl.c

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