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 ' ':
 672         case '0':
 673         case 'F':
 674         case 'a':
 675         case 'c':
 676         case 'd':
 677         case 'D':
 678         case 'h':
 679         case 'i':
 680         case 'l':
 681         case 'M':
 682         case 'm':
 683         case 'n':
 684         case 'p':
 685         case 's':
 686         case 'u':
 687         case 'U':
 688         case 'v':
 689         case 'w':
 690             if (s = moreswitches(s))
 691                 goto reswitch;
 692             break;
 693
 694         case 'T':
 695             tainting = TRUE;
 696             s++;
 697             goto reswitch;
 698
 699         case 'e':
 700             if (euid != uid || egid != gid)
 701                 croak("No -e allowed in setuid scripts");
 702             if (!e_fp) {
 703 #if defined(HAS_UMASK) && !defined(VMS)
 704                 int oldumask = PerlLIO_umask(0177);
 705 #endif
 706                 e_tmpname = savepv(TMPPATH);
 707 #ifdef HAS_MKSTEMP
 708                 e_tmpfd = PerlLIO_mkstemp(e_tmpname);
 709 #else /* use mktemp() */
 710                 (void)PerlLIO_mktemp(e_tmpname);
 711                 if (!*e_tmpname)
 712                     croak("Cannot generate temporary filename");
 713 # if defined(HAS_OPEN3) && defined(O_EXCL)
 714                 e_tmpfd = open(e_tmpname,
 715                                O_WRONLY | O_CREAT | O_EXCL,
 716                                0600);
 717 # else
 718                 (void)UNLINK(e_tmpname);
 719                 /* Yes, potential race.  But at least we can say we tried. */
 720                 e_fp = PerlIO_open(e_tmpname,"w");
 721 # endif
 722 #endif /* ifdef HAS_MKSTEMP */
 723 #if defined(HAS_MKSTEMP) || (defined(HAS_OPEN3) && defined(O_EXCL))
 724                 if (e_tmpfd < 0)
 725                     croak("Cannot create temporary file \"%s\"", e_tmpname);
 726                 e_fp = PerlIO_fdopen(e_tmpfd,"w");
 727 #endif
 728                 if (!e_fp)
 729                     croak("Cannot create temporary file \"%s\"", e_tmpname);
 730 #if defined(HAS_UMASK) && !defined(VMS)
 731                 (void)PerlLIO_umask(oldumask);
 732 #endif
 733             }
 734             if (*++s)
 735                 PerlIO_puts(e_fp,s);
 736             else if (argv[1]) {
 737                 PerlIO_puts(e_fp,argv[1]);
 738                 argc--,argv++;
 739             }
 740             else
 741                 croak("No code specified for -e");
 742             (void)PerlIO_putc(e_fp,'\n');
 743             break;
 744         case 'I':       /* -I handled both here and in moreswitches() */
 745             forbid_setid("-I");
 746             if (!*++s && (s=argv[1]) != Nullch) {
 747                 argc--,argv++;
 748             }
 749             while (s && isSPACE(*s))
 750                 ++s;
 751             if (s && *s) {
 752                 char *e, *p;
 753                 for (e = s; *e && !isSPACE(*e); e++) ;
 754                 p = savepvn(s, e-s);
 755                 incpush(p, TRUE);
 756                 sv_catpv(sv,"-I");
 757                 sv_catpv(sv,p);
 758                 sv_catpv(sv," ");
 759                 Safefree(p);
 760             }   /* XXX else croak? */
 761             break;
 762         case 'P':
 763             forbid_setid("-P");
 764             preprocess = TRUE;
 765             s++;
 766             goto reswitch;
 767         case 'S':
 768             forbid_setid("-S");
 769             dosearch = TRUE;
 770             s++;
 771             goto reswitch;
 772         case 'V':
 773             if (!preambleav)
 774                 preambleav = newAV();
 775             av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
 776             if (*++s != ':')  {
 777                 Sv = newSVpv("print myconfig();",0);
 778 #ifdef VMS
 779                 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
 780 #else
 781                 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 782 #endif
 783 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
 784                 sv_catpv(Sv,"\"  Compile-time options:");
 785 #  ifdef DEBUGGING
 786                 sv_catpv(Sv," DEBUGGING");
 787 #  endif
 788 #  ifdef NO_EMBED
 789                 sv_catpv(Sv," NO_EMBED");
 790 #  endif
 791 #  ifdef MULTIPLICITY
 792                 sv_catpv(Sv," MULTIPLICITY");
 793 #  endif
 794                 sv_catpv(Sv,"\\n\",");
 795 #endif
 796 #if defined(LOCAL_PATCH_COUNT)
 797                 if (LOCAL_PATCH_COUNT > 0) {
 798                     int i;
 799                     sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
 800                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
 801                         if (localpatches[i])
 802                             sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
 803                     }
 804                 }
 805 #endif
 806                 sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
 807 #ifdef __DATE__
 808 #  ifdef __TIME__
 809                 sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 810 #  else
 811                 sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
 812 #  endif
 813 #endif
 814                 sv_catpv(Sv, "; \
 815 $\"=\"\\n    \"; \
 816 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
 817 print \"  \\%ENV:\\n    @env\\n\" if @env; \
 818 print \"  \\@INC:\\n    @INC\\n\";");
 819             }
 820             else {
 821                 Sv = newSVpv("config_vars(qw(",0);
 822                 sv_catpv(Sv, ++s);
 823                 sv_catpv(Sv, "))");
 824                 s += strlen(s);
 825             }
 826             av_push(preambleav, Sv);
 827             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
 828             goto reswitch;
 829         case 'x':
 830             doextract = TRUE;
 831             s++;
 832             if (*s)
 833                 cddir = savepv(s);
 834             break;
 835         case 0:
 836             break;
 837         case '-':
 838             if (!*++s || isSPACE(*s)) {
 839                 argc--,argv++;
 840                 goto switch_end;
 841             }
 842             /* catch use of gnu style long options */
 843             if (strEQ(s, "version")) {
 844                 s = "v";
 845                 goto reswitch;
 846             }
 847             if (strEQ(s, "help")) {
 848                 s = "h";
 849                 goto reswitch;
 850             }
 851             s--;
 852             /* FALL THROUGH */
 853         default:
 854             croak("Unrecognized switch: -%s  (-h will show valid options)",s);
 855         }
 856     }
 857   switch_end:
 858
 859     if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
 860         while (s && *s) {
 861             while (isSPACE(*s))
 862                 s++;
 863             if (*s == '-') {
 864                 s++;
 865                 if (isSPACE(*s))
 866                     continue;
 867             }
 868             if (!*s)
 869                 break;
 870             if (!strchr("DIMUdmw", *s))
 871                 croak("Illegal switch in PERL5OPT: -%c", *s);
 872             s = moreswitches(s);
 873         }
 874     }
 875
 876     if (!scriptname)
 877         scriptname = argv[0];
 878     if (e_fp) {
 879         if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
 880 #ifndef MULTIPLICITY
 881             warn("Did you forget to compile with -DMULTIPLICITY?");
 882 #endif
 883             croak("Can't write to temp file for -e: %s", Strerror(errno));
 884         }
 885         e_fp = Nullfp;
 886         argc++,argv--;
 887         scriptname = e_tmpname;
 888     }
 889     else if (scriptname == Nullch) {
 890 #ifdef MSDOS
 891         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
 892             moreswitches("h");
 893 #endif
 894         scriptname = "-";
 895     }
 896
 897     init_perllib();
 898
 899     open_script(scriptname,dosearch,sv);
 900
 901     validate_suid(validarg, scriptname);
 902
 903     if (doextract)
 904         find_beginning();
 905
 906     main_cv = compcv = (CV*)NEWSV(1104,0);
 907     sv_upgrade((SV *)compcv, SVt_PVCV);
 908     CvUNIQUE_on(compcv);
 909
 910     comppad = newAV();
 911     av_push(comppad, Nullsv);
 912     curpad = AvARRAY(comppad);
 913     comppad_name = newAV();
 914     comppad_name_fill = 0;
 915     min_intro_pending = 0;
 916     padix = 0;
 917 #ifdef USE_THREADS
 918     av_store(comppad_name, 0, newSVpv("@_", 2));
 919     curpad[0] = (SV*)newAV();
 920     SvPADMY_on(curpad[0]);      /* XXX Needed? */
 921     CvOWNER(compcv) = 0;
 922     New(666, CvMUTEXP(compcv), 1, perl_mutex);
 923     MUTEX_INIT(CvMUTEXP(compcv));
 924 #endif /* USE_THREADS */
 925
 926     comppadlist = newAV();
 927     AvREAL_off(comppadlist);
 928     av_store(comppadlist, 0, (SV*)comppad_name);
 929     av_store(comppadlist, 1, (SV*)comppad);
 930     CvPADLIST(compcv) = comppadlist;
 931
 932     boot_core_UNIVERSAL();
 933     if (xsinit)
 934         (*xsinit)();    /* in case linked C routines want magical variables */
 935 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
 936     init_os_extras();
 937 #endif
 938
 939     init_predump_symbols();
 940     if (!do_undump)
 941         init_postdump_symbols(argc,argv,env);
 942
 943     init_lexer();
 944
 945     /* now parse the script */
 946
 947     SETERRNO(0,SS$_NORMAL);
 948     error_count = 0;
 949     if (yyparse() || error_count) {
 950         if (minus_c)
 951             croak("%s had compilation errors.\n", origfilename);
 952         else {
 953             croak("Execution of %s aborted due to compilation errors.\n",
 954                 origfilename);
 955         }
 956     }
 957     curcop->cop_line = 0;
 958     curstash = defstash;
 959     preprocess = FALSE;
 960     if (e_tmpname) {
 961         (void)UNLINK(e_tmpname);
 962         Safefree(e_tmpname);
 963         e_tmpname = Nullch;
 964         e_tmpfd = -1;
 965     }
 966
 967     /* now that script is parsed, we can modify record separator */
 968     SvREFCNT_dec(rs);
 969     rs = SvREFCNT_inc(nrs);
 970     sv_setsv(perl_get_sv("/", TRUE), rs);
 971     if (do_undump)
 972         my_unexec();
 973
 974     if (dowarn)
 975         gv_check(defstash);
 976
 977     LEAVE;
 978     FREETMPS;
 979
 980 #ifdef MYMALLOC
 981     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
 982         dump_mstats("after compilation:");
 983 #endif
 984
 985     ENTER;
 986     restartop = 0;
 987     JMPENV_POP;
 988     return 0;
 989 }
 990
 991 int
 992 perl_run(PerlInterpreter *sv_interp)
 993 {
 994     dSP;
 995     I32 oldscope;
 996     dJMPENV;
 997     int ret;
 998
 999     if (!(curinterp = sv_interp))
1000         return 255;
1001
1002     oldscope = scopestack_ix;
1003
1004     JMPENV_PUSH(ret);
1005     switch (ret) {
1006     case 1:
1007         cxstack_ix = -1;                /* start context stack again */
1008         break;
1009     case 2:
1010         /* my_exit() was called */
1011         while (scopestack_ix > oldscope)
1012             LEAVE;
1013         FREETMPS;
1014         curstash = defstash;
1015         if (endav)
1016             call_list(oldscope, endav);
1017 #ifdef MYMALLOC
1018         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1019             dump_mstats("after execution:  ");
1020 #endif
1021         JMPENV_POP;
1022         return STATUS_NATIVE_EXPORT;
1023     case 3:
1024         if (!restartop) {
1025             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1026             FREETMPS;
1027             JMPENV_POP;
1028             return 1;
1029         }
1030         POPSTACK_TO(mainstack);
1031         break;
1032     }
1033
1034     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1035                     sawampersand ? "Enabling" : "Omitting"));
1036
1037     if (!restartop) {
1038         DEBUG_x(dump_all());
1039         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1040 #ifdef USE_THREADS
1041         DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1042                               (unsigned long) thr));
1043 #endif /* USE_THREADS */
1044
1045         if (minus_c) {
1046             PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1047             my_exit(0);
1048         }
1049         if (PERLDB_SINGLE && DBsingle)
1050            sv_setiv(DBsingle, 1);
1051         if (initav)
1052             call_list(oldscope, initav);
1053     }
1054
1055     /* do it */
1056
1057     if (restartop) {
1058         op = restartop;
1059         restartop = 0;
1060         runops();
1061     }
1062     else if (main_start) {
1063         CvDEPTH(main_cv) = 1;
1064         op = main_start;
1065         runops();
1066     }
1067
1068     my_exit(0);
1069     /* NOTREACHED */
1070     return 0;
1071 }
1072
1073 SV*
1074 perl_get_sv(char *name, I32 create)
1075 {
1076     GV *gv;
1077 #ifdef USE_THREADS
1078     if (name[1] == '\0' && !isALPHA(name[0])) {
1079         PADOFFSET tmp = find_threadsv(name);
1080         if (tmp != NOT_IN_PAD) {
1081             dTHR;
1082             return THREADSV(tmp);
1083         }
1084     }
1085 #endif /* USE_THREADS */
1086     gv = gv_fetchpv(name, create, SVt_PV);
1087     if (gv)
1088         return GvSV(gv);
1089     return Nullsv;
1090 }
1091
1092 AV*
1093 perl_get_av(char *name, I32 create)
1094 {
1095     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1096     if (create)
1097         return GvAVn(gv);
1098     if (gv)
1099         return GvAV(gv);
1100     return Nullav;
1101 }
1102
1103 HV*
1104 perl_get_hv(char *name, I32 create)
1105 {
1106     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1107     if (create)
1108         return GvHVn(gv);
1109     if (gv)
1110         return GvHV(gv);
1111     return Nullhv;
1112 }
1113
1114 CV*
1115 perl_get_cv(char *name, I32 create)
1116 {
1117     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1118     if (create && !GvCVu(gv))
1119         return newSUB(start_subparse(FALSE, 0),
1120                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1121                       Nullop,
1122                       Nullop);
1123     if (gv)
1124         return GvCVu(gv);
1125     return Nullcv;
1126 }
1127
1128 /* Be sure to refetch the stack pointer after calling these routines. */
1129
1130 I32
1131 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1132
1133                         /* See G_* flags in cop.h */
1134                         /* null terminated arg list */
1135 {
1136     dSP;
1137
1138     PUSHMARK(SP);
1139     if (argv) {
1140         while (*argv) {
1141             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1142             argv++;
1143         }
1144         PUTBACK;
1145     }
1146     return perl_call_pv(sub_name, flags);
1147 }
1148
1149 I32
1150 perl_call_pv(char *sub_name, I32 flags)
1151                         /* name of the subroutine */
1152                         /* See G_* flags in cop.h */
1153 {
1154     return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1155 }
1156
1157 I32
1158 perl_call_method(char *methname, I32 flags)
1159                         /* name of the subroutine */
1160                         /* See G_* flags in cop.h */
1161 {
1162     dSP;
1163     OP myop;
1164     if (!op)
1165         op = &myop;
1166     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1167     PUTBACK;
1168     pp_method(ARGS);
1169     return perl_call_sv(*stack_sp--, flags);
1170 }
1171
1172 /* May be called with any of a CV, a GV, or an SV containing the name. */
1173 I32
1174 perl_call_sv(SV *sv, I32 flags)
1175
1176                         /* See G_* flags in cop.h */
1177 {
1178     dSP;
1179     LOGOP myop;         /* fake syntax tree node */
1180     I32 oldmark;
1181     I32 retval;
1182     I32 oldscope;
1183     static CV *DBcv;
1184     bool oldcatch = CATCH_GET;
1185     dJMPENV;
1186     int ret;
1187     OP* oldop = op;
1188
1189     if (flags & G_DISCARD) {
1190         ENTER;
1191         SAVETMPS;
1192     }
1193
1194     Zero(&myop, 1, LOGOP);
1195     myop.op_next = Nullop;
1196     if (!(flags & G_NOARGS))
1197         myop.op_flags |= OPf_STACKED;
1198     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1199                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1200                       OPf_WANT_SCALAR);
1201     SAVEOP();
1202     op = (OP*)&myop;
1203
1204     EXTEND(stack_sp, 1);
1205     *++stack_sp = sv;
1206     oldmark = TOPMARK;
1207     oldscope = scopestack_ix;
1208
1209     if (PERLDB_SUB && curstash != debstash
1210            /* Handle first BEGIN of -d. */
1211           && (DBcv || (DBcv = GvCV(DBsub)))
1212            /* Try harder, since this may have been a sighandler, thus
1213             * curstash may be meaningless. */
1214           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)
1215           && !(flags & G_NODEBUG))
1216         op->op_private |= OPpENTERSUB_DB;
1217
1218     if (flags & G_EVAL) {
1219         cLOGOP->op_other = op;
1220         markstack_ptr--;
1221         /* we're trying to emulate pp_entertry() here */
1222         {
1223             register PERL_CONTEXT *cx;
1224             I32 gimme = GIMME_V;
1225
1226             ENTER;
1227             SAVETMPS;
1228
1229             push_return(op->op_next);
1230             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1231             PUSHEVAL(cx, 0, 0);
1232             eval_root = op;             /* Only needed so that goto works right. */
1233
1234             in_eval = 1;
1235             if (flags & G_KEEPERR)
1236                 in_eval |= 4;
1237             else
1238                 sv_setpv(ERRSV,"");
1239         }
1240         markstack_ptr++;
1241
1242         JMPENV_PUSH(ret);
1243         switch (ret) {
1244         case 0:
1245             break;
1246         case 1:
1247             STATUS_ALL_FAILURE;
1248             /* FALL THROUGH */
1249         case 2:
1250             /* my_exit() was called */
1251             curstash = defstash;
1252             FREETMPS;
1253             JMPENV_POP;
1254             if (statusvalue)
1255                 croak("Callback called exit");
1256             my_exit_jump();
1257             /* NOTREACHED */
1258         case 3:
1259             if (restartop) {
1260                 op = restartop;
1261                 restartop = 0;
1262                 break;
1263             }
1264             stack_sp = stack_base + oldmark;
1265             if (flags & G_ARRAY)
1266                 retval = 0;
1267             else {
1268                 retval = 1;
1269                 *++stack_sp = &sv_undef;
1270             }
1271             goto cleanup;
1272         }
1273     }
1274     else
1275         CATCH_SET(TRUE);
1276
1277     if (op == (OP*)&myop)
1278         op = pp_entersub(ARGS);
1279     if (op)
1280         runops();
1281     retval = stack_sp - (stack_base + oldmark);
1282     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1283         sv_setpv(ERRSV,"");
1284
1285   cleanup:
1286     if (flags & G_EVAL) {
1287         if (scopestack_ix > oldscope) {
1288             SV **newsp;
1289             PMOP *newpm;
1290             I32 gimme;
1291             register PERL_CONTEXT *cx;
1292             I32 optype;
1293
1294             POPBLOCK(cx,newpm);
1295             POPEVAL(cx);
1296             pop_return();
1297             curpm = newpm;
1298             LEAVE;
1299         }
1300         JMPENV_POP;
1301     }
1302     else
1303         CATCH_SET(oldcatch);
1304
1305     if (flags & G_DISCARD) {
1306         stack_sp = stack_base + oldmark;
1307         retval = 0;
1308         FREETMPS;
1309         LEAVE;
1310     }
1311     op = oldop;
1312     return retval;
1313 }
1314
1315 /* Eval a string. The G_EVAL flag is always assumed. */
1316
1317 I32
1318 perl_eval_sv(SV *sv, I32 flags)
1319
1320                         /* See G_* flags in cop.h */
1321 {
1322     dSP;
1323     UNOP myop;          /* fake syntax tree node */
1324     I32 oldmark = SP - stack_base;
1325     I32 retval;
1326     I32 oldscope;
1327     dJMPENV;
1328     int ret;
1329     OP* oldop = op;
1330
1331     if (flags & G_DISCARD) {
1332         ENTER;
1333         SAVETMPS;
1334     }
1335
1336     SAVEOP();
1337     op = (OP*)&myop;
1338     Zero(op, 1, UNOP);
1339     EXTEND(stack_sp, 1);
1340     *++stack_sp = sv;
1341     oldscope = scopestack_ix;
1342
1343     if (!(flags & G_NOARGS))
1344         myop.op_flags = OPf_STACKED;
1345     myop.op_next = Nullop;
1346     myop.op_type = OP_ENTEREVAL;
1347     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1348                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1349                       OPf_WANT_SCALAR);
1350     if (flags & G_KEEPERR)
1351         myop.op_flags |= OPf_SPECIAL;
1352
1353     JMPENV_PUSH(ret);
1354     switch (ret) {
1355     case 0:
1356         break;
1357     case 1:
1358         STATUS_ALL_FAILURE;
1359         /* FALL THROUGH */
1360     case 2:
1361         /* my_exit() was called */
1362         curstash = defstash;
1363         FREETMPS;
1364         JMPENV_POP;
1365         if (statusvalue)
1366             croak("Callback called exit");
1367         my_exit_jump();
1368         /* NOTREACHED */
1369     case 3:
1370         if (restartop) {
1371             op = restartop;
1372             restartop = 0;
1373             break;
1374         }
1375         stack_sp = stack_base + oldmark;
1376         if (flags & G_ARRAY)
1377             retval = 0;
1378         else {
1379             retval = 1;
1380             *++stack_sp = &sv_undef;
1381         }
1382         goto cleanup;
1383     }
1384
1385     if (op == (OP*)&myop)
1386         op = pp_entereval(ARGS);
1387     if (op)
1388         runops();
1389     retval = stack_sp - (stack_base + oldmark);
1390     if (!(flags & G_KEEPERR))
1391         sv_setpv(ERRSV,"");
1392
1393   cleanup:
1394     JMPENV_POP;
1395     if (flags & G_DISCARD) {
1396         stack_sp = stack_base + oldmark;
1397         retval = 0;
1398         FREETMPS;
1399         LEAVE;
1400     }
1401     op = oldop;
1402     return retval;
1403 }
1404
1405 SV*
1406 perl_eval_pv(char *p, I32 croak_on_error)
1407 {
1408     dSP;
1409     SV* sv = newSVpv(p, 0);
1410
1411     PUSHMARK(SP);
1412     perl_eval_sv(sv, G_SCALAR);
1413     SvREFCNT_dec(sv);
1414
1415     SPAGAIN;
1416     sv = POPs;
1417     PUTBACK;
1418
1419     if (croak_on_error && SvTRUE(ERRSV))
1420         croak(SvPVx(ERRSV, na));
1421
1422     return sv;
1423 }
1424
1425 /* Require a module. */
1426
1427 void
1428 perl_require_pv(char *pv)
1429 {
1430     SV* sv = sv_newmortal();
1431     sv_setpv(sv, "require '");
1432     sv_catpv(sv, pv);
1433     sv_catpv(sv, "'");
1434     perl_eval_sv(sv, G_DISCARD);
1435 }
1436
1437 void
1438 magicname(char *sym, char *name, I32 namlen)
1439 {
1440     register GV *gv;
1441
1442     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1443         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1444 }
1445
1446 static void
1447 usage(char *name)               /* XXX move this out into a module ? */
1448
1449 {
1450     /* This message really ought to be max 23 lines.
1451      * Removed -h because the user already knows that opton. Others? */
1452
1453     static char *usage[] = {
1454 "-0[octal]       specify record separator (\\0, if no argument)",
1455 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1456 "-c              check syntax only (runs BEGIN and END blocks)",
1457 "-d[:debugger]   run scripts under debugger",
1458 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1459 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1460 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1461 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1462 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1463 "-l[octal]       enable line ending processing, specifies line terminator",
1464 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1465 "-n              assume 'while (<>) { ... }' loop around your script",
1466 "-p              assume loop like -n but print line also like sed",
1467 "-P              run script through C preprocessor before compilation",
1468 "-s              enable some switch parsing for switches after script name",
1469 "-S              look for the script using PATH environment variable",
1470 "-T              turn on tainting checks",
1471 "-u              dump core after parsing script",
1472 "-U              allow unsafe operations",
1473 "-v              print version number, patchlevel plus VERY IMPORTANT perl info",
1474 "-V[:variable]   print perl configuration information",
1475 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1476 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1477 "\n",
1478 NULL
1479 };
1480     char **p = usage;
1481
1482     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1483     while (*p)
1484         printf("\n  %s", *p++);
1485 }
1486
1487 /* This routine handles any switches that can be given during run */
1488
1489 char *
1490 moreswitches(char *s)
1491 {
1492     I32 numlen;
1493     U32 rschar;
1494
1495     switch (*s) {
1496     case '0':
1497     {
1498         dTHR;
1499         rschar = scan_oct(s, 4, &numlen);
1500         SvREFCNT_dec(nrs);
1501         if (rschar & ~((U8)~0))
1502             nrs = &sv_undef;
1503         else if (!rschar && numlen >= 2)
1504             nrs = newSVpv("", 0);
1505         else {
1506             char ch = rschar;
1507             nrs = newSVpv(&ch, 1);
1508         }
1509         return s + numlen;
1510     }
1511     case 'F':
1512         minus_F = TRUE;
1513         splitstr = savepv(s + 1);
1514         s += strlen(s);
1515         return s;
1516     case 'a':
1517         minus_a = TRUE;
1518         s++;
1519         return s;
1520     case 'c':
1521         minus_c = TRUE;
1522         s++;
1523         return s;
1524     case 'd':
1525         forbid_setid("-d");
1526         s++;
1527         if (*s == ':' || *s == '=')  {
1528             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1529             s += strlen(s);
1530         }
1531         if (!perldb) {
1532             perldb = PERLDB_ALL;
1533             init_debugger();
1534         }
1535         return s;
1536     case 'D':
1537 #ifdef DEBUGGING
1538         forbid_setid("-D");
1539         if (isALPHA(s[1])) {
1540             static char debopts[] = "psltocPmfrxuLHXD";
1541             char *d;
1542
1543             for (s++; *s && (d = strchr(debopts,*s)); s++)
1544                 debug |= 1 << (d - debopts);
1545         }
1546         else {
1547             debug = atoi(s+1);
1548             for (s++; isDIGIT(*s); s++) ;
1549         }
1550         debug |= 0x80000000;
1551 #else
1552         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1553         for (s++; isALNUM(*s); s++) ;
1554 #endif
1555         /*SUPPRESS 530*/
1556         return s;
1557     case 'h':
1558         usage(origargv[0]);
1559         PerlProc_exit(0);
1560     case 'i':
1561         if (inplace)
1562             Safefree(inplace);
1563         inplace = savepv(s+1);
1564         /*SUPPRESS 530*/
1565         for (s = inplace; *s && !isSPACE(*s); s++) ;
1566         if (*s) {
1567             *s++ = '\0';
1568             if (*s == '-')      /* Additional switches on #! line. */
1569                 s++;
1570         }
1571         return s;
1572     case 'I':   /* -I handled both here and in parse_perl() */
1573         forbid_setid("-I");
1574         ++s;
1575         while (*s && isSPACE(*s))
1576             ++s;
1577         if (*s) {
1578             char *e, *p;
1579             for (e = s; *e && !isSPACE(*e); e++) ;
1580             p = savepvn(s, e-s);
1581             incpush(p, TRUE);
1582             Safefree(p);
1583             s = e;
1584         }
1585         else
1586             croak("No space allowed after -I");
1587         return s;
1588     case 'l':
1589         minus_l = TRUE;
1590         s++;
1591         if (ors)
1592             Safefree(ors);
1593         if (isDIGIT(*s)) {
1594             ors = savepv("\n");
1595             orslen = 1;
1596             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1597             s += numlen;
1598         }
1599         else {
1600             dTHR;
1601             if (RsPARA(nrs)) {
1602                 ors = "\n\n";
1603                 orslen = 2;
1604             }
1605             else
1606                 ors = SvPV(nrs, orslen);
1607             ors = savepvn(ors, orslen);
1608         }
1609         return s;
1610     case 'M':
1611         forbid_setid("-M");     /* XXX ? */
1612         /* FALL THROUGH */
1613     case 'm':
1614         forbid_setid("-m");     /* XXX ? */
1615         if (*++s) {
1616             char *start;
1617             SV *sv;
1618             char *use = "use ";
1619             /* -M-foo == 'no foo'       */
1620             if (*s == '-') { use = "no "; ++s; }
1621             sv = newSVpv(use,0);
1622             start = s;
1623             /* We allow -M'Module qw(Foo Bar)'  */
1624             while(isALNUM(*s) || *s==':') ++s;
1625             if (*s != '=') {
1626                 sv_catpv(sv, start);
1627                 if (*(start-1) == 'm') {
1628                     if (*s != '\0')
1629                         croak("Can't use '%c' after -mname", *s);
1630                     sv_catpv( sv, " ()");
1631                 }
1632             } else {
1633                 sv_catpvn(sv, start, s-start);
1634                 sv_catpv(sv, " split(/,/,q{");
1635                 sv_catpv(sv, ++s);
1636                 sv_catpv(sv,    "})");
1637             }
1638             s += strlen(s);
1639             if (preambleav == NULL)
1640                 preambleav = newAV();
1641             av_push(preambleav, sv);
1642         }
1643         else
1644             croak("No space allowed after -%c", *(s-1));
1645         return s;
1646     case 'n':
1647         minus_n = TRUE;
1648         s++;
1649         return s;
1650     case 'p':
1651         minus_p = TRUE;
1652         s++;
1653         return s;
1654     case 's':
1655         forbid_setid("-s");
1656         doswitches = TRUE;
1657         s++;
1658         return s;
1659     case 'T':
1660         if (!tainting)
1661             croak("Too late for \"-T\" option");
1662         s++;
1663         return s;
1664     case 'u':
1665         do_undump = TRUE;
1666         s++;
1667         return s;
1668     case 'U':
1669         unsafe = TRUE;
1670         s++;
1671         return s;
1672     case 'v':
1673 #if defined(SUBVERSION) && SUBVERSION > 0
1674         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1675             PATCHLEVEL, SUBVERSION, ARCHNAME);
1676 #else
1677         printf("\nThis is perl, version %s built for %s",
1678                 patchlevel, ARCHNAME);
1679 #endif
1680 #if defined(LOCAL_PATCH_COUNT)
1681         if (LOCAL_PATCH_COUNT > 0)
1682             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1683                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1684 #endif
1685
1686         printf("\n\nCopyright 1987-1998, Larry Wall\n");
1687 #ifdef MSDOS
1688         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1689 #endif
1690 #ifdef DJGPP
1691         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1692         printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1693 #endif
1694 #ifdef OS2
1695         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1696             "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1697 #endif
1698 #ifdef atarist
1699         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1700 #endif
1701         printf("\n\
1702 Perl may be copied only under the terms of either the Artistic License or the\n\
1703 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1704 Complete documentation for Perl, including FAQ lists, should be found on\n\
1705 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
1706 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1707         PerlProc_exit(0);
1708     case 'w':
1709         dowarn = TRUE;
1710         s++;
1711         return s;
1712     case '*':
1713     case ' ':
1714         if (s[1] == '-')        /* Additional switches on #! line. */
1715             return s+2;
1716         break;
1717     case '-':
1718     case 0:
1719 #ifdef WIN32
1720     case '\r':
1721 #endif
1722     case '\n':
1723     case '\t':
1724         break;
1725 #ifdef ALTERNATE_SHEBANG
1726     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1727         break;
1728 #endif
1729     case 'P':
1730         if (preprocess)
1731             return s+1;
1732         /* FALL THROUGH */
1733     default:
1734         croak("Can't emulate -%.1s on #! line",s);
1735     }
1736     return Nullch;
1737 }
1738
1739 /* compliments of Tom Christiansen */
1740
1741 /* unexec() can be found in the Gnu emacs distribution */
1742 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1743
1744 void
1745 my_unexec(void)
1746 {
1747 #ifdef UNEXEC
1748     SV*    prog;
1749     SV*    file;
1750     int    status = 1;
1751     extern int etext;
1752
1753     prog = newSVpv(BIN_EXP, 0);
1754     sv_catpv(prog, "/perl");
1755     file = newSVpv(origfilename, 0);
1756     sv_catpv(file, ".perldump");
1757
1758     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1759     /* unexec prints msg to stderr in case of failure */
1760     PerlProc_exit(status);
1761 #else
1762 #  ifdef VMS
1763 #    include <lib$routines.h>
1764      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1765 #  else
1766     ABORT();            /* for use with undump */
1767 #  endif
1768 #endif
1769 }
1770
1771 static void
1772 init_main_stash(void)
1773 {
1774     dTHR;
1775     GV *gv;
1776
1777     /* Note that strtab is a rather special HV.  Assumptions are made
1778        about not iterating on it, and not adding tie magic to it.
1779        It is properly deallocated in perl_destruct() */
1780     strtab = newHV();
1781     HvSHAREKEYS_off(strtab);                    /* mandatory */
1782     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1783          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1784
1785     curstash = defstash = newHV();
1786     curstname = newSVpv("main",4);
1787     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1788     SvREFCNT_dec(GvHV(gv));
1789     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1790     SvREADONLY_on(gv);
1791     HvNAME(defstash) = savepv("main");
1792     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1793     GvMULTI_on(incgv);
1794     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1795     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1796     GvMULTI_on(errgv);
1797     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1798     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1799     sv_setpvn(ERRSV, "", 0);
1800     curstash = defstash;
1801     compiling.cop_stash = defstash;
1802     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1803     globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1804     /* We must init $/ before switches are processed. */
1805     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1806 }
1807
1808 static void
1809 open_script(char *scriptname, bool dosearch, SV *sv)
1810 {
1811     dTHR;
1812     register char *s;
1813
1814     scriptname = find_script(scriptname, dosearch, NULL, 0);
1815
1816     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1817         char *s = scriptname + 8;
1818         fdscript = atoi(s);
1819         while (isDIGIT(*s))
1820             s++;
1821         if (*s)
1822             scriptname = s + 1;
1823     }
1824     else
1825         fdscript = -1;
1826     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1827     curcop->cop_filegv = gv_fetchfile(origfilename);
1828     if (strEQ(origfilename,"-"))
1829         scriptname = "";
1830     if (fdscript >= 0) {
1831         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1832 #if defined(HAS_FCNTL) && defined(F_SETFD)
1833         if (rsfp)
1834             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1835 #endif
1836     }
1837     else if (preprocess) {
1838         char *cpp_cfg = CPPSTDIN;
1839         SV *cpp = NEWSV(0,0);
1840         SV *cmd = NEWSV(0,0);
1841
1842         if (strEQ(cpp_cfg, "cppstdin"))
1843             sv_catpvf(cpp, "%s/", BIN_EXP);
1844         sv_catpv(cpp, cpp_cfg);
1845
1846         sv_catpv(sv,"-I");
1847         sv_catpv(sv,PRIVLIB_EXP);
1848
1849 #ifdef MSDOS
1850         sv_setpvf(cmd, "\
1851 sed %s -e \"/^[^#]/b\" \
1852  -e \"/^#[      ]*include[      ]/b\" \
1853  -e \"/^#[      ]*define[       ]/b\" \
1854  -e \"/^#[      ]*if[   ]/b\" \
1855  -e \"/^#[      ]*ifdef[        ]/b\" \
1856  -e \"/^#[      ]*ifndef[       ]/b\" \
1857  -e \"/^#[      ]*else/b\" \
1858  -e \"/^#[      ]*elif[         ]/b\" \
1859  -e \"/^#[      ]*undef[        ]/b\" \
1860  -e \"/^#[      ]*endif/b\" \
1861  -e \"s/^#.*//\" \
1862  %s | %_ -C %_ %s",
1863           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1864 #else
1865         sv_setpvf(cmd, "\
1866 %s %s -e '/^[^#]/b' \
1867  -e '/^#[       ]*include[      ]/b' \
1868  -e '/^#[       ]*define[       ]/b' \
1869  -e '/^#[       ]*if[   ]/b' \
1870  -e '/^#[       ]*ifdef[        ]/b' \
1871  -e '/^#[       ]*ifndef[       ]/b' \
1872  -e '/^#[       ]*else/b' \
1873  -e '/^#[       ]*elif[         ]/b' \
1874  -e '/^#[       ]*undef[        ]/b' \
1875  -e '/^#[       ]*endif/b' \
1876  -e 's/^[       ]*#.*//' \
1877  %s | %_ -C %_ %s",
1878 #ifdef LOC_SED
1879           LOC_SED,
1880 #else
1881           "sed",
1882 #endif
1883           (doextract ? "-e '1,/^#/d\n'" : ""),
1884 #endif
1885           scriptname, cpp, sv, CPPMINUS);
1886         doextract = FALSE;
1887 #ifdef IAMSUID                          /* actually, this is caught earlier */
1888         if (euid != uid && !euid) {     /* if running suidperl */
1889 #ifdef HAS_SETEUID
1890             (void)seteuid(uid);         /* musn't stay setuid root */
1891 #else
1892 #ifdef HAS_SETREUID
1893             (void)setreuid((Uid_t)-1, uid);
1894 #else
1895 #ifdef HAS_SETRESUID
1896             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1897 #else
1898             setuid(uid);
1899 #endif
1900 #endif
1901 #endif
1902             if (geteuid() != uid)
1903                 croak("Can't do seteuid!\n");
1904         }
1905 #endif /* IAMSUID */
1906         rsfp = PerlProc_popen(SvPVX(cmd), "r");
1907         SvREFCNT_dec(cmd);
1908         SvREFCNT_dec(cpp);
1909     }
1910     else if (!*scriptname) {
1911         forbid_setid("program input from stdin");
1912         rsfp = PerlIO_stdin();
1913     }
1914     else {
1915         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1916 #if defined(HAS_FCNTL) && defined(F_SETFD)
1917         if (rsfp)
1918             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1919 #endif
1920     }
1921     if (e_tmpname) {
1922         e_fp = rsfp;
1923     }
1924     if (!rsfp) {
1925 #ifdef DOSUID
1926 #ifndef IAMSUID         /* in case script is not readable before setuid */
1927         if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1928           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1929             /* try again */
1930             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1931             croak("Can't do setuid\n");
1932         }
1933 #endif
1934 #endif
1935         croak("Can't open perl script \"%s\": %s\n",
1936           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1937     }
1938 }
1939
1940 static void
1941 validate_suid(char *validarg, char *scriptname)
1942 {
1943     int which;
1944
1945     /* do we need to emulate setuid on scripts? */
1946
1947     /* This code is for those BSD systems that have setuid #! scripts disabled
1948      * in the kernel because of a security problem.  Merely defining DOSUID
1949      * in perl will not fix that problem, but if you have disabled setuid
1950      * scripts in the kernel, this will attempt to emulate setuid and setgid
1951      * on scripts that have those now-otherwise-useless bits set.  The setuid
1952      * root version must be called suidperl or sperlN.NNN.  If regular perl
1953      * discovers that it has opened a setuid script, it calls suidperl with
1954      * the same argv that it had.  If suidperl finds that the script it has
1955      * just opened is NOT setuid root, it sets the effective uid back to the
1956      * uid.  We don't just make perl setuid root because that loses the
1957      * effective uid we had before invoking perl, if it was different from the
1958      * uid.
1959      *
1960      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1961      * be defined in suidperl only.  suidperl must be setuid root.  The
1962      * Configure script will set this up for you if you want it.
1963      */
1964
1965 #ifdef DOSUID
1966     dTHR;
1967     char *s, *s2;
1968
1969     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
1970         croak("Can't stat script \"%s\"",origfilename);
1971     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1972         I32 len;
1973
1974 #ifdef IAMSUID
1975 #ifndef HAS_SETREUID
1976         /* On this access check to make sure the directories are readable,
1977          * there is actually a small window that the user could use to make
1978          * filename point to an accessible directory.  So there is a faint
1979          * chance that someone could execute a setuid script down in a
1980          * non-accessible directory.  I don't know what to do about that.
1981          * But I don't think it's too important.  The manual lies when
1982          * it says access() is useful in setuid programs.
1983          */
1984         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1985             croak("Permission denied");
1986 #else
1987         /* If we can swap euid and uid, then we can determine access rights
1988          * with a simple stat of the file, and then compare device and
1989          * inode to make sure we did stat() on the same file we opened.
1990          * Then we just have to make sure he or she can execute it.
1991          */
1992         {
1993             struct stat tmpstatbuf;
1994
1995             if (
1996 #ifdef HAS_SETREUID
1997                 setreuid(euid,uid) < 0
1998 #else
1999 # if HAS_SETRESUID
2000                 setresuid(euid,uid,(Uid_t)-1) < 0
2001 # endif
2002 #endif
2003                 || getuid() != euid || geteuid() != uid)
2004                 croak("Can't swap uid and euid");       /* really paranoid */
2005             if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2006                 croak("Permission denied");     /* testing full pathname here */
2007             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2008                 tmpstatbuf.st_ino != statbuf.st_ino) {
2009                 (void)PerlIO_close(rsfp);
2010                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2011                     PerlIO_printf(rsfp,
2012 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2013 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2014                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2015                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2016                         SvPVX(GvSV(curcop->cop_filegv)),
2017                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2018                     (void)PerlProc_pclose(rsfp);
2019                 }
2020                 croak("Permission denied\n");
2021             }
2022             if (
2023 #ifdef HAS_SETREUID
2024               setreuid(uid,euid) < 0
2025 #else
2026 # if defined(HAS_SETRESUID)
2027               setresuid(uid,euid,(Uid_t)-1) < 0
2028 # endif
2029 #endif
2030               || getuid() != uid || geteuid() != euid)
2031                 croak("Can't reswap uid and euid");
2032             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2033                 croak("Permission denied\n");
2034         }
2035 #endif /* HAS_SETREUID */
2036 #endif /* IAMSUID */
2037
2038         if (!S_ISREG(statbuf.st_mode))
2039             croak("Permission denied");
2040         if (statbuf.st_mode & S_IWOTH)
2041             croak("Setuid/gid script is writable by world");
2042         doswitches = FALSE;             /* -s is insecure in suid */
2043         curcop->cop_line++;
2044         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2045           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2046             croak("No #! line");
2047         s = SvPV(linestr,na)+2;
2048         if (*s == ' ') s++;
2049         while (!isSPACE(*s)) s++;
2050         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2051                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2052         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2053             croak("Not a perl script");
2054         while (*s == ' ' || *s == '\t') s++;
2055         /*
2056          * #! arg must be what we saw above.  They can invoke it by
2057          * mentioning suidperl explicitly, but they may not add any strange
2058          * arguments beyond what #! says if they do invoke suidperl that way.
2059          */
2060         len = strlen(validarg);
2061         if (strEQ(validarg," PHOOEY ") ||
2062             strnNE(s,validarg,len) || !isSPACE(s[len]))
2063             croak("Args must match #! line");
2064
2065 #ifndef IAMSUID
2066         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2067             euid == statbuf.st_uid)
2068             if (!do_undump)
2069                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2070 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2071 #endif /* IAMSUID */
2072
2073         if (euid) {     /* oops, we're not the setuid root perl */
2074             (void)PerlIO_close(rsfp);
2075 #ifndef IAMSUID
2076             /* try again */
2077             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2078 #endif
2079             croak("Can't do setuid\n");
2080         }
2081
2082         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2083 #ifdef HAS_SETEGID
2084             (void)setegid(statbuf.st_gid);
2085 #else
2086 #ifdef HAS_SETREGID
2087            (void)setregid((Gid_t)-1,statbuf.st_gid);
2088 #else
2089 #ifdef HAS_SETRESGID
2090            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2091 #else
2092             setgid(statbuf.st_gid);
2093 #endif
2094 #endif
2095 #endif
2096             if (getegid() != statbuf.st_gid)
2097                 croak("Can't do setegid!\n");
2098         }
2099         if (statbuf.st_mode & S_ISUID) {
2100             if (statbuf.st_uid != euid)
2101 #ifdef HAS_SETEUID
2102                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2103 #else
2104 #ifdef HAS_SETREUID
2105                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2106 #else
2107 #ifdef HAS_SETRESUID
2108                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2109 #else
2110                 setuid(statbuf.st_uid);
2111 #endif
2112 #endif
2113 #endif
2114             if (geteuid() != statbuf.st_uid)
2115                 croak("Can't do seteuid!\n");
2116         }
2117         else if (uid) {                 /* oops, mustn't run as root */
2118 #ifdef HAS_SETEUID
2119           (void)seteuid((Uid_t)uid);
2120 #else
2121 #ifdef HAS_SETREUID
2122           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2123 #else
2124 #ifdef HAS_SETRESUID
2125           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2126 #else
2127           setuid((Uid_t)uid);
2128 #endif
2129 #endif
2130 #endif
2131             if (geteuid() != uid)
2132                 croak("Can't do seteuid!\n");
2133         }
2134         init_ids();
2135         if (!cando(S_IXUSR,TRUE,&statbuf))
2136             croak("Permission denied\n");       /* they can't do this */
2137     }
2138 #ifdef IAMSUID
2139     else if (preprocess)
2140         croak("-P not allowed for setuid/setgid script\n");
2141     else if (fdscript >= 0)
2142         croak("fd script not allowed in suidperl\n");
2143     else
2144         croak("Script is not setuid/setgid in suidperl\n");
2145
2146     /* We absolutely must clear out any saved ids here, so we */
2147     /* exec the real perl, substituting fd script for scriptname. */
2148     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2149     PerlIO_rewind(rsfp);
2150     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2151     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2152     if (!origargv[which])
2153         croak("Permission denied");
2154     origargv[which] = savepv(form("/dev/fd/%d/%s",
2155                                   PerlIO_fileno(rsfp), origargv[which]));
2156 #if defined(HAS_FCNTL) && defined(F_SETFD)
2157     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2158 #endif
2159     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2160     croak("Can't do setuid\n");
2161 #endif /* IAMSUID */
2162 #else /* !DOSUID */
2163     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2164 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2165         dTHR;
2166         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2167         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2168             ||
2169             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2170            )
2171             if (!do_undump)
2172                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2173 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2174 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2175         /* not set-id, must be wrapped */
2176     }
2177 #endif /* DOSUID */
2178 }
2179
2180 static void
2181 find_beginning(void)
2182 {
2183     register char *s, *s2;
2184
2185     /* skip forward in input to the real script? */
2186
2187     forbid_setid("-x");
2188     while (doextract) {
2189         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2190             croak("No Perl script found in input\n");
2191         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2192             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2193             doextract = FALSE;
2194             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2195             s2 = s;
2196             while (*s == ' ' || *s == '\t') s++;
2197             if (*s++ == '-') {
2198                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2199                 if (strnEQ(s2-4,"perl",4))
2200                     /*SUPPRESS 530*/
2201                     while (s = moreswitches(s)) ;
2202             }
2203             if (cddir && PerlDir_chdir(cddir) < 0)
2204                 croak("Can't chdir to %s",cddir);
2205         }
2206     }
2207 }
2208
2209 static void
2210 init_ids(void)
2211 {
2212     uid = (int)getuid();
2213     euid = (int)geteuid();
2214     gid = (int)getgid();
2215     egid = (int)getegid();
2216 #ifdef VMS
2217     uid |= gid << 16;
2218     euid |= egid << 16;
2219 #endif
2220     tainting |= (uid && (euid != uid || egid != gid));
2221 }
2222
2223 static void
2224 forbid_setid(char *s)
2225 {
2226     if (euid != uid)
2227         croak("No %s allowed while running setuid", s);
2228     if (egid != gid)
2229         croak("No %s allowed while running setgid", s);
2230 }
2231
2232 static void
2233 init_debugger(void)
2234 {
2235     dTHR;
2236     curstash = debstash;
2237     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2238     AvREAL_off(dbargs);
2239     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2240     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2241     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2242     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2243     sv_setiv(DBsingle, 0);
2244     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2245     sv_setiv(DBtrace, 0);
2246     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2247     sv_setiv(DBsignal, 0);
2248     curstash = defstash;
2249 }
2250
2251 #ifndef STRESS_REALLOC
2252 #define REASONABLE(size) (size)
2253 #else
2254 #define REASONABLE(size) (1) /* unreasonable */
2255 #endif
2256
2257 void
2258 init_stacks(ARGSproto)
2259 {
2260     /* start with 128-item stack and 8K cxstack */
2261     curstackinfo = new_stackinfo(REASONABLE(128),
2262                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2263     curstackinfo->si_type = SI_MAIN;
2264     curstack = curstackinfo->si_stack;
2265     mainstack = curstack;               /* remember in case we switch stacks */
2266
2267     stack_base = AvARRAY(curstack);
2268     stack_sp = stack_base;
2269     stack_max = stack_base + AvMAX(curstack);
2270
2271     New(50,tmps_stack,REASONABLE(128),SV*);
2272     tmps_floor = -1;
2273     tmps_ix = -1;
2274     tmps_max = REASONABLE(128);
2275
2276     /*
2277      * The following stacks almost certainly should be per-interpreter,
2278      * but for now they're not.  XXX
2279      */
2280
2281     if (markstack) {
2282         markstack_ptr = markstack;
2283     } else {
2284         New(54,markstack,REASONABLE(32),I32);
2285         markstack_ptr = markstack;
2286         markstack_max = markstack + REASONABLE(32);
2287     }
2288
2289     SET_MARKBASE;
2290
2291     if (scopestack) {
2292         scopestack_ix = 0;
2293     } else {
2294         New(54,scopestack,REASONABLE(32),I32);
2295         scopestack_ix = 0;
2296         scopestack_max = REASONABLE(32);
2297     }
2298
2299     if (savestack) {
2300         savestack_ix = 0;
2301     } else {
2302         New(54,savestack,REASONABLE(128),ANY);
2303         savestack_ix = 0;
2304         savestack_max = REASONABLE(128);
2305     }
2306
2307     if (retstack) {
2308         retstack_ix = 0;
2309     } else {
2310         New(54,retstack,REASONABLE(16),OP*);
2311         retstack_ix = 0;
2312         retstack_max = REASONABLE(16);
2313     }
2314 }
2315
2316 #undef REASONABLE
2317
2318 static void
2319 nuke_stacks(void)
2320 {
2321     dTHR;
2322     while (curstackinfo->si_next)
2323         curstackinfo = curstackinfo->si_next;
2324     while (curstackinfo) {
2325         PERL_SI *p = curstackinfo->si_prev;
2326         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2327         Safefree(curstackinfo->si_cxstack);
2328         Safefree(curstackinfo);
2329         curstackinfo = p;
2330     }
2331     Safefree(tmps_stack);
2332     DEBUG( {
2333         Safefree(debname);
2334         Safefree(debdelim);
2335     } )
2336 }
2337
2338 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2339
2340 static void
2341 init_lexer(void)
2342 {
2343     tmpfp = rsfp;
2344     rsfp = Nullfp;
2345     lex_start(linestr);
2346     rsfp = tmpfp;
2347     subname = newSVpv("main",4);
2348 }
2349
2350 static void
2351 init_predump_symbols(void)
2352 {
2353     dTHR;
2354     GV *tmpgv;
2355     GV *othergv;
2356
2357     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2358     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2359     GvMULTI_on(stdingv);
2360     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2361     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2362     GvMULTI_on(tmpgv);
2363     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2364
2365     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2366     GvMULTI_on(tmpgv);
2367     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2368     setdefout(tmpgv);
2369     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2370     GvMULTI_on(tmpgv);
2371     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2372
2373     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2374     GvMULTI_on(othergv);
2375     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2376     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2377     GvMULTI_on(tmpgv);
2378     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2379
2380     statname = NEWSV(66,0);             /* last filename we did stat on */
2381
2382     if (!osname)
2383         osname = savepv(OSNAME);
2384 }
2385
2386 static void
2387 init_postdump_symbols(register int argc, register char **argv, register char **env)
2388 {
2389     dTHR;
2390     char *s;
2391     SV *sv;
2392     GV* tmpgv;
2393
2394     argc--,argv++;      /* skip name of script */
2395     if (doswitches) {
2396         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2397             if (!argv[0][1])
2398                 break;
2399             if (argv[0][1] == '-') {
2400                 argc--,argv++;
2401                 break;
2402             }
2403             if (s = strchr(argv[0], '=')) {
2404                 *s++ = '\0';
2405                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2406             }
2407             else
2408                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2409         }
2410     }
2411     toptarget = NEWSV(0,0);
2412     sv_upgrade(toptarget, SVt_PVFM);
2413     sv_setpvn(toptarget, "", 0);
2414     bodytarget = NEWSV(0,0);
2415     sv_upgrade(bodytarget, SVt_PVFM);
2416     sv_setpvn(bodytarget, "", 0);
2417     formtarget = bodytarget;
2418
2419     TAINT;
2420     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2421         sv_setpv(GvSV(tmpgv),origfilename);
2422         magicname("0", "0", 1);
2423     }
2424     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2425         sv_setpv(GvSV(tmpgv),origargv[0]);
2426     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2427         GvMULTI_on(argvgv);
2428         (void)gv_AVadd(argvgv);
2429         av_clear(GvAVn(argvgv));
2430         for (; argc > 0; argc--,argv++) {
2431             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2432         }
2433     }
2434     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2435         HV *hv;
2436         GvMULTI_on(envgv);
2437         hv = GvHVn(envgv);
2438         hv_magic(hv, envgv, 'E');
2439 #ifndef VMS  /* VMS doesn't have environ array */
2440         /* Note that if the supplied env parameter is actually a copy
2441            of the global environ then it may now point to free'd memory
2442            if the environment has been modified since. To avoid this
2443            problem we treat env==NULL as meaning 'use the default'
2444         */
2445         if (!env)
2446             env = environ;
2447         if (env != environ)
2448             environ[0] = Nullch;
2449         for (; *env; env++) {
2450             if (!(s = strchr(*env,'=')))
2451                 continue;
2452             *s++ = '\0';
2453 #if defined(WIN32) || defined(MSDOS)
2454             (void)strupr(*env);
2455 #endif
2456             sv = newSVpv(s--,0);
2457             (void)hv_store(hv, *env, s - *env, sv, 0);
2458             *s = '=';
2459 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2460             /* Sins of the RTL. See note in my_setenv(). */
2461             (void)PerlEnv_putenv(savepv(*env));
2462 #endif
2463         }
2464 #endif
2465 #ifdef DYNAMIC_ENV_FETCH
2466         HvNAME(hv) = savepv(ENV_HV_NAME);
2467 #endif
2468     }
2469     TAINT_NOT;
2470     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2471         sv_setiv(GvSV(tmpgv), (IV)getpid());
2472 }
2473
2474 static void
2475 init_perllib(void)
2476 {
2477     char *s;
2478     if (!tainting) {
2479 #ifndef VMS
2480         s = PerlEnv_getenv("PERL5LIB");
2481         if (s)
2482             incpush(s, TRUE);
2483         else
2484             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2485 #else /* VMS */
2486         /* Treat PERL5?LIB as a possible search list logical name -- the
2487          * "natural" VMS idiom for a Unix path string.  We allow each
2488          * element to be a set of |-separated directories for compatibility.
2489          */
2490         char buf[256];
2491         int idx = 0;
2492         if (my_trnlnm("PERL5LIB",buf,0))
2493             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2494         else
2495             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2496 #endif /* VMS */
2497     }
2498
2499 /* Use the ~-expanded versions of APPLLIB (undocumented),
2500     ARCHLIB PRIVLIB SITEARCH and SITELIB
2501 */
2502 #ifdef APPLLIB_EXP
2503     incpush(APPLLIB_EXP, TRUE);
2504 #endif
2505
2506 #ifdef ARCHLIB_EXP
2507     incpush(ARCHLIB_EXP, FALSE);
2508 #endif
2509 #ifndef PRIVLIB_EXP
2510 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2511 #endif
2512     incpush(PRIVLIB_EXP, FALSE);
2513
2514 #ifdef SITEARCH_EXP
2515     incpush(SITEARCH_EXP, FALSE);
2516 #endif
2517 #ifdef SITELIB_EXP
2518     incpush(SITELIB_EXP, FALSE);
2519 #endif
2520     if (!tainting)
2521         incpush(".", FALSE);
2522 }
2523
2524 #if defined(DOSISH)
2525 #    define PERLLIB_SEP ';'
2526 #else
2527 #  if defined(VMS)
2528 #    define PERLLIB_SEP '|'
2529 #  else
2530 #    define PERLLIB_SEP ':'
2531 #  endif
2532 #endif
2533 #ifndef PERLLIB_MANGLE
2534 #  define PERLLIB_MANGLE(s,n) (s)
2535 #endif
2536
2537 static void
2538 incpush(char *p, int addsubdirs)
2539 {
2540     SV *subdir = Nullsv;
2541     static char *archpat_auto;
2542
2543     if (!p)
2544         return;
2545
2546     if (addsubdirs) {
2547         subdir = NEWSV(55,0);
2548         if (!archpat_auto) {
2549             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2550                           + sizeof("//auto"));
2551             New(55, archpat_auto, len, char);
2552             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2553 #ifdef VMS
2554         for (len = sizeof(ARCHNAME) + 2;
2555              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2556                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2557 #endif
2558         }
2559     }
2560
2561     /* Break at all separators */
2562     while (p && *p) {
2563         SV *libdir = NEWSV(55,0);
2564         char *s;
2565
2566         /* skip any consecutive separators */
2567         while ( *p == PERLLIB_SEP ) {
2568             /* Uncomment the next line for PATH semantics */
2569             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2570             p++;
2571         }
2572
2573         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2574             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2575                       (STRLEN)(s - p));
2576             p = s + 1;
2577         }
2578         else {
2579             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2580             p = Nullch; /* break out */
2581         }
2582
2583         /*
2584          * BEFORE pushing libdir onto @INC we may first push version- and
2585          * archname-specific sub-directories.
2586          */
2587         if (addsubdirs) {
2588             struct stat tmpstatbuf;
2589 #ifdef VMS
2590             char *unix;
2591             STRLEN len;
2592
2593             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2594                 len = strlen(unix);
2595                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2596                 sv_usepvn(libdir,unix,len);
2597             }
2598             else
2599                 PerlIO_printf(PerlIO_stderr(),
2600                               "Failed to unixify @INC element \"%s\"\n",
2601                               SvPV(libdir,na));
2602 #endif
2603             /* .../archname/version if -d .../archname/version/auto */
2604             sv_setsv(subdir, libdir);
2605             sv_catpv(subdir, archpat_auto);
2606             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2607                   S_ISDIR(tmpstatbuf.st_mode))
2608                 av_push(GvAVn(incgv),
2609                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2610
2611             /* .../archname if -d .../archname/auto */
2612             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2613                       strlen(patchlevel) + 1, "", 0);
2614             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2615                   S_ISDIR(tmpstatbuf.st_mode))
2616                 av_push(GvAVn(incgv),
2617                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2618         }
2619
2620         /* finally push this lib directory on the end of @INC */
2621         av_push(GvAVn(incgv), libdir);
2622     }
2623
2624     SvREFCNT_dec(subdir);
2625 }
2626
2627 #ifdef USE_THREADS
2628 static struct perl_thread *
2629 init_main_thread()
2630 {
2631     struct perl_thread *thr;
2632     XPV *xpv;
2633
2634     Newz(53, thr, 1, struct perl_thread);
2635     curcop = &compiling;
2636     thr->cvcache = newHV();
2637     thr->threadsv = newAV();
2638     /* thr->threadsvp is set when find_threadsv is called */
2639     thr->specific = newAV();
2640     thr->errhv = newHV();
2641     thr->flags = THRf_R_JOINABLE;
2642     MUTEX_INIT(&thr->mutex);
2643     /* Handcraft thrsv similarly to mess_sv */
2644     New(53, thrsv, 1, SV);
2645     Newz(53, xpv, 1, XPV);
2646     SvFLAGS(thrsv) = SVt_PV;
2647     SvANY(thrsv) = (void*)xpv;
2648     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2649     SvPVX(thrsv) = (char*)thr;
2650     SvCUR_set(thrsv, sizeof(thr));
2651     SvLEN_set(thrsv, sizeof(thr));
2652     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2653     thr->oursv = thrsv;
2654     chopset = " \n-";
2655
2656     MUTEX_LOCK(&threads_mutex);
2657     nthreads++;
2658     thr->tid = 0;
2659     thr->next = thr;
2660     thr->prev = thr;
2661     MUTEX_UNLOCK(&threads_mutex);
2662
2663 #ifdef HAVE_THREAD_INTERN
2664     init_thread_intern(thr);
2665 #endif
2666
2667 #ifdef SET_THREAD_SELF
2668     SET_THREAD_SELF(thr);
2669 #else
2670     thr->self = pthread_self();
2671 #endif /* SET_THREAD_SELF */
2672     SET_THR(thr);
2673
2674     /*
2675      * These must come after the SET_THR because sv_setpvn does
2676      * SvTAINT and the taint fields require dTHR.
2677      */
2678     toptarget = NEWSV(0,0);
2679     sv_upgrade(toptarget, SVt_PVFM);
2680     sv_setpvn(toptarget, "", 0);
2681     bodytarget = NEWSV(0,0);
2682     sv_upgrade(bodytarget, SVt_PVFM);
2683     sv_setpvn(bodytarget, "", 0);
2684     formtarget = bodytarget;
2685     thr->errsv = newSVpv("", 0);
2686     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2687     return thr;
2688 }
2689 #endif /* USE_THREADS */
2690
2691 void
2692 call_list(I32 oldscope, AV *list)
2693 {
2694     dTHR;
2695     line_t oldline = curcop->cop_line;
2696     STRLEN len;
2697     dJMPENV;
2698     int ret;
2699
2700     while (AvFILL(list) >= 0) {
2701         CV *cv = (CV*)av_shift(list);
2702
2703         SAVEFREESV(cv);
2704
2705         JMPENV_PUSH(ret);
2706         switch (ret) {
2707         case 0: {
2708                 SV* atsv = ERRSV;
2709                 PUSHMARK(stack_sp);
2710                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2711                 (void)SvPV(atsv, len);
2712                 if (len) {
2713                     JMPENV_POP;
2714                     curcop = &compiling;
2715                     curcop->cop_line = oldline;
2716                     if (list == beginav)
2717                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2718                     else
2719                         sv_catpv(atsv, "END failed--cleanup aborted");
2720                     while (scopestack_ix > oldscope)
2721                         LEAVE;
2722                     croak("%s", SvPVX(atsv));
2723                 }
2724             }
2725             break;
2726         case 1:
2727             STATUS_ALL_FAILURE;
2728             /* FALL THROUGH */
2729         case 2:
2730             /* my_exit() was called */
2731             while (scopestack_ix > oldscope)
2732                 LEAVE;
2733             FREETMPS;
2734             curstash = defstash;
2735             if (endav)
2736                 call_list(oldscope, endav);
2737             JMPENV_POP;
2738             curcop = &compiling;
2739             curcop->cop_line = oldline;
2740             if (statusvalue) {
2741                 if (list == beginav)
2742                     croak("BEGIN failed--compilation aborted");
2743                 else
2744                     croak("END failed--cleanup aborted");
2745             }
2746             my_exit_jump();
2747             /* NOTREACHED */
2748         case 3:
2749             if (!restartop) {
2750                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2751                 FREETMPS;
2752                 break;
2753             }
2754             JMPENV_POP;
2755             curcop = &compiling;
2756             curcop->cop_line = oldline;
2757             JMPENV_JUMP(3);
2758         }
2759         JMPENV_POP;
2760     }
2761 }
2762
2763 void
2764 my_exit(U32 status)
2765 {
2766     dTHR;
2767
2768 #ifdef USE_THREADS
2769     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2770                           thr, (unsigned long) status));
2771 #endif /* USE_THREADS */
2772     switch (status) {
2773     case 0:
2774         STATUS_ALL_SUCCESS;
2775         break;
2776     case 1:
2777         STATUS_ALL_FAILURE;
2778         break;
2779     default:
2780         STATUS_NATIVE_SET(status);
2781         break;
2782     }
2783     my_exit_jump();
2784 }
2785
2786 void
2787 my_failure_exit(void)
2788 {
2789 #ifdef VMS
2790     if (vaxc$errno & 1) {
2791         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2792             STATUS_NATIVE_SET(44);
2793     }
2794     else {
2795         if (!vaxc$errno && errno)       /* unlikely */
2796             STATUS_NATIVE_SET(44);
2797         else
2798             STATUS_NATIVE_SET(vaxc$errno);
2799     }
2800 #else
2801     int exitstatus;
2802     if (errno & 255)
2803         STATUS_POSIX_SET(errno);
2804     else {
2805         exitstatus = STATUS_POSIX >> 8;
2806         if (exitstatus & 255)
2807             STATUS_POSIX_SET(exitstatus);
2808         else
2809             STATUS_POSIX_SET(255);
2810     }
2811 #endif
2812     my_exit_jump();
2813 }
2814
2815 static void
2816 my_exit_jump(void)
2817 {
2818     dSP;
2819     register PERL_CONTEXT *cx;
2820     I32 gimme;
2821     SV **newsp;
2822
2823     if (e_tmpname) {
2824         if (e_fp) {
2825             PerlIO_close(e_fp);
2826             e_fp = Nullfp;
2827         }
2828         (void)UNLINK(e_tmpname);
2829         Safefree(e_tmpname);
2830         e_tmpname = Nullch;
2831     }
2832
2833     POPSTACK_TO(mainstack);
2834     if (cxstack_ix >= 0) {
2835         if (cxstack_ix > 0)
2836             dounwind(0);
2837         POPBLOCK(cx,curpm);
2838         LEAVE;
2839     }
2840
2841     JMPENV_JUMP(2);
2842 }
2843
2844
2845