perl.c

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