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