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
1743 void
1744 my_unexec(void)
1745 {
1746 #ifdef UNEXEC
1747     SV*    prog;
1748     SV*    file;
1749     int    status;
1750     extern int etext;
1751
1752     prog = newSVpv(BIN_EXP);
1753     sv_catpv(prog, "/perl");
1754     file = newSVpv(origfilename);
1755     sv_catpv(file, ".perldump");
1756
1757     status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1758     if (status)
1759         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1760                       SvPVX(prog), SvPVX(file));
1761     PerlProc_exit(status);
1762 #else
1763 #  ifdef VMS
1764 #    include <lib$routines.h>
1765      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1766 #  else
1767     ABORT();            /* for use with undump */
1768 #  endif
1769 #endif
1770 }
1771
1772 static void
1773 init_main_stash(void)
1774 {
1775     dTHR;
1776     GV *gv;
1777
1778     /* Note that strtab is a rather special HV.  Assumptions are made
1779        about not iterating on it, and not adding tie magic to it.
1780        It is properly deallocated in perl_destruct() */
1781     strtab = newHV();
1782     HvSHAREKEYS_off(strtab);                    /* mandatory */
1783     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1784          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1785
1786     curstash = defstash = newHV();
1787     curstname = newSVpv("main",4);
1788     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1789     SvREFCNT_dec(GvHV(gv));
1790     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1791     SvREADONLY_on(gv);
1792     HvNAME(defstash) = savepv("main");
1793     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1794     GvMULTI_on(incgv);
1795     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1796     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1797     GvMULTI_on(errgv);
1798     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1799     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
1800     sv_setpvn(ERRSV, "", 0);
1801     curstash = defstash;
1802     compiling.cop_stash = defstash;
1803     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1804     globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1805     /* We must init $/ before switches are processed. */
1806     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1807 }
1808
1809 static void
1810 open_script(char *scriptname, bool dosearch, SV *sv)
1811 {
1812     dTHR;
1813     register char *s;
1814
1815     scriptname = find_script(scriptname, dosearch, NULL, 0);
1816
1817     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1818         char *s = scriptname + 8;
1819         fdscript = atoi(s);
1820         while (isDIGIT(*s))
1821             s++;
1822         if (*s)
1823             scriptname = s + 1;
1824     }
1825     else
1826         fdscript = -1;
1827     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1828     curcop->cop_filegv = gv_fetchfile(origfilename);
1829     if (strEQ(origfilename,"-"))
1830         scriptname = "";
1831     if (fdscript >= 0) {
1832         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
1833 #if defined(HAS_FCNTL) && defined(F_SETFD)
1834         if (rsfp)
1835             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1836 #endif
1837     }
1838     else if (preprocess) {
1839         char *cpp_cfg = CPPSTDIN;
1840         SV *cpp = NEWSV(0,0);
1841         SV *cmd = NEWSV(0,0);
1842
1843         if (strEQ(cpp_cfg, "cppstdin"))
1844             sv_catpvf(cpp, "%s/", BIN_EXP);
1845         sv_catpv(cpp, cpp_cfg);
1846
1847         sv_catpv(sv,"-I");
1848         sv_catpv(sv,PRIVLIB_EXP);
1849
1850 #ifdef MSDOS
1851         sv_setpvf(cmd, "\
1852 sed %s -e \"/^[^#]/b\" \
1853  -e \"/^#[      ]*include[      ]/b\" \
1854  -e \"/^#[      ]*define[       ]/b\" \
1855  -e \"/^#[      ]*if[   ]/b\" \
1856  -e \"/^#[      ]*ifdef[        ]/b\" \
1857  -e \"/^#[      ]*ifndef[       ]/b\" \
1858  -e \"/^#[      ]*else/b\" \
1859  -e \"/^#[      ]*elif[         ]/b\" \
1860  -e \"/^#[      ]*undef[        ]/b\" \
1861  -e \"/^#[      ]*endif/b\" \
1862  -e \"s/^#.*//\" \
1863  %s | %_ -C %_ %s",
1864           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1865 #else
1866         sv_setpvf(cmd, "\
1867 %s %s -e '/^[^#]/b' \
1868  -e '/^#[       ]*include[      ]/b' \
1869  -e '/^#[       ]*define[       ]/b' \
1870  -e '/^#[       ]*if[   ]/b' \
1871  -e '/^#[       ]*ifdef[        ]/b' \
1872  -e '/^#[       ]*ifndef[       ]/b' \
1873  -e '/^#[       ]*else/b' \
1874  -e '/^#[       ]*elif[         ]/b' \
1875  -e '/^#[       ]*undef[        ]/b' \
1876  -e '/^#[       ]*endif/b' \
1877  -e 's/^[       ]*#.*//' \
1878  %s | %_ -C %_ %s",
1879 #ifdef LOC_SED
1880           LOC_SED,
1881 #else
1882           "sed",
1883 #endif
1884           (doextract ? "-e '1,/^#/d\n'" : ""),
1885 #endif
1886           scriptname, cpp, sv, CPPMINUS);
1887         doextract = FALSE;
1888 #ifdef IAMSUID                          /* actually, this is caught earlier */
1889         if (euid != uid && !euid) {     /* if running suidperl */
1890 #ifdef HAS_SETEUID
1891             (void)seteuid(uid);         /* musn't stay setuid root */
1892 #else
1893 #ifdef HAS_SETREUID
1894             (void)setreuid((Uid_t)-1, uid);
1895 #else
1896 #ifdef HAS_SETRESUID
1897             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1898 #else
1899             setuid(uid);
1900 #endif
1901 #endif
1902 #endif
1903             if (geteuid() != uid)
1904                 croak("Can't do seteuid!\n");
1905         }
1906 #endif /* IAMSUID */
1907         rsfp = PerlProc_popen(SvPVX(cmd), "r");
1908         SvREFCNT_dec(cmd);
1909         SvREFCNT_dec(cpp);
1910     }
1911     else if (!*scriptname) {
1912         forbid_setid("program input from stdin");
1913         rsfp = PerlIO_stdin();
1914     }
1915     else {
1916         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1917 #if defined(HAS_FCNTL) && defined(F_SETFD)
1918         if (rsfp)
1919             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1920 #endif
1921     }
1922     if (e_tmpname) {
1923         e_fp = rsfp;
1924     }
1925     if (!rsfp) {
1926 #ifdef DOSUID
1927 #ifndef IAMSUID         /* in case script is not readable before setuid */
1928         if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1929           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1930             /* try again */
1931             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1932             croak("Can't do setuid\n");
1933         }
1934 #endif
1935 #endif
1936         croak("Can't open perl script \"%s\": %s\n",
1937           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1938     }
1939 }
1940
1941 static void
1942 validate_suid(char *validarg, char *scriptname)
1943 {
1944     int which;
1945
1946     /* do we need to emulate setuid on scripts? */
1947
1948     /* This code is for those BSD systems that have setuid #! scripts disabled
1949      * in the kernel because of a security problem.  Merely defining DOSUID
1950      * in perl will not fix that problem, but if you have disabled setuid
1951      * scripts in the kernel, this will attempt to emulate setuid and setgid
1952      * on scripts that have those now-otherwise-useless bits set.  The setuid
1953      * root version must be called suidperl or sperlN.NNN.  If regular perl
1954      * discovers that it has opened a setuid script, it calls suidperl with
1955      * the same argv that it had.  If suidperl finds that the script it has
1956      * just opened is NOT setuid root, it sets the effective uid back to the
1957      * uid.  We don't just make perl setuid root because that loses the
1958      * effective uid we had before invoking perl, if it was different from the
1959      * uid.
1960      *
1961      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1962      * be defined in suidperl only.  suidperl must be setuid root.  The
1963      * Configure script will set this up for you if you want it.
1964      */
1965
1966 #ifdef DOSUID
1967     dTHR;
1968     char *s, *s2;
1969
1970     if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
1971         croak("Can't stat script \"%s\"",origfilename);
1972     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1973         I32 len;
1974
1975 #ifdef IAMSUID
1976 #ifndef HAS_SETREUID
1977         /* On this access check to make sure the directories are readable,
1978          * there is actually a small window that the user could use to make
1979          * filename point to an accessible directory.  So there is a faint
1980          * chance that someone could execute a setuid script down in a
1981          * non-accessible directory.  I don't know what to do about that.
1982          * But I don't think it's too important.  The manual lies when
1983          * it says access() is useful in setuid programs.
1984          */
1985         if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1986             croak("Permission denied");
1987 #else
1988         /* If we can swap euid and uid, then we can determine access rights
1989          * with a simple stat of the file, and then compare device and
1990          * inode to make sure we did stat() on the same file we opened.
1991          * Then we just have to make sure he or she can execute it.
1992          */
1993         {
1994             struct stat tmpstatbuf;
1995
1996             if (
1997 #ifdef HAS_SETREUID
1998                 setreuid(euid,uid) < 0
1999 #else
2000 # if HAS_SETRESUID
2001                 setresuid(euid,uid,(Uid_t)-1) < 0
2002 # endif
2003 #endif
2004                 || getuid() != euid || geteuid() != uid)
2005                 croak("Can't swap uid and euid");       /* really paranoid */
2006             if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2007                 croak("Permission denied");     /* testing full pathname here */
2008             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2009                 tmpstatbuf.st_ino != statbuf.st_ino) {
2010                 (void)PerlIO_close(rsfp);
2011                 if (rsfp = PerlProc_popen("/bin/mail root","w")) {      /* heh, heh */
2012                     PerlIO_printf(rsfp,
2013 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2014 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2015                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2016                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2017                         SvPVX(GvSV(curcop->cop_filegv)),
2018                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2019                     (void)PerlProc_pclose(rsfp);
2020                 }
2021                 croak("Permission denied\n");
2022             }
2023             if (
2024 #ifdef HAS_SETREUID
2025               setreuid(uid,euid) < 0
2026 #else
2027 # if defined(HAS_SETRESUID)
2028               setresuid(uid,euid,(Uid_t)-1) < 0
2029 # endif
2030 #endif
2031               || getuid() != uid || geteuid() != euid)
2032                 croak("Can't reswap uid and euid");
2033             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2034                 croak("Permission denied\n");
2035         }
2036 #endif /* HAS_SETREUID */
2037 #endif /* IAMSUID */
2038
2039         if (!S_ISREG(statbuf.st_mode))
2040             croak("Permission denied");
2041         if (statbuf.st_mode & S_IWOTH)
2042             croak("Setuid/gid script is writable by world");
2043         doswitches = FALSE;             /* -s is insecure in suid */
2044         curcop->cop_line++;
2045         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2046           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2047             croak("No #! line");
2048         s = SvPV(linestr,na)+2;
2049         if (*s == ' ') s++;
2050         while (!isSPACE(*s)) s++;
2051         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2052                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2053         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2054             croak("Not a perl script");
2055         while (*s == ' ' || *s == '\t') s++;
2056         /*
2057          * #! arg must be what we saw above.  They can invoke it by
2058          * mentioning suidperl explicitly, but they may not add any strange
2059          * arguments beyond what #! says if they do invoke suidperl that way.
2060          */
2061         len = strlen(validarg);
2062         if (strEQ(validarg," PHOOEY ") ||
2063             strnNE(s,validarg,len) || !isSPACE(s[len]))
2064             croak("Args must match #! line");
2065
2066 #ifndef IAMSUID
2067         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2068             euid == statbuf.st_uid)
2069             if (!do_undump)
2070                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2071 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2072 #endif /* IAMSUID */
2073
2074         if (euid) {     /* oops, we're not the setuid root perl */
2075             (void)PerlIO_close(rsfp);
2076 #ifndef IAMSUID
2077             /* try again */
2078             PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2079 #endif
2080             croak("Can't do setuid\n");
2081         }
2082
2083         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2084 #ifdef HAS_SETEGID
2085             (void)setegid(statbuf.st_gid);
2086 #else
2087 #ifdef HAS_SETREGID
2088            (void)setregid((Gid_t)-1,statbuf.st_gid);
2089 #else
2090 #ifdef HAS_SETRESGID
2091            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2092 #else
2093             setgid(statbuf.st_gid);
2094 #endif
2095 #endif
2096 #endif
2097             if (getegid() != statbuf.st_gid)
2098                 croak("Can't do setegid!\n");
2099         }
2100         if (statbuf.st_mode & S_ISUID) {
2101             if (statbuf.st_uid != euid)
2102 #ifdef HAS_SETEUID
2103                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2104 #else
2105 #ifdef HAS_SETREUID
2106                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2107 #else
2108 #ifdef HAS_SETRESUID
2109                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2110 #else
2111                 setuid(statbuf.st_uid);
2112 #endif
2113 #endif
2114 #endif
2115             if (geteuid() != statbuf.st_uid)
2116                 croak("Can't do seteuid!\n");
2117         }
2118         else if (uid) {                 /* oops, mustn't run as root */
2119 #ifdef HAS_SETEUID
2120           (void)seteuid((Uid_t)uid);
2121 #else
2122 #ifdef HAS_SETREUID
2123           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2124 #else
2125 #ifdef HAS_SETRESUID
2126           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2127 #else
2128           setuid((Uid_t)uid);
2129 #endif
2130 #endif
2131 #endif
2132             if (geteuid() != uid)
2133                 croak("Can't do seteuid!\n");
2134         }
2135         init_ids();
2136         if (!cando(S_IXUSR,TRUE,&statbuf))
2137             croak("Permission denied\n");       /* they can't do this */
2138     }
2139 #ifdef IAMSUID
2140     else if (preprocess)
2141         croak("-P not allowed for setuid/setgid script\n");
2142     else if (fdscript >= 0)
2143         croak("fd script not allowed in suidperl\n");
2144     else
2145         croak("Script is not setuid/setgid in suidperl\n");
2146
2147     /* We absolutely must clear out any saved ids here, so we */
2148     /* exec the real perl, substituting fd script for scriptname. */
2149     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2150     PerlIO_rewind(rsfp);
2151     PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2152     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2153     if (!origargv[which])
2154         croak("Permission denied");
2155     origargv[which] = savepv(form("/dev/fd/%d/%s",
2156                                   PerlIO_fileno(rsfp), origargv[which]));
2157 #if defined(HAS_FCNTL) && defined(F_SETFD)
2158     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2159 #endif
2160     PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
2161     croak("Can't do setuid\n");
2162 #endif /* IAMSUID */
2163 #else /* !DOSUID */
2164     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2165 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2166         dTHR;
2167         PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2168         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2169             ||
2170             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2171            )
2172             if (!do_undump)
2173                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2174 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2175 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2176         /* not set-id, must be wrapped */
2177     }
2178 #endif /* DOSUID */
2179 }
2180
2181 static void
2182 find_beginning(void)
2183 {
2184     register char *s, *s2;
2185
2186     /* skip forward in input to the real script? */
2187
2188     forbid_setid("-x");
2189     while (doextract) {
2190         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2191             croak("No Perl script found in input\n");
2192         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2193             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2194             doextract = FALSE;
2195             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2196             s2 = s;
2197             while (*s == ' ' || *s == '\t') s++;
2198             if (*s++ == '-') {
2199                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2200                 if (strnEQ(s2-4,"perl",4))
2201                     /*SUPPRESS 530*/
2202                     while (s = moreswitches(s)) ;
2203             }
2204             if (cddir && PerlDir_chdir(cddir) < 0)
2205                 croak("Can't chdir to %s",cddir);
2206         }
2207     }
2208 }
2209
2210 static void
2211 init_ids(void)
2212 {
2213     uid = (int)getuid();
2214     euid = (int)geteuid();
2215     gid = (int)getgid();
2216     egid = (int)getegid();
2217 #ifdef VMS
2218     uid |= gid << 16;
2219     euid |= egid << 16;
2220 #endif
2221     tainting |= (uid && (euid != uid || egid != gid));
2222 }
2223
2224 static void
2225 forbid_setid(char *s)
2226 {
2227     if (euid != uid)
2228         croak("No %s allowed while running setuid", s);
2229     if (egid != gid)
2230         croak("No %s allowed while running setgid", s);
2231 }
2232
2233 static void
2234 init_debugger(void)
2235 {
2236     dTHR;
2237     curstash = debstash;
2238     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2239     AvREAL_off(dbargs);
2240     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2241     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2242     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2243     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2244     sv_setiv(DBsingle, 0);
2245     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2246     sv_setiv(DBtrace, 0);
2247     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2248     sv_setiv(DBsignal, 0);
2249     curstash = defstash;
2250 }
2251
2252 #ifndef STRESS_REALLOC
2253 #define REASONABLE(size) (size)
2254 #else
2255 #define REASONABLE(size) (1) /* unreasonable */
2256 #endif
2257
2258 void
2259 init_stacks(ARGSproto)
2260 {
2261     /* start with 128-item stack and 8K cxstack */
2262     curstackinfo = new_stackinfo(REASONABLE(128),
2263                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2264     curstackinfo->si_type = SI_MAIN;
2265     curstack = curstackinfo->si_stack;
2266     mainstack = curstack;               /* remember in case we switch stacks */
2267
2268     stack_base = AvARRAY(curstack);
2269     stack_sp = stack_base;
2270     stack_max = stack_base + AvMAX(curstack);
2271
2272     New(50,tmps_stack,REASONABLE(128),SV*);
2273     tmps_floor = -1;
2274     tmps_ix = -1;
2275     tmps_max = REASONABLE(128);
2276
2277     /*
2278      * The following stacks almost certainly should be per-interpreter,
2279      * but for now they're not.  XXX
2280      */
2281
2282     if (markstack) {
2283         markstack_ptr = markstack;
2284     } else {
2285         New(54,markstack,REASONABLE(32),I32);
2286         markstack_ptr = markstack;
2287         markstack_max = markstack + REASONABLE(32);
2288     }
2289
2290     SET_MARKBASE;
2291
2292     if (scopestack) {
2293         scopestack_ix = 0;
2294     } else {
2295         New(54,scopestack,REASONABLE(32),I32);
2296         scopestack_ix = 0;
2297         scopestack_max = REASONABLE(32);
2298     }
2299
2300     if (savestack) {
2301         savestack_ix = 0;
2302     } else {
2303         New(54,savestack,REASONABLE(128),ANY);
2304         savestack_ix = 0;
2305         savestack_max = REASONABLE(128);
2306     }
2307
2308     if (retstack) {
2309         retstack_ix = 0;
2310     } else {
2311         New(54,retstack,REASONABLE(16),OP*);
2312         retstack_ix = 0;
2313         retstack_max = REASONABLE(16);
2314     }
2315 }
2316
2317 #undef REASONABLE
2318
2319 static void
2320 nuke_stacks(void)
2321 {
2322     dTHR;
2323     while (curstackinfo->si_next)
2324         curstackinfo = curstackinfo->si_next;
2325     while (curstackinfo) {
2326         PERL_SI *p = curstackinfo->si_prev;
2327         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2328         Safefree(curstackinfo->si_cxstack);
2329         Safefree(curstackinfo);
2330         curstackinfo = p;
2331     }
2332     Safefree(tmps_stack);
2333     DEBUG( {
2334         Safefree(debname);
2335         Safefree(debdelim);
2336     } )
2337 }
2338
2339 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2340
2341 static void
2342 init_lexer(void)
2343 {
2344     tmpfp = rsfp;
2345     rsfp = Nullfp;
2346     lex_start(linestr);
2347     rsfp = tmpfp;
2348     subname = newSVpv("main",4);
2349 }
2350
2351 static void
2352 init_predump_symbols(void)
2353 {
2354     dTHR;
2355     GV *tmpgv;
2356     GV *othergv;
2357
2358     sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2359     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2360     GvMULTI_on(stdingv);
2361     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2362     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2363     GvMULTI_on(tmpgv);
2364     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2365
2366     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2367     GvMULTI_on(tmpgv);
2368     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2369     setdefout(tmpgv);
2370     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2371     GvMULTI_on(tmpgv);
2372     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2373
2374     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2375     GvMULTI_on(othergv);
2376     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2377     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2378     GvMULTI_on(tmpgv);
2379     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2380
2381     statname = NEWSV(66,0);             /* last filename we did stat on */
2382
2383     if (!osname)
2384         osname = savepv(OSNAME);
2385 }
2386
2387 static void
2388 init_postdump_symbols(register int argc, register char **argv, register char **env)
2389 {
2390     dTHR;
2391     char *s;
2392     SV *sv;
2393     GV* tmpgv;
2394
2395     argc--,argv++;      /* skip name of script */
2396     if (doswitches) {
2397         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2398             if (!argv[0][1])
2399                 break;
2400             if (argv[0][1] == '-') {
2401                 argc--,argv++;
2402                 break;
2403             }
2404             if (s = strchr(argv[0], '=')) {
2405                 *s++ = '\0';
2406                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2407             }
2408             else
2409                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2410         }
2411     }
2412     toptarget = NEWSV(0,0);
2413     sv_upgrade(toptarget, SVt_PVFM);
2414     sv_setpvn(toptarget, "", 0);
2415     bodytarget = NEWSV(0,0);
2416     sv_upgrade(bodytarget, SVt_PVFM);
2417     sv_setpvn(bodytarget, "", 0);
2418     formtarget = bodytarget;
2419
2420     TAINT;
2421     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2422         sv_setpv(GvSV(tmpgv),origfilename);
2423         magicname("0", "0", 1);
2424     }
2425     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2426         sv_setpv(GvSV(tmpgv),origargv[0]);
2427     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2428         GvMULTI_on(argvgv);
2429         (void)gv_AVadd(argvgv);
2430         av_clear(GvAVn(argvgv));
2431         for (; argc > 0; argc--,argv++) {
2432             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2433         }
2434     }
2435     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2436         HV *hv;
2437         GvMULTI_on(envgv);
2438         hv = GvHVn(envgv);
2439         hv_magic(hv, envgv, 'E');
2440 #ifndef VMS  /* VMS doesn't have environ array */
2441         /* Note that if the supplied env parameter is actually a copy
2442            of the global environ then it may now point to free'd memory
2443            if the environment has been modified since. To avoid this
2444            problem we treat env==NULL as meaning 'use the default'
2445         */
2446         if (!env)
2447             env = environ;
2448         if (env != environ)
2449             environ[0] = Nullch;
2450         for (; *env; env++) {
2451             if (!(s = strchr(*env,'=')))
2452                 continue;
2453             *s++ = '\0';
2454 #if defined(WIN32) || defined(MSDOS)
2455             (void)strupr(*env);
2456 #endif
2457             sv = newSVpv(s--,0);
2458             (void)hv_store(hv, *env, s - *env, sv, 0);
2459             *s = '=';
2460 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2461             /* Sins of the RTL. See note in my_setenv(). */
2462             (void)PerlEnv_putenv(savepv(*env));
2463 #endif
2464         }
2465 #endif
2466 #ifdef DYNAMIC_ENV_FETCH
2467         HvNAME(hv) = savepv(ENV_HV_NAME);
2468 #endif
2469     }
2470     TAINT_NOT;
2471     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2472         sv_setiv(GvSV(tmpgv), (IV)getpid());
2473 }
2474
2475 static void
2476 init_perllib(void)
2477 {
2478     char *s;
2479     if (!tainting) {
2480 #ifndef VMS
2481         s = PerlEnv_getenv("PERL5LIB");
2482         if (s)
2483             incpush(s, TRUE);
2484         else
2485             incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2486 #else /* VMS */
2487         /* Treat PERL5?LIB as a possible search list logical name -- the
2488          * "natural" VMS idiom for a Unix path string.  We allow each
2489          * element to be a set of |-separated directories for compatibility.
2490          */
2491         char buf[256];
2492         int idx = 0;
2493         if (my_trnlnm("PERL5LIB",buf,0))
2494             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2495         else
2496             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2497 #endif /* VMS */
2498     }
2499
2500 /* Use the ~-expanded versions of APPLLIB (undocumented),
2501     ARCHLIB PRIVLIB SITEARCH and SITELIB
2502 */
2503 #ifdef APPLLIB_EXP
2504     incpush(APPLLIB_EXP, TRUE);
2505 #endif
2506
2507 #ifdef ARCHLIB_EXP
2508     incpush(ARCHLIB_EXP, FALSE);
2509 #endif
2510 #ifndef PRIVLIB_EXP
2511 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2512 #endif
2513     incpush(PRIVLIB_EXP, FALSE);
2514
2515 #ifdef SITEARCH_EXP
2516     incpush(SITEARCH_EXP, FALSE);
2517 #endif
2518 #ifdef SITELIB_EXP
2519     incpush(SITELIB_EXP, FALSE);
2520 #endif
2521     if (!tainting)
2522         incpush(".", FALSE);
2523 }
2524
2525 #if defined(DOSISH)
2526 #    define PERLLIB_SEP ';'
2527 #else
2528 #  if defined(VMS)
2529 #    define PERLLIB_SEP '|'
2530 #  else
2531 #    define PERLLIB_SEP ':'
2532 #  endif
2533 #endif
2534 #ifndef PERLLIB_MANGLE
2535 #  define PERLLIB_MANGLE(s,n) (s)
2536 #endif
2537
2538 static void
2539 incpush(char *p, int addsubdirs)
2540 {
2541     SV *subdir = Nullsv;
2542     static char *archpat_auto;
2543
2544     if (!p)
2545         return;
2546
2547     if (addsubdirs) {
2548         subdir = NEWSV(55,0);
2549         if (!archpat_auto) {
2550             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2551                           + sizeof("//auto"));
2552             New(55, archpat_auto, len, char);
2553             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2554 #ifdef VMS
2555         for (len = sizeof(ARCHNAME) + 2;
2556              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2557                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2558 #endif
2559         }
2560     }
2561
2562     /* Break at all separators */
2563     while (p && *p) {
2564         SV *libdir = NEWSV(55,0);
2565         char *s;
2566
2567         /* skip any consecutive separators */
2568         while ( *p == PERLLIB_SEP ) {
2569             /* Uncomment the next line for PATH semantics */
2570             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2571             p++;
2572         }
2573
2574         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2575             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2576                       (STRLEN)(s - p));
2577             p = s + 1;
2578         }
2579         else {
2580             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2581             p = Nullch; /* break out */
2582         }
2583
2584         /*
2585          * BEFORE pushing libdir onto @INC we may first push version- and
2586          * archname-specific sub-directories.
2587          */
2588         if (addsubdirs) {
2589             struct stat tmpstatbuf;
2590 #ifdef VMS
2591             char *unix;
2592             STRLEN len;
2593
2594             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2595                 len = strlen(unix);
2596                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2597                 sv_usepvn(libdir,unix,len);
2598             }
2599             else
2600                 PerlIO_printf(PerlIO_stderr(),
2601                               "Failed to unixify @INC element \"%s\"\n",
2602                               SvPV(libdir,na));
2603 #endif
2604             /* .../archname/version if -d .../archname/version/auto */
2605             sv_setsv(subdir, libdir);
2606             sv_catpv(subdir, archpat_auto);
2607             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2608                   S_ISDIR(tmpstatbuf.st_mode))
2609                 av_push(GvAVn(incgv),
2610                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2611
2612             /* .../archname if -d .../archname/auto */
2613             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2614                       strlen(patchlevel) + 1, "", 0);
2615             if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2616                   S_ISDIR(tmpstatbuf.st_mode))
2617                 av_push(GvAVn(incgv),
2618                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2619         }
2620
2621         /* finally push this lib directory on the end of @INC */
2622         av_push(GvAVn(incgv), libdir);
2623     }
2624
2625     SvREFCNT_dec(subdir);
2626 }
2627
2628 #ifdef USE_THREADS
2629 static struct perl_thread *
2630 init_main_thread()
2631 {
2632     struct perl_thread *thr;
2633     XPV *xpv;
2634
2635     Newz(53, thr, 1, struct perl_thread);
2636     curcop = &compiling;
2637     thr->cvcache = newHV();
2638     thr->threadsv = newAV();
2639     /* thr->threadsvp is set when find_threadsv is called */
2640     thr->specific = newAV();
2641     thr->errhv = newHV();
2642     thr->flags = THRf_R_JOINABLE;
2643     MUTEX_INIT(&thr->mutex);
2644     /* Handcraft thrsv similarly to mess_sv */
2645     New(53, thrsv, 1, SV);
2646     Newz(53, xpv, 1, XPV);
2647     SvFLAGS(thrsv) = SVt_PV;
2648     SvANY(thrsv) = (void*)xpv;
2649     SvREFCNT(thrsv) = 1 << 30;  /* practically infinite */
2650     SvPVX(thrsv) = (char*)thr;
2651     SvCUR_set(thrsv, sizeof(thr));
2652     SvLEN_set(thrsv, sizeof(thr));
2653     *SvEND(thrsv) = '\0';       /* in the trailing_nul field */
2654     thr->oursv = thrsv;
2655     chopset = " \n-";
2656
2657     MUTEX_LOCK(&threads_mutex);
2658     nthreads++;
2659     thr->tid = 0;
2660     thr->next = thr;
2661     thr->prev = thr;
2662     MUTEX_UNLOCK(&threads_mutex);
2663
2664 #ifdef HAVE_THREAD_INTERN
2665     init_thread_intern(thr);
2666 #endif
2667
2668 #ifdef SET_THREAD_SELF
2669     SET_THREAD_SELF(thr);
2670 #else
2671     thr->self = pthread_self();
2672 #endif /* SET_THREAD_SELF */
2673     SET_THR(thr);
2674
2675     /*
2676      * These must come after the SET_THR because sv_setpvn does
2677      * SvTAINT and the taint fields require dTHR.
2678      */
2679     toptarget = NEWSV(0,0);
2680     sv_upgrade(toptarget, SVt_PVFM);
2681     sv_setpvn(toptarget, "", 0);
2682     bodytarget = NEWSV(0,0);
2683     sv_upgrade(bodytarget, SVt_PVFM);
2684     sv_setpvn(bodytarget, "", 0);
2685     formtarget = bodytarget;
2686     thr->errsv = newSVpv("", 0);
2687     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
2688     return thr;
2689 }
2690 #endif /* USE_THREADS */
2691
2692 void
2693 call_list(I32 oldscope, AV *list)
2694 {
2695     dTHR;
2696     line_t oldline = curcop->cop_line;
2697     STRLEN len;
2698     dJMPENV;
2699     int ret;
2700
2701     while (AvFILL(list) >= 0) {
2702         CV *cv = (CV*)av_shift(list);
2703
2704         SAVEFREESV(cv);
2705
2706         JMPENV_PUSH(ret);
2707         switch (ret) {
2708         case 0: {
2709                 SV* atsv = ERRSV;
2710                 PUSHMARK(stack_sp);
2711                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2712                 (void)SvPV(atsv, len);
2713                 if (len) {
2714                     JMPENV_POP;
2715                     curcop = &compiling;
2716                     curcop->cop_line = oldline;
2717                     if (list == beginav)
2718                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2719                     else
2720                         sv_catpv(atsv, "END failed--cleanup aborted");
2721                     while (scopestack_ix > oldscope)
2722                         LEAVE;
2723                     croak("%s", SvPVX(atsv));
2724                 }
2725             }
2726             break;
2727         case 1:
2728             STATUS_ALL_FAILURE;
2729             /* FALL THROUGH */
2730         case 2:
2731             /* my_exit() was called */
2732             while (scopestack_ix > oldscope)
2733                 LEAVE;
2734             FREETMPS;
2735             curstash = defstash;
2736             if (endav)
2737                 call_list(oldscope, endav);
2738             JMPENV_POP;
2739             curcop = &compiling;
2740             curcop->cop_line = oldline;
2741             if (statusvalue) {
2742                 if (list == beginav)
2743                     croak("BEGIN failed--compilation aborted");
2744                 else
2745                     croak("END failed--cleanup aborted");
2746             }
2747             my_exit_jump();
2748             /* NOTREACHED */
2749         case 3:
2750             if (!restartop) {
2751                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2752                 FREETMPS;
2753                 break;
2754             }
2755             JMPENV_POP;
2756             curcop = &compiling;
2757             curcop->cop_line = oldline;
2758             JMPENV_JUMP(3);
2759         }
2760         JMPENV_POP;
2761     }
2762 }
2763
2764 void
2765 my_exit(U32 status)
2766 {
2767     dTHR;
2768
2769 #ifdef USE_THREADS
2770     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2771                           thr, (unsigned long) status));
2772 #endif /* USE_THREADS */
2773     switch (status) {
2774     case 0:
2775         STATUS_ALL_SUCCESS;
2776         break;
2777     case 1:
2778         STATUS_ALL_FAILURE;
2779         break;
2780     default:
2781         STATUS_NATIVE_SET(status);
2782         break;
2783     }
2784     my_exit_jump();
2785 }
2786
2787 void
2788 my_failure_exit(void)
2789 {
2790 #ifdef VMS
2791     if (vaxc$errno & 1) {
2792         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2793             STATUS_NATIVE_SET(44);
2794     }
2795     else {
2796         if (!vaxc$errno && errno)       /* unlikely */
2797             STATUS_NATIVE_SET(44);
2798         else
2799             STATUS_NATIVE_SET(vaxc$errno);
2800     }
2801 #else
2802     int exitstatus;
2803     if (errno & 255)
2804         STATUS_POSIX_SET(errno);
2805     else {
2806         exitstatus = STATUS_POSIX >> 8;
2807         if (exitstatus & 255)
2808             STATUS_POSIX_SET(exitstatus);
2809         else
2810             STATUS_POSIX_SET(255);
2811     }
2812 #endif
2813     my_exit_jump();
2814 }
2815
2816 static void
2817 my_exit_jump(void)
2818 {
2819     dSP;
2820     register PERL_CONTEXT *cx;
2821     I32 gimme;
2822     SV **newsp;
2823
2824     if (e_tmpname) {
2825         if (e_fp) {
2826             PerlIO_close(e_fp);
2827             e_fp = Nullfp;
2828         }
2829         (void)UNLINK(e_tmpname);
2830         Safefree(e_tmpname);
2831         e_tmpname = Nullch;
2832     }
2833
2834     POPSTACK_TO(mainstack);
2835     if (cxstack_ix >= 0) {
2836         if (cxstack_ix > 0)
2837             dounwind(0);
2838         POPBLOCK(cx,curpm);
2839         LEAVE;
2840     }
2841
2842     JMPENV_JUMP(2);
2843 }
2844
2845
2846