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