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