perl.c

   1 /*    perl.c
   2  *
   3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
  13  */
  14
  15 /* This file contains the top-level functions that are used to create, use
  16  * and destroy a perl interpreter, plus the functions used by XS code to
  17  * call back into perl. Note that it does not contain the actual main()
  18  * function of the interpreter; that can be found in perlmain.c
  19  */
  20
  21 /* PSz 12 Nov 03
  22  *
  23  * Be proud that perl(1) may proclaim:
  24  *   Setuid Perl scripts are safer than C programs ...
  25  * Do not abandon (deprecate) suidperl. Do not advocate C wrappers.
  26  *
  27  * The flow was: perl starts, notices script is suid, execs suidperl with same
  28  * arguments; suidperl opens script, checks many things, sets itself with
  29  * right UID, execs perl with similar arguments but with script pre-opened on
  30  * /dev/fd/xxx; perl checks script is as should be and does work. This was
  31  * insecure: see perlsec(1) for many problems with this approach.
  32  *
  33  * The "correct" flow should be: perl starts, opens script and notices it is
  34  * suid, checks many things, execs suidperl with similar arguments but with
  35  * script on /dev/fd/xxx; suidperl checks script and /dev/fd/xxx object are
  36  * same, checks arguments match #! line, sets itself with right UID, execs
  37  * perl with same arguments; perl checks many things and does work.
  38  *
  39  * (Opening the script in perl instead of suidperl, we "lose" scripts that
  40  * are readable to the target UID but not to the invoker. Where did
  41  * unreadable scripts work anyway?)
  42  *
  43  * For now, suidperl and perl are pretty much the same large and cumbersome
  44  * program, so suidperl can check its argument list (see comments elsewhere).
  45  *
  46  * References:
  47  * Original bug report:
  48  *   http://bugs.perl.org/index.html?req=bug_id&bug_id=20010322.218
  49  *   http://rt.perl.org/rt2/Ticket/Display.html?id=6511
  50  * Comments and discussion with Debian:
  51  *   http://bugs.debian.org/203426
  52  *   http://bugs.debian.org/220486
  53  * Debian Security Advisory DSA 431-1 (does not fully fix problem):
  54  *   http://www.debian.org/security/2004/dsa-431
  55  * CVE candidate:
  56  *   http://cve.mitre.org/cgi-bin/cvename.cgi?name=CAN-2003-0618
  57  * Previous versions of this patch sent to perl5-porters:
  58  *   http://www.mail-archive.com/perl5-porters@perl.org/msg71953.html
  59  *   http://www.mail-archive.com/perl5-porters@perl.org/msg75245.html
  60  *   http://www.mail-archive.com/perl5-porters@perl.org/msg75563.html
  61  *   http://www.mail-archive.com/perl5-porters@perl.org/msg75635.html
  62  *
  63 Paul Szabo - psz@maths.usyd.edu.au  http://www.maths.usyd.edu.au:8000/u/psz/
  64 School of Mathematics and Statistics  University of Sydney   2006  Australia
  65  *
  66  */
  67 /* PSz 13 Nov 03
  68  * Use truthful, neat, specific error messages.
  69  * Cannot always hide the truth; security must not depend on doing so.
  70  */
  71
  72 /* PSz 18 Feb 04
  73  * Use global(?), thread-local fdscript for easier checks.
  74  * (I do not understand how we could possibly get a thread race:
  75  * do not all threads go through the same initialization? Or in
  76  * fact, are not threads started only after we get the script and
  77  * so know what to do? Oh well, make things super-safe...)
  78  */
  79
  80 #include "EXTERN.h"
  81 #define PERL_IN_PERL_C
  82 #include "perl.h"
  83 #include "patchlevel.h"                 /* for local_patches */
  84
  85 #ifdef NETWARE
  86 #include "nwutil.h"
  87 char *nw_get_sitelib(const char *pl);
  88 #endif
  89
  90 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  91 #ifdef I_UNISTD
  92 #include <unistd.h>
  93 #endif
  94
  95 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
  96 #  ifdef I_SYS_WAIT
  97 #   include <sys/wait.h>
  98 #  endif
  99 #endif
 100
 101 #ifdef __BEOS__
 102 #  define HZ 1000000
 103 #endif
 104
 105 #ifndef HZ
 106 #  ifdef CLK_TCK
 107 #    define HZ CLK_TCK
 108 #  else
 109 #    define HZ 60
 110 #  endif
 111 #endif
 112
 113 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
 114 char *getenv (char *); /* Usually in <stdlib.h> */
 115 #endif
 116
 117 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 118
 119 #ifdef IAMSUID
 120 #ifndef DOSUID
 121 #define DOSUID
 122 #endif
 123 #endif /* IAMSUID */
 124
 125 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 126 #ifdef DOSUID
 127 #undef DOSUID
 128 #endif
 129 #endif
 130
 131 static void
 132 S_init_tls_and_interp(PerlInterpreter *my_perl)
 133 {
 134     dVAR;
 135     if (!PL_curinterp) {
 136         PERL_SET_INTERP(my_perl);
 137 #if defined(USE_ITHREADS)
 138         INIT_THREADS;
 139         ALLOC_THREAD_KEY;
 140         PERL_SET_THX(my_perl);
 141         OP_REFCNT_INIT;
 142         MUTEX_INIT(&PL_dollarzero_mutex);
 143 #  endif
 144     }
 145     else {
 146         PERL_SET_THX(my_perl);
 147     }
 148 }
 149
 150 #ifdef PERL_IMPLICIT_SYS
 151 PerlInterpreter *
 152 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
 153                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
 154                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
 155                  struct IPerlDir* ipD, struct IPerlSock* ipS,
 156                  struct IPerlProc* ipP)
 157 {
 158     PerlInterpreter *my_perl;
 159     /* New() needs interpreter, so call malloc() instead */
 160     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
 161     S_init_tls_and_interp(my_perl);
 162     Zero(my_perl, 1, PerlInterpreter);
 163     PL_Mem = ipM;
 164     PL_MemShared = ipMS;
 165     PL_MemParse = ipMP;
 166     PL_Env = ipE;
 167     PL_StdIO = ipStd;
 168     PL_LIO = ipLIO;
 169     PL_Dir = ipD;
 170     PL_Sock = ipS;
 171     PL_Proc = ipP;
 172
 173     return my_perl;
 174 }
 175 #else
 176
 177 /*
 178 =head1 Embedding Functions
 179
 180 =for apidoc perl_alloc
 181
 182 Allocates a new Perl interpreter.  See L<perlembed>.
 183
 184 =cut
 185 */
 186
 187 PerlInterpreter *
 188 perl_alloc(void)
 189 {
 190     PerlInterpreter *my_perl;
 191
 192     /* New() needs interpreter, so call malloc() instead */
 193     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
 194
 195     S_init_tls_and_interp(my_perl);
 196     return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
 197 }
 198 #endif /* PERL_IMPLICIT_SYS */
 199
 200 /*
 201 =for apidoc perl_construct
 202
 203 Initializes a new Perl interpreter.  See L<perlembed>.
 204
 205 =cut
 206 */
 207
 208 void
 209 perl_construct(pTHXx)
 210 {
 211     dVAR;
 212 #ifdef MULTIPLICITY
 213     init_interp();
 214     PL_perl_destruct_level = 1;
 215 #else
 216    if (PL_perl_destruct_level > 0)
 217        init_interp();
 218 #endif
 219    /* Init the real globals (and main thread)? */
 220     if (!PL_linestr) {
 221         PL_curcop = &PL_compiling;      /* needed by ckWARN, right away */
 222
 223         PL_linestr = NEWSV(65,79);
 224         sv_upgrade(PL_linestr,SVt_PVIV);
 225
 226         if (!SvREADONLY(&PL_sv_undef)) {
 227             /* set read-only and try to insure than we wont see REFCNT==0
 228                very often */
 229
 230             SvREADONLY_on(&PL_sv_undef);
 231             SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
 232
 233             sv_setpv(&PL_sv_no,PL_No);
 234             /* value lookup in void context - happens to have the side effect
 235                of caching the numeric forms.  */
 236             SvIV(&PL_sv_no);
 237             SvNV(&PL_sv_no);
 238             SvREADONLY_on(&PL_sv_no);
 239             SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
 240
 241             sv_setpv(&PL_sv_yes,PL_Yes);
 242             SvIV(&PL_sv_yes);
 243             SvNV(&PL_sv_yes);
 244             SvREADONLY_on(&PL_sv_yes);
 245             SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
 246
 247             SvREADONLY_on(&PL_sv_placeholder);
 248             SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
 249         }
 250
 251         PL_sighandlerp = Perl_sighandler;
 252         PL_pidstatus = newHV();
 253     }
 254
 255     PL_rs = newSVpvn("\n", 1);
 256
 257     init_stacks();
 258
 259     init_ids();
 260     PL_lex_state = LEX_NOTPARSING;
 261
 262     JMPENV_BOOTSTRAP;
 263     STATUS_ALL_SUCCESS;
 264
 265     init_i18nl10n(1);
 266     SET_NUMERIC_STANDARD();
 267
 268 #if defined(LOCAL_PATCH_COUNT)
 269     PL_localpatches = local_patches;    /* For possible -v */
 270 #endif
 271
 272 #ifdef HAVE_INTERP_INTERN
 273     sys_intern_init();
 274 #endif
 275
 276     PerlIO_init(aTHX);                  /* Hook to IO system */
 277
 278     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
 279     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
 280     PL_errors = newSVpvn("",0);
 281     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
 282     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
 283     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
 284 #ifdef USE_ITHREADS
 285     PL_regex_padav = newAV();
 286     av_push(PL_regex_padav,(SV*)newAV());    /* First entry is an array of empty elements */
 287     PL_regex_pad = AvARRAY(PL_regex_padav);
 288 #endif
 289 #ifdef USE_REENTRANT_API
 290     Perl_reentrant_init(aTHX);
 291 #endif
 292
 293     /* Note that strtab is a rather special HV.  Assumptions are made
 294        about not iterating on it, and not adding tie magic to it.
 295        It is properly deallocated in perl_destruct() */
 296     PL_strtab = newHV();
 297
 298     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
 299     hv_ksplit(PL_strtab, 512);
 300
 301 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
 302     _dyld_lookup_and_bind
 303         ("__environ", (unsigned long *) &environ_pointer, NULL);
 304 #endif /* environ */
 305
 306 #ifndef PERL_MICRO
 307 #   ifdef  USE_ENVIRON_ARRAY
 308     PL_origenviron = environ;
 309 #   endif
 310 #endif
 311
 312     /* Use sysconf(_SC_CLK_TCK) if available, if not
 313      * available or if the sysconf() fails, use the HZ.
 314      * BeOS has those, but returns the wrong value.
 315      * The HZ if not originally defined has been by now
 316      * been defined as CLK_TCK, if available. */
 317 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
 318     PL_clocktick = sysconf(_SC_CLK_TCK);
 319     if (PL_clocktick <= 0)
 320 #endif
 321          PL_clocktick = HZ;
 322
 323     PL_stashcache = newHV();
 324
 325     PL_patchlevel = newSVpv(
 326             Perl_form(aTHX_ "%d.%d.%d",
 327             (int)PERL_REVISION,
 328             (int)PERL_VERSION,
 329             (int)PERL_SUBVERSION ), 0
 330     );
 331
 332 #ifdef HAS_MMAP
 333     if (!PL_mmap_page_size) {
 334 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
 335       {
 336         SETERRNO(0, SS_NORMAL);
 337 #   ifdef _SC_PAGESIZE
 338         PL_mmap_page_size = sysconf(_SC_PAGESIZE);
 339 #   else
 340         PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
 341 #   endif
 342         if ((long) PL_mmap_page_size < 0) {
 343           if (errno) {
 344             SV *error = ERRSV;
 345             (void) SvUPGRADE(error, SVt_PV);
 346             Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
 347           }
 348           else
 349             Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
 350         }
 351       }
 352 #else
 353 #   ifdef HAS_GETPAGESIZE
 354       PL_mmap_page_size = getpagesize();
 355 #   else
 356 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
 357       PL_mmap_page_size = PAGESIZE;       /* compiletime, bad */
 358 #       endif
 359 #   endif
 360 #endif
 361       if (PL_mmap_page_size <= 0)
 362         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
 363                    (IV) PL_mmap_page_size);
 364     }
 365 #endif /* HAS_MMAP */
 366
 367 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
 368     PL_timesbase.tms_utime  = 0;
 369     PL_timesbase.tms_stime  = 0;
 370     PL_timesbase.tms_cutime = 0;
 371     PL_timesbase.tms_cstime = 0;
 372 #endif
 373
 374     ENTER;
 375 }
 376
 377 /*
 378 =for apidoc nothreadhook
 379
 380 Stub that provides thread hook for perl_destruct when there are
 381 no threads.
 382
 383 =cut
 384 */
 385
 386 int
 387 Perl_nothreadhook(pTHX)
 388 {
 389     return 0;
 390 }
 391
 392 /*
 393 =for apidoc perl_destruct
 394
 395 Shuts down a Perl interpreter.  See L<perlembed>.
 396
 397 =cut
 398 */
 399
 400 int
 401 perl_destruct(pTHXx)
 402 {
 403     dVAR;
 404     volatile int destruct_level;  /* 0=none, 1=full, 2=full with checks */
 405     HV *hv;
 406 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 407     int sock;
 408     pid_t child;
 409 #endif
 410
 411     /* wait for all pseudo-forked children to finish */
 412     PERL_WAIT_FOR_CHILDREN;
 413
 414     destruct_level = PL_perl_destruct_level;
 415 #ifdef DEBUGGING
 416     {
 417         const char *s;
 418         if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
 419             const int i = atoi(s);
 420             if (destruct_level < i)
 421                 destruct_level = i;
 422         }
 423     }
 424 #endif
 425
 426     if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
 427         dJMPENV;
 428         int x = 0;
 429
 430         JMPENV_PUSH(x);
 431         PERL_UNUSED_VAR(x);
 432         if (PL_endav && !PL_minus_c)
 433             call_list(PL_scopestack_ix, PL_endav);
 434         JMPENV_POP;
 435     }
 436     LEAVE;
 437     FREETMPS;
 438
 439     /* Need to flush since END blocks can produce output */
 440     my_fflush_all();
 441
 442     if (CALL_FPTR(PL_threadhook)(aTHX)) {
 443         /* Threads hook has vetoed further cleanup */
 444         return STATUS_NATIVE_EXPORT;
 445     }
 446
 447 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 448     if (destruct_level != 0) {
 449         /* Fork here to create a child. Our child's job is to preserve the
 450            state of scalars prior to destruction, so that we can instruct it
 451            to dump any scalars that we later find have leaked.
 452            There's no subtlety in this code - it assumes POSIX, and it doesn't
 453            fail gracefully  */
 454         int fd[2];
 455
 456         if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
 457             perror("Debug leaking scalars socketpair failed");
 458             abort();
 459         }
 460
 461         child = fork();
 462         if(child == -1) {
 463             perror("Debug leaking scalars fork failed");
 464             abort();
 465         }
 466         if (!child) {
 467             /* We are the child */
 468             close(fd[0]);
 469             sock = fd[1];
 470
 471             while (1) {
 472                 SV *target;
 473                 ssize_t got = read(sock, &target, sizeof(target));
 474
 475                 if(got == 0)
 476                     break;
 477                 if(got < 0) {
 478                     perror("Debug leaking scalars child read failed");
 479                     abort();
 480                 }
 481                 if(got < sizeof(target)) {
 482                     perror("Debug leaking scalars child short read");
 483                     abort();
 484                 }
 485                 sv_dump(target);
 486                 PerlIO_flush(Perl_debug_log);
 487
 488                 /* Write something back as synchronisation.  */
 489                 got = write(sock, &target, sizeof(target));
 490
 491                 if(got < 0) {
 492                     perror("Debug leaking scalars child write failed");
 493                     abort();
 494                 }
 495                 if(got < sizeof(target)) {
 496                     perror("Debug leaking scalars child short write");
 497                     abort();
 498                 }
 499             }
 500             _exit(0);
 501         }
 502         sock = fd[0];
 503         close(fd[1]);
 504     }
 505 #endif
 506
 507     /* We must account for everything.  */
 508
 509     /* Destroy the main CV and syntax tree */
 510     if (PL_main_root) {
 511         /* ensure comppad/curpad to refer to main's pad */
 512         if (CvPADLIST(PL_main_cv)) {
 513             PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
 514         }
 515         op_free(PL_main_root);
 516         PL_main_root = Nullop;
 517     }
 518     PL_curcop = &PL_compiling;
 519     PL_main_start = Nullop;
 520     SvREFCNT_dec(PL_main_cv);
 521     PL_main_cv = Nullcv;
 522     PL_dirty = TRUE;
 523
 524     /* Tell PerlIO we are about to tear things apart in case
 525        we have layers which are using resources that should
 526        be cleaned up now.
 527      */
 528
 529     PerlIO_destruct(aTHX);
 530
 531     if (PL_sv_objcount) {
 532         /*
 533          * Try to destruct global references.  We do this first so that the
 534          * destructors and destructees still exist.  Some sv's might remain.
 535          * Non-referenced objects are on their own.
 536          */
 537         sv_clean_objs();
 538         PL_sv_objcount = 0;
 539     }
 540
 541     /* unhook hooks which will soon be, or use, destroyed data */
 542     SvREFCNT_dec(PL_warnhook);
 543     PL_warnhook = Nullsv;
 544     SvREFCNT_dec(PL_diehook);
 545     PL_diehook = Nullsv;
 546
 547     /* call exit list functions */
 548     while (PL_exitlistlen-- > 0)
 549         PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
 550
 551     Safefree(PL_exitlist);
 552
 553     PL_exitlist = NULL;
 554     PL_exitlistlen = 0;
 555
 556     if (destruct_level == 0){
 557
 558         DEBUG_P(debprofdump());
 559
 560 #if defined(PERLIO_LAYERS)
 561         /* No more IO - including error messages ! */
 562         PerlIO_cleanup(aTHX);
 563 #endif
 564
 565         /* The exit() function will do everything that needs doing. */
 566         return STATUS_NATIVE_EXPORT;
 567     }
 568
 569     /* jettison our possibly duplicated environment */
 570     /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
 571      * so we certainly shouldn't free it here
 572      */
 573 #ifndef PERL_MICRO
 574 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
 575     if (environ != PL_origenviron && !PL_use_safe_putenv
 576 #ifdef USE_ITHREADS
 577         /* only main thread can free environ[0] contents */
 578         && PL_curinterp == aTHX
 579 #endif
 580         )
 581     {
 582         I32 i;
 583
 584         for (i = 0; environ[i]; i++)
 585             safesysfree(environ[i]);
 586
 587         /* Must use safesysfree() when working with environ. */
 588         safesysfree(environ);
 589
 590         environ = PL_origenviron;
 591     }
 592 #endif
 593 #endif /* !PERL_MICRO */
 594
 595     /* reset so print() ends up where we expect */
 596     setdefout(Nullgv);
 597
 598 #ifdef USE_ITHREADS
 599     /* the syntax tree is shared between clones
 600      * so op_free(PL_main_root) only ReREFCNT_dec's
 601      * REGEXPs in the parent interpreter
 602      * we need to manually ReREFCNT_dec for the clones
 603      */
 604     {
 605         I32 i = AvFILLp(PL_regex_padav) + 1;
 606         SV **ary = AvARRAY(PL_regex_padav);
 607
 608         while (i) {
 609             SV *resv = ary[--i];
 610
 611             if (SvFLAGS(resv) & SVf_BREAK) {
 612                 /* this is PL_reg_curpm, already freed
 613                  * flag is set in regexec.c:S_regtry
 614                  */
 615                 SvFLAGS(resv) &= ~SVf_BREAK;
 616             }
 617             else if(SvREPADTMP(resv)) {
 618               SvREPADTMP_off(resv);
 619             }
 620             else if(SvIOKp(resv)) {
 621                 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
 622                 ReREFCNT_dec(re);
 623             }
 624         }
 625     }
 626     SvREFCNT_dec(PL_regex_padav);
 627     PL_regex_padav = Nullav;
 628     PL_regex_pad = NULL;
 629 #endif
 630
 631     SvREFCNT_dec((SV*) PL_stashcache);
 632     PL_stashcache = NULL;
 633
 634     /* loosen bonds of global variables */
 635
 636     if(PL_rsfp) {
 637         (void)PerlIO_close(PL_rsfp);
 638         PL_rsfp = Nullfp;
 639     }
 640
 641     /* Filters for program text */
 642     SvREFCNT_dec(PL_rsfp_filters);
 643     PL_rsfp_filters = Nullav;
 644
 645     /* switches */
 646     PL_preprocess   = FALSE;
 647     PL_minus_n      = FALSE;
 648     PL_minus_p      = FALSE;
 649     PL_minus_l      = FALSE;
 650     PL_minus_a      = FALSE;
 651     PL_minus_F      = FALSE;
 652     PL_doswitches   = FALSE;
 653     PL_dowarn       = G_WARN_OFF;
 654     PL_doextract    = FALSE;
 655     PL_sawampersand = FALSE;    /* must save all match strings */
 656     PL_unsafe       = FALSE;
 657
 658     Safefree(PL_inplace);
 659     PL_inplace = Nullch;
 660     SvREFCNT_dec(PL_patchlevel);
 661
 662     if (PL_e_script) {
 663         SvREFCNT_dec(PL_e_script);
 664         PL_e_script = Nullsv;
 665     }
 666
 667     PL_perldb = 0;
 668
 669     /* magical thingies */
 670
 671     SvREFCNT_dec(PL_ofs_sv);    /* $, */
 672     PL_ofs_sv = Nullsv;
 673
 674     SvREFCNT_dec(PL_ors_sv);    /* $\ */
 675     PL_ors_sv = Nullsv;
 676
 677     SvREFCNT_dec(PL_rs);        /* $/ */
 678     PL_rs = Nullsv;
 679
 680     PL_multiline = 0;           /* $* */
 681     Safefree(PL_osname);        /* $^O */
 682     PL_osname = Nullch;
 683
 684     SvREFCNT_dec(PL_statname);
 685     PL_statname = Nullsv;
 686     PL_statgv = Nullgv;
 687
 688     /* defgv, aka *_ should be taken care of elsewhere */
 689
 690     /* clean up after study() */
 691     SvREFCNT_dec(PL_lastscream);
 692     PL_lastscream = Nullsv;
 693     Safefree(PL_screamfirst);
 694     PL_screamfirst = 0;
 695     Safefree(PL_screamnext);
 696     PL_screamnext  = 0;
 697
 698     /* float buffer */
 699     Safefree(PL_efloatbuf);
 700     PL_efloatbuf = Nullch;
 701     PL_efloatsize = 0;
 702
 703     /* startup and shutdown function lists */
 704     SvREFCNT_dec(PL_beginav);
 705     SvREFCNT_dec(PL_beginav_save);
 706     SvREFCNT_dec(PL_endav);
 707     SvREFCNT_dec(PL_checkav);
 708     SvREFCNT_dec(PL_checkav_save);
 709     SvREFCNT_dec(PL_initav);
 710     PL_beginav = Nullav;
 711     PL_beginav_save = Nullav;
 712     PL_endav = Nullav;
 713     PL_checkav = Nullav;
 714     PL_checkav_save = Nullav;
 715     PL_initav = Nullav;
 716
 717     /* shortcuts just get cleared */
 718     PL_envgv = Nullgv;
 719     PL_incgv = Nullgv;
 720     PL_hintgv = Nullgv;
 721     PL_errgv = Nullgv;
 722     PL_argvgv = Nullgv;
 723     PL_argvoutgv = Nullgv;
 724     PL_stdingv = Nullgv;
 725     PL_stderrgv = Nullgv;
 726     PL_last_in_gv = Nullgv;
 727     PL_replgv = Nullgv;
 728     PL_DBgv = Nullgv;
 729     PL_DBline = Nullgv;
 730     PL_DBsub = Nullgv;
 731     PL_DBsingle = Nullsv;
 732     PL_DBtrace = Nullsv;
 733     PL_DBsignal = Nullsv;
 734     PL_DBassertion = Nullsv;
 735     PL_DBcv = Nullcv;
 736     PL_dbargs = Nullav;
 737     PL_debstash = Nullhv;
 738
 739     SvREFCNT_dec(PL_argvout_stack);
 740     PL_argvout_stack = Nullav;
 741
 742     SvREFCNT_dec(PL_modglobal);
 743     PL_modglobal = Nullhv;
 744     SvREFCNT_dec(PL_preambleav);
 745     PL_preambleav = Nullav;
 746     SvREFCNT_dec(PL_subname);
 747     PL_subname = Nullsv;
 748     SvREFCNT_dec(PL_linestr);
 749     PL_linestr = Nullsv;
 750     SvREFCNT_dec(PL_pidstatus);
 751     PL_pidstatus = Nullhv;
 752     SvREFCNT_dec(PL_toptarget);
 753     PL_toptarget = Nullsv;
 754     SvREFCNT_dec(PL_bodytarget);
 755     PL_bodytarget = Nullsv;
 756     PL_formtarget = Nullsv;
 757
 758     /* free locale stuff */
 759 #ifdef USE_LOCALE_COLLATE
 760     Safefree(PL_collation_name);
 761     PL_collation_name = Nullch;
 762 #endif
 763
 764 #ifdef USE_LOCALE_NUMERIC
 765     Safefree(PL_numeric_name);
 766     PL_numeric_name = Nullch;
 767     SvREFCNT_dec(PL_numeric_radix_sv);
 768     PL_numeric_radix_sv = Nullsv;
 769 #endif
 770
 771     /* clear utf8 character classes */
 772     SvREFCNT_dec(PL_utf8_alnum);
 773     SvREFCNT_dec(PL_utf8_alnumc);
 774     SvREFCNT_dec(PL_utf8_ascii);
 775     SvREFCNT_dec(PL_utf8_alpha);
 776     SvREFCNT_dec(PL_utf8_space);
 777     SvREFCNT_dec(PL_utf8_cntrl);
 778     SvREFCNT_dec(PL_utf8_graph);
 779     SvREFCNT_dec(PL_utf8_digit);
 780     SvREFCNT_dec(PL_utf8_upper);
 781     SvREFCNT_dec(PL_utf8_lower);
 782     SvREFCNT_dec(PL_utf8_print);
 783     SvREFCNT_dec(PL_utf8_punct);
 784     SvREFCNT_dec(PL_utf8_xdigit);
 785     SvREFCNT_dec(PL_utf8_mark);
 786     SvREFCNT_dec(PL_utf8_toupper);
 787     SvREFCNT_dec(PL_utf8_totitle);
 788     SvREFCNT_dec(PL_utf8_tolower);
 789     SvREFCNT_dec(PL_utf8_tofold);
 790     SvREFCNT_dec(PL_utf8_idstart);
 791     SvREFCNT_dec(PL_utf8_idcont);
 792     PL_utf8_alnum       = Nullsv;
 793     PL_utf8_alnumc      = Nullsv;
 794     PL_utf8_ascii       = Nullsv;
 795     PL_utf8_alpha       = Nullsv;
 796     PL_utf8_space       = Nullsv;
 797     PL_utf8_cntrl       = Nullsv;
 798     PL_utf8_graph       = Nullsv;
 799     PL_utf8_digit       = Nullsv;
 800     PL_utf8_upper       = Nullsv;
 801     PL_utf8_lower       = Nullsv;
 802     PL_utf8_print       = Nullsv;
 803     PL_utf8_punct       = Nullsv;
 804     PL_utf8_xdigit      = Nullsv;
 805     PL_utf8_mark        = Nullsv;
 806     PL_utf8_toupper     = Nullsv;
 807     PL_utf8_totitle     = Nullsv;
 808     PL_utf8_tolower     = Nullsv;
 809     PL_utf8_tofold      = Nullsv;
 810     PL_utf8_idstart     = Nullsv;
 811     PL_utf8_idcont      = Nullsv;
 812
 813     if (!specialWARN(PL_compiling.cop_warnings))
 814         SvREFCNT_dec(PL_compiling.cop_warnings);
 815     PL_compiling.cop_warnings = Nullsv;
 816     if (!specialCopIO(PL_compiling.cop_io))
 817         SvREFCNT_dec(PL_compiling.cop_io);
 818     PL_compiling.cop_io = Nullsv;
 819     CopFILE_free(&PL_compiling);
 820     CopSTASH_free(&PL_compiling);
 821
 822     /* Prepare to destruct main symbol table.  */
 823
 824     hv = PL_defstash;
 825     PL_defstash = 0;
 826     SvREFCNT_dec(hv);
 827     SvREFCNT_dec(PL_curstname);
 828     PL_curstname = Nullsv;
 829
 830     /* clear queued errors */
 831     SvREFCNT_dec(PL_errors);
 832     PL_errors = Nullsv;
 833
 834     FREETMPS;
 835     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 836         if (PL_scopestack_ix != 0)
 837             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 838                  "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 839                  (long)PL_scopestack_ix);
 840         if (PL_savestack_ix != 0)
 841             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 842                  "Unbalanced saves: %ld more saves than restores\n",
 843                  (long)PL_savestack_ix);
 844         if (PL_tmps_floor != -1)
 845             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
 846                  (long)PL_tmps_floor + 1);
 847         if (cxstack_ix != -1)
 848             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
 849                  (long)cxstack_ix + 1);
 850     }
 851
 852     /* Now absolutely destruct everything, somehow or other, loops or no. */
 853     SvFLAGS(PL_fdpid) |= SVTYPEMASK;            /* don't clean out pid table now */
 854     SvFLAGS(PL_strtab) |= SVTYPEMASK;           /* don't clean out strtab now */
 855
 856     /* the 2 is for PL_fdpid and PL_strtab */
 857     while (PL_sv_count > 2 && sv_clean_all())
 858         ;
 859
 860     SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
 861     SvFLAGS(PL_fdpid) |= SVt_PVAV;
 862     SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
 863     SvFLAGS(PL_strtab) |= SVt_PVHV;
 864
 865     AvREAL_off(PL_fdpid);               /* no surviving entries */
 866     SvREFCNT_dec(PL_fdpid);             /* needed in io_close() */
 867     PL_fdpid = Nullav;
 868
 869 #ifdef HAVE_INTERP_INTERN
 870     sys_intern_clear();
 871 #endif
 872
 873     /* Destruct the global string table. */
 874     {
 875         /* Yell and reset the HeVAL() slots that are still holding refcounts,
 876          * so that sv_free() won't fail on them.
 877          * Now that the global string table is using a single hunk of memory
 878          * for both HE and HEK, we either need to explicitly unshare it the
 879          * correct way, or actually free things here.
 880          */
 881         I32 riter = 0;
 882         const I32 max = HvMAX(PL_strtab);
 883         HE **array = HvARRAY(PL_strtab);
 884         HE *hent = array[0];
 885
 886         for (;;) {
 887             if (hent && ckWARN_d(WARN_INTERNAL)) {
 888                 HE *next = HeNEXT(hent);
 889                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 890                      "Unbalanced string table refcount: (%d) for \"%s\"",
 891                      HeVAL(hent) - Nullsv, HeKEY(hent));
 892                 Safefree(hent);
 893                 hent = next;
 894             }
 895             if (!hent) {
 896                 if (++riter > max)
 897                     break;
 898                 hent = array[riter];
 899             }
 900         }
 901
 902         Safefree(array);
 903         HvARRAY(PL_strtab) = 0;
 904         HvTOTALKEYS(PL_strtab) = 0;
 905         HvFILL(PL_strtab) = 0;
 906     }
 907     SvREFCNT_dec(PL_strtab);
 908
 909 #ifdef USE_ITHREADS
 910     /* free the pointer tables used for cloning */
 911     ptr_table_free(PL_ptr_table);
 912     PL_ptr_table = (PTR_TBL_t*)NULL;
 913 #endif
 914
 915     /* free special SVs */
 916
 917     SvREFCNT(&PL_sv_yes) = 0;
 918     sv_clear(&PL_sv_yes);
 919     SvANY(&PL_sv_yes) = NULL;
 920     SvFLAGS(&PL_sv_yes) = 0;
 921
 922     SvREFCNT(&PL_sv_no) = 0;
 923     sv_clear(&PL_sv_no);
 924     SvANY(&PL_sv_no) = NULL;
 925     SvFLAGS(&PL_sv_no) = 0;
 926
 927     {
 928         int i;
 929         for (i=0; i<=2; i++) {
 930             SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
 931             sv_clear(PERL_DEBUG_PAD(i));
 932             SvANY(PERL_DEBUG_PAD(i)) = NULL;
 933             SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
 934         }
 935     }
 936
 937     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 938         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
 939
 940 #ifdef DEBUG_LEAKING_SCALARS
 941     if (PL_sv_count != 0) {
 942         SV* sva;
 943         SV* sv;
 944         register SV* svend;
 945
 946         for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 947             svend = &sva[SvREFCNT(sva)];
 948             for (sv = sva + 1; sv < svend; ++sv) {
 949                 if (SvTYPE(sv) != SVTYPEMASK) {
 950 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 951                     ssize_t got;
 952                     SV *target;
 953 #endif
 954
 955                     PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
 956                         " flags=0x%"UVxf
 957                         " refcnt=%"UVuf pTHX__FORMAT "\n"
 958                         "\tallocated at %s:%d %s %s%s\n",
 959                         sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
 960                         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
 961                         sv->sv_debug_line,
 962                         sv->sv_debug_inpad ? "for" : "by",
 963                         sv->sv_debug_optype ?
 964                             PL_op_name[sv->sv_debug_optype]: "(none)",
 965                         sv->sv_debug_cloned ? " (cloned)" : ""
 966                     );
 967
 968 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 969                     PerlIO_flush(Perl_debug_log);
 970
 971                     got = write(sock, &sv, sizeof(sv));
 972
 973                     if(got < 0) {
 974                         perror("Debug leaking scalars parent write failed");
 975                         abort();
 976                     }
 977                     if(got < sizeof(target)) {
 978                         perror("Debug leaking scalars parent short write");
 979                         abort();
 980                     }
 981
 982                     got = read(sock, &target, sizeof(target));
 983
 984                     if(got < 0) {
 985                         perror("Debug leaking scalars parent read failed");
 986                         abort();
 987                     }
 988                     if(got < sizeof(target)) {
 989                         perror("Debug leaking scalars parent short read");
 990                         abort();
 991                     }
 992 #endif
 993                 }
 994             }
 995         }
 996     }
 997 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 998     {
 999         int status;
1000         fd_set rset;
1001         /* Wait for up to 4 seconds for child to terminate.
1002            This seems to be the least effort way of timing out on reaping
1003            its exit status.  */
1004         struct timeval waitfor = {4, 0};
1005
1006         shutdown(sock, 1);
1007         FD_ZERO(&rset);
1008         FD_SET(sock, &rset);
1009         select(sock + 1, &rset, NULL, NULL, &waitfor);
1010         waitpid(child, &status, WNOHANG);
1011         close(sock);
1012     }
1013 #endif
1014 #endif
1015     PL_sv_count = 0;
1016
1017
1018 #if defined(PERLIO_LAYERS)
1019     /* No more IO - including error messages ! */
1020     PerlIO_cleanup(aTHX);
1021 #endif
1022
1023     /* sv_undef needs to stay immortal until after PerlIO_cleanup
1024        as currently layers use it rather than Nullsv as a marker
1025        for no arg - and will try and SvREFCNT_dec it.
1026      */
1027     SvREFCNT(&PL_sv_undef) = 0;
1028     SvREADONLY_off(&PL_sv_undef);
1029
1030     Safefree(PL_origfilename);
1031     PL_origfilename = Nullch;
1032     Safefree(PL_reg_start_tmp);
1033     PL_reg_start_tmp = (char**)NULL;
1034     PL_reg_start_tmpl = 0;
1035     if (PL_reg_curpm)
1036         Safefree(PL_reg_curpm);
1037     Safefree(PL_reg_poscache);
1038     free_tied_hv_pool();
1039     Safefree(PL_op_mask);
1040     Safefree(PL_psig_ptr);
1041     PL_psig_ptr = (SV**)NULL;
1042     Safefree(PL_psig_name);
1043     PL_psig_name = (SV**)NULL;
1044     Safefree(PL_bitcount);
1045     PL_bitcount = Nullch;
1046     Safefree(PL_psig_pend);
1047     PL_psig_pend = (int*)NULL;
1048     PL_formfeed = Nullsv;
1049     nuke_stacks();
1050     PL_tainting = FALSE;
1051     PL_taint_warn = FALSE;
1052     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
1053     PL_debug = 0;
1054
1055     DEBUG_P(debprofdump());
1056
1057 #ifdef USE_REENTRANT_API
1058     Perl_reentrant_free(aTHX);
1059 #endif
1060
1061     sv_free_arenas();
1062
1063     /* As the absolutely last thing, free the non-arena SV for mess() */
1064
1065     if (PL_mess_sv) {
1066         /* we know that type == SVt_PVMG */
1067
1068         /* it could have accumulated taint magic */
1069         MAGIC* mg;
1070         MAGIC* moremagic;
1071         for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1072             moremagic = mg->mg_moremagic;
1073             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1074                 && mg->mg_len >= 0)
1075                 Safefree(mg->mg_ptr);
1076             Safefree(mg);
1077         }
1078
1079         /* we know that type >= SVt_PV */
1080         SvPV_free(PL_mess_sv);
1081         Safefree(SvANY(PL_mess_sv));
1082         Safefree(PL_mess_sv);
1083         PL_mess_sv = Nullsv;
1084     }
1085     return STATUS_NATIVE_EXPORT;
1086 }
1087
1088 /*
1089 =for apidoc perl_free
1090
1091 Releases a Perl interpreter.  See L<perlembed>.
1092
1093 =cut
1094 */
1095
1096 void
1097 perl_free(pTHXx)
1098 {
1099 #if defined(WIN32) || defined(NETWARE)
1100 #  if defined(PERL_IMPLICIT_SYS)
1101 #    ifdef NETWARE
1102     void *host = nw_internal_host;
1103 #    else
1104     void *host = w32_internal_host;
1105 #    endif
1106     PerlMem_free(aTHXx);
1107 #    ifdef NETWARE
1108     nw_delete_internal_host(host);
1109 #    else
1110     win32_delete_internal_host(host);
1111 #    endif
1112 #  else
1113     PerlMem_free(aTHXx);
1114 #  endif
1115 #else
1116     PerlMem_free(aTHXx);
1117 #endif
1118 }
1119
1120 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
1121 /* provide destructors to clean up the thread key when libperl is unloaded */
1122 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1123
1124 #if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
1125 #pragma fini "perl_fini"
1126 #endif
1127
1128 static void
1129 #if defined(__GNUC__)
1130 __attribute__((destructor))
1131 #endif
1132 perl_fini(void)
1133 {
1134     dVAR;
1135     if (PL_curinterp)
1136         FREE_THREAD_KEY;
1137 }
1138
1139 #endif /* WIN32 */
1140 #endif /* THREADS */
1141
1142 void
1143 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1144 {
1145     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1146     PL_exitlist[PL_exitlistlen].fn = fn;
1147     PL_exitlist[PL_exitlistlen].ptr = ptr;
1148     ++PL_exitlistlen;
1149 }
1150
1151 #ifdef HAS_PROCSELFEXE
1152 /* This is a function so that we don't hold on to MAXPATHLEN
1153    bytes of stack longer than necessary
1154  */
1155 STATIC void
1156 S_procself_val(pTHX_ SV *sv, const char *arg0)
1157 {
1158     char buf[MAXPATHLEN];
1159     int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1160
1161     /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1162        includes a spurious NUL which will cause $^X to fail in system
1163        or backticks (this will prevent extensions from being built and
1164        many tests from working). readlink is not meant to add a NUL.
1165        Normal readlink works fine.
1166      */
1167     if (len > 0 && buf[len-1] == '\0') {
1168       len--;
1169     }
1170
1171     /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1172        returning the text "unknown" from the readlink rather than the path
1173        to the executable (or returning an error from the readlink).  Any valid
1174        path has a '/' in it somewhere, so use that to validate the result.
1175        See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1176     */
1177     if (len > 0 && memchr(buf, '/', len)) {
1178         sv_setpvn(sv,buf,len);
1179     }
1180     else {
1181         sv_setpv(sv,arg0);
1182     }
1183 }
1184 #endif /* HAS_PROCSELFEXE */
1185
1186 STATIC void
1187 S_set_caret_X(pTHX) {
1188     GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
1189     if (tmpgv) {
1190 #ifdef HAS_PROCSELFEXE
1191         S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1192 #else
1193 #ifdef OS2
1194         sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
1195 #else
1196         sv_setpv(GvSV(tmpgv),PL_origargv[0]);
1197 #endif
1198 #endif
1199     }
1200 }
1201
1202 /*
1203 =for apidoc perl_parse
1204
1205 Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
1206
1207 =cut
1208 */
1209
1210 int
1211 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1212 {
1213     dVAR;
1214     I32 oldscope;
1215     int ret;
1216     dJMPENV;
1217
1218 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1219 #ifdef IAMSUID
1220 #undef IAMSUID
1221     Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
1222 setuid perl scripts securely.\n");
1223 #endif /* IAMSUID */
1224 #endif
1225
1226 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1227     /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
1228      * This MUST be done before any hash stores or fetches take place.
1229      * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1230      * yourself, it is your responsibility to provide a good random seed!
1231      * You can also define PERL_HASH_SEED in compile time, see hv.h. */
1232     if (!PL_rehash_seed_set)
1233          PL_rehash_seed = get_hash_seed();
1234     {
1235         const char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1236
1237         if (s && (atoi(s) == 1))
1238             PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
1239     }
1240 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1241
1242     PL_origargc = argc;
1243     PL_origargv = argv;
1244
1245     {
1246         /* Set PL_origalen be the sum of the contiguous argv[]
1247          * elements plus the size of the env in case that it is
1248          * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
1249          * as the maximum modifiable length of $0.  In the worst case
1250          * the area we are able to modify is limited to the size of
1251          * the original argv[0].  (See below for 'contiguous', though.)
1252          * --jhi */
1253          const char *s = NULL;
1254          int i;
1255          const UV mask =
1256            ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1257          /* Do the mask check only if the args seem like aligned. */
1258          const UV aligned =
1259            (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1260
1261          /* See if all the arguments are contiguous in memory.  Note
1262           * that 'contiguous' is a loose term because some platforms
1263           * align the argv[] and the envp[].  If the arguments look
1264           * like non-aligned, assume that they are 'strictly' or
1265           * 'traditionally' contiguous.  If the arguments look like
1266           * aligned, we just check that they are within aligned
1267           * PTRSIZE bytes.  As long as no system has something bizarre
1268           * like the argv[] interleaved with some other data, we are
1269           * fine.  (Did I just evoke Murphy's Law?)  --jhi */
1270          if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1271               while (*s) s++;
1272               for (i = 1; i < PL_origargc; i++) {
1273                    if ((PL_origargv[i] == s + 1
1274 #ifdef OS2
1275                         || PL_origargv[i] == s + 2
1276 #endif
1277                             )
1278                        ||
1279                        (aligned &&
1280                         (PL_origargv[i] >  s &&
1281                          PL_origargv[i] <=
1282                          INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1283                         )
1284                    {
1285                         s = PL_origargv[i];
1286                         while (*s) s++;
1287                    }
1288                    else
1289                         break;
1290               }
1291          }
1292          /* Can we grab env area too to be used as the area for $0? */
1293          if (PL_origenviron) {
1294               if ((PL_origenviron[0] == s + 1
1295 #ifdef OS2
1296                    || (PL_origenviron[0] == s + 9 && (s += 8))
1297 #endif
1298                   )
1299                   ||
1300                   (aligned &&
1301                    (PL_origenviron[0] >  s &&
1302                     PL_origenviron[0] <=
1303                     INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1304                  )
1305               {
1306 #ifndef OS2
1307                    s = PL_origenviron[0];
1308                    while (*s) s++;
1309 #endif
1310                    my_setenv("NoNe  SuCh", Nullch);
1311                    /* Force copy of environment. */
1312                    for (i = 1; PL_origenviron[i]; i++) {
1313                         if (PL_origenviron[i] == s + 1
1314                             ||
1315                             (aligned &&
1316                              (PL_origenviron[i] >  s &&
1317                               PL_origenviron[i] <=
1318                               INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1319                            )
1320                         {
1321                              s = PL_origenviron[i];
1322                              while (*s) s++;
1323                         }
1324                         else
1325                              break;
1326                    }
1327               }
1328          }
1329          PL_origalen = s - PL_origargv[0] + 1;
1330     }
1331
1332     if (PL_do_undump) {
1333
1334         /* Come here if running an undumped a.out. */
1335
1336         PL_origfilename = savepv(argv[0]);
1337         PL_do_undump = FALSE;
1338         cxstack_ix = -1;                /* start label stack again */
1339         init_ids();
1340         assert (!PL_tainted);
1341         TAINT;
1342         S_set_caret_X(aTHX);
1343         TAINT_NOT;
1344         init_postdump_symbols(argc,argv,env);
1345         return 0;
1346     }
1347
1348     if (PL_main_root) {
1349         op_free(PL_main_root);
1350         PL_main_root = Nullop;
1351     }
1352     PL_main_start = Nullop;
1353     SvREFCNT_dec(PL_main_cv);
1354     PL_main_cv = Nullcv;
1355
1356     time(&PL_basetime);
1357     oldscope = PL_scopestack_ix;
1358     PL_dowarn = G_WARN_OFF;
1359
1360     JMPENV_PUSH(ret);
1361     switch (ret) {
1362     case 0:
1363         parse_body(env,xsinit);
1364         if (PL_checkav)
1365             call_list(oldscope, PL_checkav);
1366         ret = 0;
1367         break;
1368     case 1:
1369         STATUS_ALL_FAILURE;
1370         /* FALL THROUGH */
1371     case 2:
1372         /* my_exit() was called */
1373         while (PL_scopestack_ix > oldscope)
1374             LEAVE;
1375         FREETMPS;
1376         PL_curstash = PL_defstash;
1377         if (PL_checkav)
1378             call_list(oldscope, PL_checkav);
1379         ret = STATUS_NATIVE_EXPORT;
1380         break;
1381     case 3:
1382         PerlIO_printf(Perl_error_log, "panic: top_env\n");
1383         ret = 1;
1384         break;
1385     }
1386     JMPENV_POP;
1387     return ret;
1388 }
1389
1390 STATIC void *
1391 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1392 {
1393     dVAR;
1394     int argc = PL_origargc;
1395     char **argv = PL_origargv;
1396     const char *scriptname = NULL;
1397     VOL bool dosearch = FALSE;
1398     const char *validarg = "";
1399     register SV *sv;
1400     register char *s;
1401     const char *cddir = Nullch;
1402 #ifdef USE_SITECUSTOMIZE
1403     bool minus_f = FALSE;
1404 #endif
1405
1406     PL_fdscript = -1;
1407     PL_suidscript = -1;
1408     sv_setpvn(PL_linestr,"",0);
1409     sv = newSVpvn("",0);                /* first used for -I flags */
1410     SAVEFREESV(sv);
1411     init_main_stash();
1412
1413     for (argc--,argv++; argc > 0; argc--,argv++) {
1414         if (argv[0][0] != '-' || !argv[0][1])
1415             break;
1416 #ifdef DOSUID
1417     if (*validarg)
1418         validarg = " PHOOEY ";
1419     else
1420         validarg = argv[0];
1421     /*
1422      * Can we rely on the kernel to start scripts with argv[1] set to
1423      * contain all #! line switches (the whole line)? (argv[0] is set to
1424      * the interpreter name, argv[2] to the script name; argv[3] and
1425      * above may contain other arguments.)
1426      */
1427 #endif
1428         s = argv[0]+1;
1429       reswitch:
1430         switch (*s) {
1431         case 'C':
1432 #ifndef PERL_STRICT_CR
1433         case '\r':
1434 #endif
1435         case ' ':
1436         case '0':
1437         case 'F':
1438         case 'a':
1439         case 'c':
1440         case 'd':
1441         case 'D':
1442         case 'h':
1443         case 'i':
1444         case 'l':
1445         case 'M':
1446         case 'm':
1447         case 'n':
1448         case 'p':
1449         case 's':
1450         case 'u':
1451         case 'U':
1452         case 'v':
1453         case 'W':
1454         case 'X':
1455         case 'w':
1456         case 'A':
1457             if ((s = moreswitches(s)))
1458                 goto reswitch;
1459             break;
1460
1461         case 't':
1462             CHECK_MALLOC_TOO_LATE_FOR('t');
1463             if( !PL_tainting ) {
1464                  PL_taint_warn = TRUE;
1465                  PL_tainting = TRUE;
1466             }
1467             s++;
1468             goto reswitch;
1469         case 'T':
1470             CHECK_MALLOC_TOO_LATE_FOR('T');
1471             PL_tainting = TRUE;
1472             PL_taint_warn = FALSE;
1473             s++;
1474             goto reswitch;
1475
1476         case 'e':
1477 #ifdef MACOS_TRADITIONAL
1478             /* ignore -e for Dev:Pseudo argument */
1479             if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1480                 break;
1481 #endif
1482             forbid_setid("-e");
1483             if (!PL_e_script) {
1484                 PL_e_script = newSVpvn("",0);
1485                 filter_add(read_e_script, NULL);
1486             }
1487             if (*++s)
1488                 sv_catpv(PL_e_script, s);
1489             else if (argv[1]) {
1490                 sv_catpv(PL_e_script, argv[1]);
1491                 argc--,argv++;
1492             }
1493             else
1494                 Perl_croak(aTHX_ "No code specified for -e");
1495             sv_catpv(PL_e_script, "\n");
1496             break;
1497
1498         case 'f':
1499 #ifdef USE_SITECUSTOMIZE
1500             minus_f = TRUE;
1501 #endif
1502             s++;
1503             goto reswitch;
1504
1505         case 'I':       /* -I handled both here and in moreswitches() */
1506             forbid_setid("-I");
1507             if (!*++s && (s=argv[1]) != Nullch) {
1508                 argc--,argv++;
1509             }
1510             if (s && *s) {
1511                 char *p;
1512                 STRLEN len = strlen(s);
1513                 p = savepvn(s, len);
1514                 incpush(p, TRUE, TRUE, FALSE, FALSE);
1515                 sv_catpvn(sv, "-I", 2);
1516                 sv_catpvn(sv, p, len);
1517                 sv_catpvn(sv, " ", 1);
1518                 Safefree(p);
1519             }
1520             else
1521                 Perl_croak(aTHX_ "No directory specified for -I");
1522             break;
1523         case 'P':
1524             forbid_setid("-P");
1525             PL_preprocess = TRUE;
1526             s++;
1527             goto reswitch;
1528         case 'S':
1529             forbid_setid("-S");
1530             dosearch = TRUE;
1531             s++;
1532             goto reswitch;
1533         case 'V':
1534             if (!PL_preambleav)
1535                 PL_preambleav = newAV();
1536             av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1537             if (*++s != ':')  {
1538                 STRLEN opts;
1539
1540                 PL_Sv = newSVpv("print myconfig();",0);
1541 #ifdef VMS
1542                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1543 #else
1544                 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1545 #endif
1546                 opts = SvCUR(PL_Sv);
1547
1548                 sv_catpv(PL_Sv,"\"  Compile-time options:");
1549 #  ifdef DEBUGGING
1550                 sv_catpv(PL_Sv," DEBUGGING");
1551 #  endif
1552 #  ifdef MULTIPLICITY
1553                 sv_catpv(PL_Sv," MULTIPLICITY");
1554 #  endif
1555 #  ifdef USE_5005THREADS
1556                 sv_catpv(PL_Sv," USE_5005THREADS");
1557 #  endif
1558 #  ifdef USE_ITHREADS
1559                 sv_catpv(PL_Sv," USE_ITHREADS");
1560 #  endif
1561 #  ifdef USE_64_BIT_INT
1562                 sv_catpv(PL_Sv," USE_64_BIT_INT");
1563 #  endif
1564 #  ifdef USE_64_BIT_ALL
1565                 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1566 #  endif
1567 #  ifdef USE_LONG_DOUBLE
1568                 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1569 #  endif
1570 #  ifdef USE_LARGE_FILES
1571                 sv_catpv(PL_Sv," USE_LARGE_FILES");
1572 #  endif
1573 #  ifdef USE_SOCKS
1574                 sv_catpv(PL_Sv," USE_SOCKS");
1575 #  endif
1576 #  ifdef USE_SITECUSTOMIZE
1577                 sv_catpv(PL_Sv," USE_SITECUSTOMIZE");
1578 #  endif
1579 #  ifdef PERL_IMPLICIT_CONTEXT
1580                 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1581 #  endif
1582 #  ifdef PERL_IMPLICIT_SYS
1583                 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1584 #  endif
1585
1586                 while (SvCUR(PL_Sv) > opts+76) {
1587                     /* find last space after "options: " and before col 76 */
1588
1589                     const char *space;
1590                     char *pv = SvPV_nolen(PL_Sv);
1591                     const char c = pv[opts+76];
1592                     pv[opts+76] = '\0';
1593                     space = strrchr(pv+opts+26, ' ');
1594                     pv[opts+76] = c;
1595                     if (!space) break; /* "Can't happen" */
1596
1597                     /* break the line before that space */
1598
1599                     opts = space - pv;
1600                     sv_insert(PL_Sv, opts, 0,
1601                               "\\n                       ", 25);
1602                 }
1603
1604                 sv_catpv(PL_Sv,"\\n\",");
1605
1606 #if defined(LOCAL_PATCH_COUNT)
1607                 if (LOCAL_PATCH_COUNT > 0) {
1608                     int i;
1609                     sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
1610                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1611                         if (PL_localpatches[i])
1612                             Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1613                                     0, PL_localpatches[i], 0);
1614                     }
1615                 }
1616 #endif
1617                 Perl_sv_catpvf(aTHX_ PL_Sv,"\"  Built under %s\\n\"",OSNAME);
1618 #ifdef __DATE__
1619 #  ifdef __TIME__
1620                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
1621 #  else
1622                 Perl_sv_catpvf(aTHX_ PL_Sv,",\"  Compiled on %s\\n\"",__DATE__);
1623 #  endif
1624 #endif
1625                 sv_catpv(PL_Sv, "; \
1626 $\"=\"\\n    \"; \
1627 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1628 #ifdef __CYGWIN__
1629                 sv_catpv(PL_Sv,"\
1630 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1631 #endif
1632                 sv_catpv(PL_Sv, "\
1633 print \"  \\%ENV:\\n    @env\\n\" if @env; \
1634 print \"  \\@INC:\\n    @INC\\n\";");
1635             }
1636             else {
1637                 PL_Sv = newSVpv("config_vars(qw(",0);
1638                 sv_catpv(PL_Sv, ++s);
1639                 sv_catpv(PL_Sv, "))");
1640                 s += strlen(s);
1641             }
1642             av_push(PL_preambleav, PL_Sv);
1643             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
1644             goto reswitch;
1645         case 'x':
1646             PL_doextract = TRUE;
1647             s++;
1648             if (*s)
1649                 cddir = s;
1650             break;
1651         case 0:
1652             break;
1653         case '-':
1654             if (!*++s || isSPACE(*s)) {
1655                 argc--,argv++;
1656                 goto switch_end;
1657             }
1658             /* catch use of gnu style long options */
1659             if (strEQ(s, "version")) {
1660                 s = (char *)"v";
1661                 goto reswitch;
1662             }
1663             if (strEQ(s, "help")) {
1664                 s = (char *)"h";
1665                 goto reswitch;
1666             }
1667             s--;
1668             /* FALL THROUGH */
1669         default:
1670             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
1671         }
1672     }
1673   switch_end:
1674
1675     if (
1676 #ifndef SECURE_INTERNAL_GETENV
1677         !PL_tainting &&
1678 #endif
1679         (s = PerlEnv_getenv("PERL5OPT")))
1680     {
1681         const char *popt = s;
1682         while (isSPACE(*s))
1683             s++;
1684         if (*s == '-' && *(s+1) == 'T') {
1685             CHECK_MALLOC_TOO_LATE_FOR('T');
1686             PL_tainting = TRUE;
1687             PL_taint_warn = FALSE;
1688         }
1689         else {
1690             char *popt_copy = Nullch;
1691             while (s && *s) {
1692                 char *d;
1693                 while (isSPACE(*s))
1694                     s++;
1695                 if (*s == '-') {
1696                     s++;
1697                     if (isSPACE(*s))
1698                         continue;
1699                 }
1700                 d = s;
1701                 if (!*s)
1702                     break;
1703                 if (!strchr("DIMUdmtwA", *s))
1704                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1705                 while (++s && *s) {
1706                     if (isSPACE(*s)) {
1707                         if (!popt_copy) {
1708                             popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1709                             s = popt_copy + (s - popt);
1710                             d = popt_copy + (d - popt);
1711                         }
1712                         *s++ = '\0';
1713                         break;
1714                     }
1715                 }
1716                 if (*d == 't') {
1717                     if( !PL_tainting ) {
1718                         PL_taint_warn = TRUE;
1719                         PL_tainting = TRUE;
1720                     }
1721                 } else {
1722                     moreswitches(d);
1723                 }
1724             }
1725         }
1726     }
1727
1728 #ifdef USE_SITECUSTOMIZE
1729     if (!minus_f) {
1730         if (!PL_preambleav)
1731             PL_preambleav = newAV();
1732         av_unshift(PL_preambleav, 1);
1733         (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
1734     }
1735 #endif
1736
1737     if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1738        PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1739     }
1740
1741     if (!scriptname)
1742         scriptname = argv[0];
1743     if (PL_e_script) {
1744         argc++,argv--;
1745         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
1746     }
1747     else if (scriptname == Nullch) {
1748 #ifdef MSDOS
1749         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1750             moreswitches("h");
1751 #endif
1752         scriptname = "-";
1753     }
1754
1755     /* Set $^X early so that it can be used for relocatable paths in @INC  */
1756     assert (!PL_tainted);
1757     TAINT;
1758     S_set_caret_X(aTHX);
1759     TAINT_NOT;
1760     init_perllib();
1761
1762     open_script(scriptname,dosearch,sv);
1763
1764     validate_suid(validarg, scriptname);
1765
1766 #ifndef PERL_MICRO
1767 #if defined(SIGCHLD) || defined(SIGCLD)
1768     {
1769 #ifndef SIGCHLD
1770 #  define SIGCHLD SIGCLD
1771 #endif
1772         Sighandler_t sigstate = rsignal_state(SIGCHLD);
1773         if (sigstate == SIG_IGN) {
1774             if (ckWARN(WARN_SIGNAL))
1775                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1776                             "Can't ignore signal CHLD, forcing to default");
1777             (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1778         }
1779     }
1780 #endif
1781 #endif
1782
1783 #ifdef MACOS_TRADITIONAL
1784     if (PL_doextract || gMacPerl_AlwaysExtract) {
1785 #else
1786     if (PL_doextract) {
1787 #endif
1788         find_beginning();
1789         if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
1790             Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1791
1792     }
1793
1794     PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1795     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1796     CvUNIQUE_on(PL_compcv);
1797
1798     CvPADLIST(PL_compcv) = pad_new(0);
1799 #ifdef USE_5005THREADS
1800     CvOWNER(PL_compcv) = 0;
1801     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1802     MUTEX_INIT(CvMUTEXP(PL_compcv));
1803 #endif /* USE_5005THREADS */
1804
1805     boot_core_PerlIO();
1806     boot_core_UNIVERSAL();
1807     boot_core_xsutils();
1808
1809     if (xsinit)
1810         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
1811 #ifndef PERL_MICRO
1812 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1813     init_os_extras();
1814 #endif
1815 #endif
1816
1817 #ifdef USE_SOCKS
1818 #   ifdef HAS_SOCKS5_INIT
1819     socks5_init(argv[0]);
1820 #   else
1821     SOCKSinit(argv[0]);
1822 #   endif
1823 #endif
1824
1825     init_predump_symbols();
1826     /* init_postdump_symbols not currently designed to be called */
1827     /* more than once (ENV isn't cleared first, for example)     */
1828     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
1829     if (!PL_do_undump)
1830         init_postdump_symbols(argc,argv,env);
1831
1832     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
1833      * or explicitly in some platforms.
1834      * locale.c:Perl_init_i18nl10n() if the environment
1835      * look like the user wants to use UTF-8. */
1836 #if defined(SYMBIAN)
1837     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
1838 #endif
1839     if (PL_unicode) {
1840          /* Requires init_predump_symbols(). */
1841          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1842               IO* io;
1843               PerlIO* fp;
1844               SV* sv;
1845
1846               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1847                * and the default open disciplines. */
1848               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1849                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
1850                   (fp = IoIFP(io)))
1851                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1852               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1853                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1854                   (fp = IoOFP(io)))
1855                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1856               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1857                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1858                   (fp = IoOFP(io)))
1859                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1860               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1861                   (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1862                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
1863                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1864                    if (in) {
1865                         if (out)
1866                              sv_setpvn(sv, ":utf8\0:utf8", 11);
1867                         else
1868                              sv_setpvn(sv, ":utf8\0", 6);
1869                    }
1870                    else if (out)
1871                         sv_setpvn(sv, "\0:utf8", 6);
1872                    SvSETMAGIC(sv);
1873               }
1874          }
1875     }
1876
1877     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1878          if (strEQ(s, "unsafe"))
1879               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
1880          else if (strEQ(s, "safe"))
1881               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1882          else
1883               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1884     }
1885
1886     init_lexer();
1887
1888     /* now parse the script */
1889
1890     SETERRNO(0,SS_NORMAL);
1891     PL_error_count = 0;
1892 #ifdef MACOS_TRADITIONAL
1893     if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1894         if (PL_minus_c)
1895             Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1896         else {
1897             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1898                        MacPerl_MPWFileName(PL_origfilename));
1899         }
1900     }
1901 #else
1902     if (yyparse() || PL_error_count) {
1903         if (PL_minus_c)
1904             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1905         else {
1906             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1907                        PL_origfilename);
1908         }
1909     }
1910 #endif
1911     CopLINE_set(PL_curcop, 0);
1912     PL_curstash = PL_defstash;
1913     PL_preprocess = FALSE;
1914     if (PL_e_script) {
1915         SvREFCNT_dec(PL_e_script);
1916         PL_e_script = Nullsv;
1917     }
1918
1919     if (PL_do_undump)
1920         my_unexec();
1921
1922     if (isWARN_ONCE) {
1923         SAVECOPFILE(PL_curcop);
1924         SAVECOPLINE(PL_curcop);
1925         gv_check(PL_defstash);
1926     }
1927
1928     LEAVE;
1929     FREETMPS;
1930
1931 #ifdef MYMALLOC
1932     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1933         dump_mstats("after compilation:");
1934 #endif
1935
1936     ENTER;
1937     PL_restartop = 0;
1938     return NULL;
1939 }
1940
1941 /*
1942 =for apidoc perl_run
1943
1944 Tells a Perl interpreter to run.  See L<perlembed>.
1945
1946 =cut
1947 */
1948
1949 int
1950 perl_run(pTHXx)
1951 {
1952     I32 oldscope;
1953     int ret = 0;
1954     dJMPENV;
1955
1956     oldscope = PL_scopestack_ix;
1957 #ifdef VMS
1958     VMSISH_HUSHED = 0;
1959 #endif
1960
1961     JMPENV_PUSH(ret);
1962     switch (ret) {
1963     case 1:
1964         cxstack_ix = -1;                /* start context stack again */
1965         goto redo_body;
1966     case 0:                             /* normal completion */
1967  redo_body:
1968         run_body(oldscope);
1969         /* FALL THROUGH */
1970     case 2:                             /* my_exit() */
1971         while (PL_scopestack_ix > oldscope)
1972             LEAVE;
1973         FREETMPS;
1974         PL_curstash = PL_defstash;
1975         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1976             PL_endav && !PL_minus_c)
1977             call_list(oldscope, PL_endav);
1978 #ifdef MYMALLOC
1979         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1980             dump_mstats("after execution:  ");
1981 #endif
1982         ret = STATUS_NATIVE_EXPORT;
1983         break;
1984     case 3:
1985         if (PL_restartop) {
1986             POPSTACK_TO(PL_mainstack);
1987             goto redo_body;
1988         }
1989         PerlIO_printf(Perl_error_log, "panic: restartop\n");
1990         FREETMPS;
1991         ret = 1;
1992         break;
1993     }
1994
1995     JMPENV_POP;
1996     return ret;
1997 }
1998
1999
2000 STATIC void
2001 S_run_body(pTHX_ I32 oldscope)
2002 {
2003     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2004                     PL_sawampersand ? "Enabling" : "Omitting"));
2005
2006     if (!PL_restartop) {
2007         DEBUG_x(dump_all());
2008         if (!DEBUG_q_TEST)
2009           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2010         DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
2011                               PTR2UV(thr)));
2012
2013         if (PL_minus_c) {
2014 #ifdef MACOS_TRADITIONAL
2015             PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2016                 (gMacPerl_ErrorFormat ? "# " : ""),
2017                 MacPerl_MPWFileName(PL_origfilename));
2018 #else
2019             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2020 #endif
2021             my_exit(0);
2022         }
2023         if (PERLDB_SINGLE && PL_DBsingle)
2024             sv_setiv(PL_DBsingle, 1);
2025         if (PL_initav)
2026             call_list(oldscope, PL_initav);
2027     }
2028
2029     /* do it */
2030
2031     if (PL_restartop) {
2032         PL_op = PL_restartop;
2033         PL_restartop = 0;
2034         CALLRUNOPS(aTHX);
2035     }
2036     else if (PL_main_start) {
2037         CvDEPTH(PL_main_cv) = 1;
2038         PL_op = PL_main_start;
2039         CALLRUNOPS(aTHX);
2040     }
2041     my_exit(0);
2042     /* NOTREACHED */
2043 }
2044
2045 /*
2046 =head1 SV Manipulation Functions
2047
2048 =for apidoc p||get_sv
2049
2050 Returns the SV of the specified Perl scalar.  If C<create> is set and the
2051 Perl variable does not exist then it will be created.  If C<create> is not
2052 set and the variable does not exist then NULL is returned.
2053
2054 =cut
2055 */
2056
2057 SV*
2058 Perl_get_sv(pTHX_ const char *name, I32 create)
2059 {
2060     GV *gv;
2061 #ifdef USE_5005THREADS
2062     if (name[1] == '\0' && !isALPHA(name[0])) {
2063         PADOFFSET tmp = find_threadsv(name);
2064         if (tmp != NOT_IN_PAD)
2065             return THREADSV(tmp);
2066     }
2067 #endif /* USE_5005THREADS */
2068     gv = gv_fetchpv(name, create, SVt_PV);
2069     if (gv)
2070         return GvSV(gv);
2071     return Nullsv;
2072 }
2073
2074 /*
2075 =head1 Array Manipulation Functions
2076
2077 =for apidoc p||get_av
2078
2079 Returns the AV of the specified Perl array.  If C<create> is set and the
2080 Perl variable does not exist then it will be created.  If C<create> is not
2081 set and the variable does not exist then NULL is returned.
2082
2083 =cut
2084 */
2085
2086 AV*
2087 Perl_get_av(pTHX_ const char *name, I32 create)
2088 {
2089     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
2090     if (create)
2091         return GvAVn(gv);
2092     if (gv)
2093         return GvAV(gv);
2094     return Nullav;
2095 }
2096
2097 /*
2098 =head1 Hash Manipulation Functions
2099
2100 =for apidoc p||get_hv
2101
2102 Returns the HV of the specified Perl hash.  If C<create> is set and the
2103 Perl variable does not exist then it will be created.  If C<create> is not
2104 set and the variable does not exist then NULL is returned.
2105
2106 =cut
2107 */
2108
2109 HV*
2110 Perl_get_hv(pTHX_ const char *name, I32 create)
2111 {
2112     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
2113     if (create)
2114         return GvHVn(gv);
2115     if (gv)
2116         return GvHV(gv);
2117     return Nullhv;
2118 }
2119
2120 /*
2121 =head1 CV Manipulation Functions
2122
2123 =for apidoc p||get_cv
2124
2125 Returns the CV of the specified Perl subroutine.  If C<create> is set and
2126 the Perl subroutine does not exist then it will be declared (which has the
2127 same effect as saying C<sub name;>).  If C<create> is not set and the
2128 subroutine does not exist then NULL is returned.
2129
2130 =cut
2131 */
2132
2133 CV*
2134 Perl_get_cv(pTHX_ const char *name, I32 create)
2135 {
2136     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
2137     /* XXX unsafe for threads if eval_owner isn't held */
2138     /* XXX this is probably not what they think they're getting.
2139      * It has the same effect as "sub name;", i.e. just a forward
2140      * declaration! */
2141     if (create && !GvCVu(gv))
2142         return newSUB(start_subparse(FALSE, 0),
2143                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
2144                       Nullop,
2145                       Nullop);
2146     if (gv)
2147         return GvCVu(gv);
2148     return Nullcv;
2149 }
2150
2151 /* Be sure to refetch the stack pointer after calling these routines. */
2152
2153 /*
2154
2155 =head1 Callback Functions
2156
2157 =for apidoc p||call_argv
2158
2159 Performs a callback to the specified Perl sub.  See L<perlcall>.
2160
2161 =cut
2162 */
2163
2164 I32
2165 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2166
2167                         /* See G_* flags in cop.h */
2168                         /* null terminated arg list */
2169 {
2170     dSP;
2171
2172     PUSHMARK(SP);
2173     if (argv) {
2174         while (*argv) {
2175             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
2176             argv++;
2177         }
2178         PUTBACK;
2179     }
2180     return call_pv(sub_name, flags);
2181 }
2182
2183 /*
2184 =for apidoc p||call_pv
2185
2186 Performs a callback to the specified Perl sub.  See L<perlcall>.
2187
2188 =cut
2189 */
2190
2191 I32
2192 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2193                         /* name of the subroutine */
2194                         /* See G_* flags in cop.h */
2195 {
2196     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
2197 }
2198
2199 /*
2200 =for apidoc p||call_method
2201
2202 Performs a callback to the specified Perl method.  The blessed object must
2203 be on the stack.  See L<perlcall>.
2204
2205 =cut
2206 */
2207
2208 I32
2209 Perl_call_method(pTHX_ const char *methname, I32 flags)
2210                         /* name of the subroutine */
2211                         /* See G_* flags in cop.h */
2212 {
2213     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2214 }
2215
2216 /* May be called with any of a CV, a GV, or an SV containing the name. */
2217 /*
2218 =for apidoc p||call_sv
2219
2220 Performs a callback to the Perl sub whose name is in the SV.  See
2221 L<perlcall>.
2222
2223 =cut
2224 */
2225
2226 I32
2227 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2228                         /* See G_* flags in cop.h */
2229 {
2230     dVAR; dSP;
2231     LOGOP myop;         /* fake syntax tree node */
2232     UNOP method_op;
2233     I32 oldmark;
2234     volatile I32 retval = 0;
2235     I32 oldscope;
2236     bool oldcatch = CATCH_GET;
2237     int ret;
2238     OP* oldop = PL_op;
2239     dJMPENV;
2240
2241     if (flags & G_DISCARD) {
2242         ENTER;
2243         SAVETMPS;
2244     }
2245
2246     Zero(&myop, 1, LOGOP);
2247     myop.op_next = Nullop;
2248     if (!(flags & G_NOARGS))
2249         myop.op_flags |= OPf_STACKED;
2250     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2251                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2252                       OPf_WANT_SCALAR);
2253     SAVEOP();
2254     PL_op = (OP*)&myop;
2255
2256     EXTEND(PL_stack_sp, 1);
2257     *++PL_stack_sp = sv;
2258     oldmark = TOPMARK;
2259     oldscope = PL_scopestack_ix;
2260
2261     if (PERLDB_SUB && PL_curstash != PL_debstash
2262            /* Handle first BEGIN of -d. */
2263           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2264            /* Try harder, since this may have been a sighandler, thus
2265             * curstash may be meaningless. */
2266           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2267           && !(flags & G_NODEBUG))
2268         PL_op->op_private |= OPpENTERSUB_DB;
2269
2270     if (flags & G_METHOD) {
2271         Zero(&method_op, 1, UNOP);
2272         method_op.op_next = PL_op;
2273         method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2274         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2275         PL_op = (OP*)&method_op;
2276     }
2277
2278     if (!(flags & G_EVAL)) {
2279         CATCH_SET(TRUE);
2280         call_body((OP*)&myop, FALSE);
2281         retval = PL_stack_sp - (PL_stack_base + oldmark);
2282         CATCH_SET(oldcatch);
2283     }
2284     else {
2285         myop.op_other = (OP*)&myop;
2286         PL_markstack_ptr--;
2287         /* we're trying to emulate pp_entertry() here */
2288         {
2289             register PERL_CONTEXT *cx;
2290             const I32 gimme = GIMME_V;
2291
2292             ENTER;
2293             SAVETMPS;
2294
2295             PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2296             PUSHEVAL(cx, 0, 0);
2297             PL_eval_root = PL_op;             /* Only needed so that goto works right. */
2298
2299             PL_in_eval = EVAL_INEVAL;
2300             if (flags & G_KEEPERR)
2301                 PL_in_eval |= EVAL_KEEPERR;
2302             else
2303                 sv_setpvn(ERRSV,"",0);
2304         }
2305         PL_markstack_ptr++;
2306
2307         JMPENV_PUSH(ret);
2308         switch (ret) {
2309         case 0:
2310  redo_body:
2311             call_body((OP*)&myop, FALSE);
2312             retval = PL_stack_sp - (PL_stack_base + oldmark);
2313             if (!(flags & G_KEEPERR))
2314                 sv_setpvn(ERRSV,"",0);
2315             break;
2316         case 1:
2317             STATUS_ALL_FAILURE;
2318             /* FALL THROUGH */
2319         case 2:
2320             /* my_exit() was called */
2321             PL_curstash = PL_defstash;
2322             FREETMPS;
2323             JMPENV_POP;
2324             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2325                 Perl_croak(aTHX_ "Callback called exit");
2326             my_exit_jump();
2327             /* NOTREACHED */
2328         case 3:
2329             if (PL_restartop) {
2330                 PL_op = PL_restartop;
2331                 PL_restartop = 0;
2332                 goto redo_body;
2333             }
2334             PL_stack_sp = PL_stack_base + oldmark;
2335             if (flags & G_ARRAY)
2336                 retval = 0;
2337             else {
2338                 retval = 1;
2339                 *++PL_stack_sp = &PL_sv_undef;
2340             }
2341             break;
2342         }
2343
2344         if (PL_scopestack_ix > oldscope) {
2345             SV **newsp;
2346             PMOP *newpm;
2347             I32 gimme;
2348             register PERL_CONTEXT *cx;
2349             I32 optype;
2350
2351             POPBLOCK(cx,newpm);
2352             POPEVAL(cx);
2353             PL_curpm = newpm;
2354             LEAVE;
2355         }
2356         JMPENV_POP;
2357     }
2358
2359     if (flags & G_DISCARD) {
2360         PL_stack_sp = PL_stack_base + oldmark;
2361         retval = 0;
2362         FREETMPS;
2363         LEAVE;
2364     }
2365     PL_op = oldop;
2366     return retval;
2367 }
2368
2369 STATIC void
2370 S_call_body(pTHX_ const OP *myop, bool is_eval)
2371 {
2372     if (PL_op == myop) {
2373         if (is_eval)
2374             PL_op = Perl_pp_entereval(aTHX);    /* this doesn't do a POPMARK */
2375         else
2376             PL_op = Perl_pp_entersub(aTHX);     /* this does */
2377     }
2378     if (PL_op)
2379         CALLRUNOPS(aTHX);
2380 }
2381
2382 /* Eval a string. The G_EVAL flag is always assumed. */
2383
2384 /*
2385 =for apidoc p||eval_sv
2386
2387 Tells Perl to C<eval> the string in the SV.
2388
2389 =cut
2390 */
2391
2392 I32
2393 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2394
2395                         /* See G_* flags in cop.h */
2396 {
2397     dSP;
2398     UNOP myop;          /* fake syntax tree node */
2399     volatile I32 oldmark = SP - PL_stack_base;
2400     volatile I32 retval = 0;
2401     int ret;
2402     OP* oldop = PL_op;
2403     dJMPENV;
2404
2405     if (flags & G_DISCARD) {
2406         ENTER;
2407         SAVETMPS;
2408     }
2409
2410     SAVEOP();
2411     PL_op = (OP*)&myop;
2412     Zero(PL_op, 1, UNOP);
2413     EXTEND(PL_stack_sp, 1);
2414     *++PL_stack_sp = sv;
2415
2416     if (!(flags & G_NOARGS))
2417         myop.op_flags = OPf_STACKED;
2418     myop.op_next = Nullop;
2419     myop.op_type = OP_ENTEREVAL;
2420     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2421                       (flags & G_ARRAY) ? OPf_WANT_LIST :
2422                       OPf_WANT_SCALAR);
2423     if (flags & G_KEEPERR)
2424         myop.op_flags |= OPf_SPECIAL;
2425
2426     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2427      * before a PUSHEVAL, which corrupts the stack after a croak */
2428     TAINT_PROPER("eval_sv()");
2429
2430     JMPENV_PUSH(ret);
2431     switch (ret) {
2432     case 0:
2433  redo_body:
2434         call_body((OP*)&myop,TRUE);
2435         retval = PL_stack_sp - (PL_stack_base + oldmark);
2436         if (!(flags & G_KEEPERR))
2437             sv_setpvn(ERRSV,"",0);
2438         break;
2439     case 1:
2440         STATUS_ALL_FAILURE;
2441         /* FALL THROUGH */
2442     case 2:
2443         /* my_exit() was called */
2444         PL_curstash = PL_defstash;
2445         FREETMPS;
2446         JMPENV_POP;
2447         if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2448             Perl_croak(aTHX_ "Callback called exit");
2449         my_exit_jump();
2450         /* NOTREACHED */
2451     case 3:
2452         if (PL_restartop) {
2453             PL_op = PL_restartop;
2454             PL_restartop = 0;
2455             goto redo_body;
2456         }
2457         PL_stack_sp = PL_stack_base + oldmark;
2458         if (flags & G_ARRAY)
2459             retval = 0;
2460         else {
2461             retval = 1;
2462             *++PL_stack_sp = &PL_sv_undef;
2463         }
2464         break;
2465     }
2466
2467     JMPENV_POP;
2468     if (flags & G_DISCARD) {
2469         PL_stack_sp = PL_stack_base + oldmark;
2470         retval = 0;
2471         FREETMPS;
2472         LEAVE;
2473     }
2474     PL_op = oldop;
2475     return retval;
2476 }
2477
2478 /*
2479 =for apidoc p||eval_pv
2480
2481 Tells Perl to C<eval> the given string and return an SV* result.
2482
2483 =cut
2484 */
2485
2486 SV*
2487 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2488 {
2489     dSP;
2490     SV* sv = newSVpv(p, 0);
2491
2492     eval_sv(sv, G_SCALAR);
2493     SvREFCNT_dec(sv);
2494
2495     SPAGAIN;
2496     sv = POPs;
2497     PUTBACK;
2498
2499     if (croak_on_error && SvTRUE(ERRSV)) {
2500         Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2501     }
2502
2503     return sv;
2504 }
2505
2506 /* Require a module. */
2507
2508 /*
2509 =head1 Embedding Functions
2510
2511 =for apidoc p||require_pv
2512
2513 Tells Perl to C<require> the file named by the string argument.  It is
2514 analogous to the Perl code C<eval "require '$file'">.  It's even
2515 implemented that way; consider using load_module instead.
2516
2517 =cut */
2518
2519 void
2520 Perl_require_pv(pTHX_ const char *pv)
2521 {
2522     SV* sv;
2523     dSP;
2524     PUSHSTACKi(PERLSI_REQUIRE);
2525     PUTBACK;
2526     sv = sv_newmortal();
2527     sv_setpv(sv, "require '");
2528     sv_catpv(sv, pv);
2529     sv_catpv(sv, "'");
2530     eval_sv(sv, G_DISCARD);
2531     SPAGAIN;
2532     POPSTACK;
2533 }
2534
2535 void
2536 Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
2537 {
2538     register GV *gv;
2539
2540     if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2541         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2542 }
2543
2544 STATIC void
2545 S_usage(pTHX_ const char *name)         /* XXX move this out into a module ? */
2546 {
2547     /* This message really ought to be max 23 lines.
2548      * Removed -h because the user already knows that option. Others? */
2549
2550     static const char * const usage_msg[] = {
2551 "-0[octal]         specify record separator (\\0, if no argument)",
2552 "-A[mod][=pattern] activate all/given assertions",
2553 "-a                autosplit mode with -n or -p (splits $_ into @F)",
2554 "-C[number/list]   enables the listed Unicode features",
2555 "-c                check syntax only (runs BEGIN and CHECK blocks)",
2556 "-d[:debugger]     run program under debugger",
2557 "-D[number/list]   set debugging flags (argument is a bit mask or alphabets)",
2558 "-e program        one line of program (several -e's allowed, omit programfile)",
2559 "-f                don't do $sitelib/sitecustomize.pl at startup",
2560 "-F/pattern/       split() pattern for -a switch (//'s are optional)",
2561 "-i[extension]     edit <> files in place (makes backup if extension supplied)",
2562 "-Idirectory       specify @INC/#include directory (several -I's allowed)",
2563 "-l[octal]         enable line ending processing, specifies line terminator",
2564 "-[mM][-]module    execute \"use/no module...\" before executing program",
2565 "-n                assume \"while (<>) { ... }\" loop around program",
2566 "-p                assume loop like -n but print line also, like sed",
2567 "-P                run program through C preprocessor before compilation",
2568 "-s                enable rudimentary parsing for switches after programfile",
2569 "-S                look for programfile using PATH environment variable",
2570 "-t                enable tainting warnings",
2571 "-T                enable tainting checks",
2572 "-u                dump core after parsing program",
2573 "-U                allow unsafe operations",
2574 "-v                print version, subversion (includes VERY IMPORTANT perl info)",
2575 "-V[:variable]     print configuration summary (or a single Config.pm variable)",
2576 "-w                enable many useful warnings (RECOMMENDED)",
2577 "-W                enable all warnings",
2578 "-x[directory]     strip off text before #!perl line and perhaps cd to directory",
2579 "-X                disable all warnings",
2580 "\n",
2581 NULL
2582 };
2583     const char * const *p = usage_msg;
2584
2585     PerlIO_printf(PerlIO_stdout(),
2586                   "\nUsage: %s [switches] [--] [programfile] [arguments]",
2587                   name);
2588     while (*p)
2589         PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
2590 }
2591
2592 /* convert a string of -D options (or digits) into an int.
2593  * sets *s to point to the char after the options */
2594
2595 #ifdef DEBUGGING
2596 int
2597 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2598 {
2599     static const char * const usage_msgd[] = {
2600       " Debugging flag values: (see also -d)",
2601       "  p  Tokenizing and parsing (with v, displays parse stack)",
2602       "  s  Stack snapshots (with v, displays all stacks)",
2603       "  l  Context (loop) stack processing",
2604       "  t  Trace execution",
2605       "  o  Method and overloading resolution",
2606       "  c  String/numeric conversions",
2607       "  P  Print profiling info, preprocessor command for -P, source file input state",
2608       "  m  Memory allocation",
2609       "  f  Format processing",
2610       "  r  Regular expression parsing and execution",
2611       "  x  Syntax tree dump",
2612       "  u  Tainting checks",
2613       "  H  Hash dump -- usurps values()",
2614       "  X  Scratchpad allocation",
2615       "  D  Cleaning up",
2616       "  S  Thread synchronization",
2617       "  T  Tokenising",
2618       "  R  Include reference counts of dumped variables (eg when using -Ds)",
2619       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
2620       "  v  Verbose: use in conjunction with other flags",
2621       "  C  Copy On Write",
2622       "  A  Consistency checks on internal structures",
2623       "  q  quiet - currently only suppresses the 'EXECUTING' message",
2624       NULL
2625     };
2626     int i = 0;
2627     if (isALPHA(**s)) {
2628         /* if adding extra options, remember to update DEBUG_MASK */
2629         static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
2630
2631         for (; isALNUM(**s); (*s)++) {
2632             const char *d = strchr(debopts,**s);
2633             if (d)
2634                 i |= 1 << (d - debopts);
2635             else if (ckWARN_d(WARN_DEBUGGING))
2636                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2637                     "invalid option -D%c, use -D'' to see choices\n", **s);
2638         }
2639     }
2640     else if (isDIGIT(**s)) {
2641         i = atoi(*s);
2642         for (; isALNUM(**s); (*s)++) ;
2643     }
2644     else if (givehelp) {
2645       char **p = (char **)usage_msgd;
2646       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2647     }
2648 #  ifdef EBCDIC
2649     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2650         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2651                 "-Dp not implemented on this platform\n");
2652 #  endif
2653     return i;
2654 }
2655 #endif
2656
2657 /* This routine handles any switches that can be given during run */
2658
2659 char *
2660 Perl_moreswitches(pTHX_ char *s)
2661 {
2662     dVAR;
2663     UV rschar;
2664
2665     switch (*s) {
2666     case '0':
2667     {
2668          I32 flags = 0;
2669          STRLEN numlen;
2670
2671          SvREFCNT_dec(PL_rs);
2672          if (s[1] == 'x' && s[2]) {
2673               const char *e = s+=2;
2674               U8 *tmps;
2675
2676               while (*e)
2677                 e++;
2678               numlen = e - s;
2679               flags = PERL_SCAN_SILENT_ILLDIGIT;
2680               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2681               if (s + numlen < e) {
2682                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2683                    numlen = 0;
2684                    s--;
2685               }
2686               PL_rs = newSVpvn("", 0);
2687               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2688               tmps = (U8*)SvPVX(PL_rs);
2689               uvchr_to_utf8(tmps, rschar);
2690               SvCUR_set(PL_rs, UNISKIP(rschar));
2691               SvUTF8_on(PL_rs);
2692          }
2693          else {
2694               numlen = 4;
2695               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2696               if (rschar & ~((U8)~0))
2697                    PL_rs = &PL_sv_undef;
2698               else if (!rschar && numlen >= 2)
2699                    PL_rs = newSVpvn("", 0);
2700               else {
2701                    char ch = (char)rschar;
2702                    PL_rs = newSVpvn(&ch, 1);
2703               }
2704          }
2705          sv_setsv(get_sv("/", TRUE), PL_rs);
2706          return s + numlen;
2707     }
2708     case 'C':
2709         s++;
2710         PL_unicode = parse_unicode_opts( (const char **)&s );
2711         return s;
2712     case 'F':
2713         PL_minus_F = TRUE;
2714         PL_splitstr = ++s;
2715         while (*s && !isSPACE(*s)) ++s;
2716         *s = '\0';
2717         PL_splitstr = savepv(PL_splitstr);
2718         return s;
2719     case 'a':
2720         PL_minus_a = TRUE;
2721         s++;
2722         return s;
2723     case 'c':
2724         PL_minus_c = TRUE;
2725         s++;
2726         return s;
2727     case 'd':
2728         forbid_setid("-d");
2729         s++;
2730
2731         /* -dt indicates to the debugger that threads will be used */
2732         if (*s == 't' && !isALNUM(s[1])) {
2733             ++s;
2734             my_setenv("PERL5DB_THREADED", "1");
2735         }
2736
2737         /* The following permits -d:Mod to accepts arguments following an =
2738            in the fashion that -MSome::Mod does. */
2739         if (*s == ':' || *s == '=') {
2740             const char *start;
2741             SV *sv;
2742             sv = newSVpv("use Devel::", 0);
2743             start = ++s;
2744             /* We now allow -d:Module=Foo,Bar */
2745             while(isALNUM(*s) || *s==':') ++s;
2746             if (*s != '=')
2747                 sv_catpv(sv, start);
2748             else {
2749                 sv_catpvn(sv, start, s-start);
2750                 sv_catpv(sv, " split(/,/,q{");
2751                 sv_catpv(sv, ++s);
2752                 sv_catpv(sv, "})");
2753             }
2754             s += strlen(s);
2755             my_setenv("PERL5DB", SvPV(sv, PL_na));
2756         }
2757         if (!PL_perldb) {
2758             PL_perldb = PERLDB_ALL;
2759             init_debugger();
2760         }
2761         return s;
2762     case 'D':
2763     {
2764 #ifdef DEBUGGING
2765         forbid_setid("-D");
2766         s++;
2767         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
2768 #else /* !DEBUGGING */
2769         if (ckWARN_d(WARN_DEBUGGING))
2770             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2771                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
2772         for (s++; isALNUM(*s); s++) ;
2773 #endif
2774         return s;
2775     }
2776     case 'h':
2777         usage(PL_origargv[0]);
2778         my_exit(0);
2779     case 'i':
2780         if (PL_inplace)
2781             Safefree(PL_inplace);
2782 #if defined(__CYGWIN__) /* do backup extension automagically */
2783         if (*(s+1) == '\0') {
2784         PL_inplace = savepv(".bak");
2785         return s+1;
2786         }
2787 #endif /* __CYGWIN__ */
2788         PL_inplace = savepv(s+1);
2789         for (s = PL_inplace; *s && !isSPACE(*s); s++)
2790             ;
2791         if (*s) {
2792             *s++ = '\0';
2793             if (*s == '-')      /* Additional switches on #! line. */
2794                 s++;
2795         }
2796         return s;
2797     case 'I':   /* -I handled both here and in parse_body() */
2798         forbid_setid("-I");
2799         ++s;
2800         while (*s && isSPACE(*s))
2801             ++s;
2802         if (*s) {
2803             char *e, *p;
2804             p = s;
2805             /* ignore trailing spaces (possibly followed by other switches) */
2806             do {
2807                 for (e = p; *e && !isSPACE(*e); e++) ;
2808                 p = e;
2809                 while (isSPACE(*p))
2810                     p++;
2811             } while (*p && *p != '-');
2812             e = savepvn(s, e-s);
2813             incpush(e, TRUE, TRUE, FALSE, FALSE);
2814             Safefree(e);
2815             s = p;
2816             if (*s == '-')
2817                 s++;
2818         }
2819         else
2820             Perl_croak(aTHX_ "No directory specified for -I");
2821         return s;
2822     case 'l':
2823         PL_minus_l = TRUE;
2824         s++;
2825         if (PL_ors_sv) {
2826             SvREFCNT_dec(PL_ors_sv);
2827             PL_ors_sv = Nullsv;
2828         }
2829         if (isDIGIT(*s)) {
2830             I32 flags = 0;
2831             STRLEN numlen;
2832             PL_ors_sv = newSVpvn("\n",1);
2833             numlen = 3 + (*s == '0');
2834             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2835             s += numlen;
2836         }
2837         else {
2838             if (RsPARA(PL_rs)) {
2839                 PL_ors_sv = newSVpvn("\n\n",2);
2840             }
2841             else {
2842                 PL_ors_sv = newSVsv(PL_rs);
2843             }
2844         }
2845         return s;
2846     case 'A':
2847         forbid_setid("-A");
2848         if (!PL_preambleav)
2849             PL_preambleav = newAV();
2850         s++;
2851         {
2852             char *start = s;
2853             SV *sv = newSVpv("use assertions::activate", 24);
2854             while(isALNUM(*s) || *s == ':') ++s;
2855             if (s != start) {
2856                 sv_catpvn(sv, "::", 2);
2857                 sv_catpvn(sv, start, s-start);
2858             }
2859             if (*s == '=') {
2860                 sv_catpvn(sv, " split(/,/,q\0", 13);
2861                 sv_catpv(sv, s+1);
2862                 sv_catpvn(sv, "\0)", 2);
2863                 s+=strlen(s);
2864             }
2865             else if (*s != '\0') {
2866                 Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
2867             }
2868             av_push(PL_preambleav, sv);
2869             return s;
2870         }
2871     case 'M':
2872         forbid_setid("-M");     /* XXX ? */
2873         /* FALL THROUGH */
2874     case 'm':
2875         forbid_setid("-m");     /* XXX ? */
2876         if (*++s) {
2877             char *start;
2878             SV *sv;
2879             const char *use = "use ";
2880             /* -M-foo == 'no foo'       */
2881             if (*s == '-') { use = "no "; ++s; }
2882             sv = newSVpv(use,0);
2883             start = s;
2884             /* We allow -M'Module qw(Foo Bar)'  */
2885             while(isALNUM(*s) || *s==':') ++s;
2886             if (*s != '=') {
2887                 sv_catpv(sv, start);
2888                 if (*(start-1) == 'm') {
2889                     if (*s != '\0')
2890                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2891                     sv_catpv( sv, " ()");
2892                 }
2893             } else {
2894                 if (s == start)
2895                     Perl_croak(aTHX_ "Module name required with -%c option",
2896                                s[-1]);
2897                 sv_catpvn(sv, start, s-start);
2898                 sv_catpv(sv, " split(/,/,q");
2899                 sv_catpvn(sv, "\0)", 1);        /* Use NUL as q//-delimiter. */
2900                 sv_catpv(sv, ++s);
2901                 sv_catpvn(sv,  "\0)", 2);
2902             }
2903             s += strlen(s);
2904             if (!PL_preambleav)
2905                 PL_preambleav = newAV();
2906             av_push(PL_preambleav, sv);
2907         }
2908         else
2909             Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
2910         return s;
2911     case 'n':
2912         PL_minus_n = TRUE;
2913         s++;
2914         return s;
2915     case 'p':
2916         PL_minus_p = TRUE;
2917         s++;
2918         return s;
2919     case 's':
2920         forbid_setid("-s");
2921         PL_doswitches = TRUE;
2922         s++;
2923         return s;
2924     case 't':
2925         if (!PL_tainting)
2926             TOO_LATE_FOR('t');
2927         s++;
2928         return s;
2929     case 'T':
2930         if (!PL_tainting)
2931             TOO_LATE_FOR('T');
2932         s++;
2933         return s;
2934     case 'u':
2935 #ifdef MACOS_TRADITIONAL
2936         Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2937 #endif
2938         PL_do_undump = TRUE;
2939         s++;
2940         return s;
2941     case 'U':
2942         PL_unsafe = TRUE;
2943         s++;
2944         return s;
2945     case 'v':
2946         if (!sv_derived_from(PL_patchlevel, "version"))
2947                 (void *)upg_version(PL_patchlevel);
2948 #if !defined(DGUX)
2949         PerlIO_printf(PerlIO_stdout(),
2950                 Perl_form(aTHX_ "\nThis is perl, %"SVf" built for %s",
2951                     vstringify(PL_patchlevel),
2952                     ARCHNAME));
2953 #else /* DGUX */
2954 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2955         PerlIO_printf(PerlIO_stdout(),
2956                 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
2957                     vstringify(PL_patchlevel)));
2958         PerlIO_printf(PerlIO_stdout(),
2959                         Perl_form(aTHX_ "        built under %s at %s %s\n",
2960                                         OSNAME, __DATE__, __TIME__));
2961         PerlIO_printf(PerlIO_stdout(),
2962                         Perl_form(aTHX_ "        OS Specific Release: %s\n",
2963                                         OSVERS));
2964 #endif /* !DGUX */
2965
2966 #if defined(LOCAL_PATCH_COUNT)
2967         if (LOCAL_PATCH_COUNT > 0)
2968             PerlIO_printf(PerlIO_stdout(),
2969                           "\n(with %d registered patch%s, "
2970                           "see perl -V for more detail)",
2971                           (int)LOCAL_PATCH_COUNT,
2972                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2973 #endif
2974
2975         PerlIO_printf(PerlIO_stdout(),
2976                       "\n\nCopyright 1987-2005, Larry Wall\n");
2977 #ifdef MACOS_TRADITIONAL
2978         PerlIO_printf(PerlIO_stdout(),
2979                       "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2980                       "maintained by Chris Nandor\n");
2981 #endif
2982 #ifdef MSDOS
2983         PerlIO_printf(PerlIO_stdout(),
2984                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2985 #endif
2986 #ifdef DJGPP
2987         PerlIO_printf(PerlIO_stdout(),
2988                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2989                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2990 #endif
2991 #ifdef OS2
2992         PerlIO_printf(PerlIO_stdout(),
2993                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2994                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2995 #endif
2996 #ifdef atarist
2997         PerlIO_printf(PerlIO_stdout(),
2998                       "atariST series port, ++jrb  bammi@cadence.com\n");
2999 #endif
3000 #ifdef __BEOS__
3001         PerlIO_printf(PerlIO_stdout(),
3002                       "BeOS port Copyright Tom Spindler, 1997-1999\n");
3003 #endif
3004 #ifdef MPE
3005         PerlIO_printf(PerlIO_stdout(),
3006                       "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3007 #endif
3008 #ifdef OEMVS
3009         PerlIO_printf(PerlIO_stdout(),
3010                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3011 #endif
3012 #ifdef __VOS__
3013         PerlIO_printf(PerlIO_stdout(),
3014                       "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3015 #endif
3016 #ifdef __OPEN_VM
3017         PerlIO_printf(PerlIO_stdout(),
3018                       "VM/ESA port by Neale Ferguson, 1998-1999\n");
3019 #endif
3020 #ifdef POSIX_BC
3021         PerlIO_printf(PerlIO_stdout(),
3022                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3023 #endif
3024 #ifdef __MINT__
3025         PerlIO_printf(PerlIO_stdout(),
3026                       "MiNT port by Guido Flohr, 1997-1999\n");
3027 #endif
3028 #ifdef EPOC
3029         PerlIO_printf(PerlIO_stdout(),
3030                       "EPOC port by Olaf Flebbe, 1999-2002\n");
3031 #endif
3032 #ifdef UNDER_CE
3033         PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3034         PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3035         wce_hitreturn();
3036 #endif
3037 #ifdef SYMBIAN
3038         PerlIO_printf(PerlIO_stdout(),
3039                       "Symbian port by Nokia, 2004-2005\n");
3040 #endif
3041 #ifdef BINARY_BUILD_NOTICE
3042         BINARY_BUILD_NOTICE;
3043 #endif
3044         PerlIO_printf(PerlIO_stdout(),
3045                       "\n\
3046 Perl may be copied only under the terms of either the Artistic License or the\n\
3047 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3048 Complete documentation for Perl, including FAQ lists, should be found on\n\
3049 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3050 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3051         my_exit(0);
3052     case 'w':
3053         if (! (PL_dowarn & G_WARN_ALL_MASK))
3054             PL_dowarn |= G_WARN_ON;
3055         s++;
3056         return s;
3057     case 'W':
3058         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3059         if (!specialWARN(PL_compiling.cop_warnings))
3060             SvREFCNT_dec(PL_compiling.cop_warnings);
3061         PL_compiling.cop_warnings = pWARN_ALL ;
3062         s++;
3063         return s;
3064     case 'X':
3065         PL_dowarn = G_WARN_ALL_OFF;
3066         if (!specialWARN(PL_compiling.cop_warnings))
3067             SvREFCNT_dec(PL_compiling.cop_warnings);
3068         PL_compiling.cop_warnings = pWARN_NONE ;
3069         s++;
3070         return s;
3071     case '*':
3072     case ' ':
3073         if (s[1] == '-')        /* Additional switches on #! line. */
3074             return s+2;
3075         break;
3076     case '-':
3077     case 0:
3078 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3079     case '\r':
3080 #endif
3081     case '\n':
3082     case '\t':
3083         break;
3084 #ifdef ALTERNATE_SHEBANG
3085     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3086         break;
3087 #endif
3088     case 'P':
3089         if (PL_preprocess)
3090             return s+1;
3091         /* FALL THROUGH */
3092     default:
3093         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3094     }
3095     return Nullch;
3096 }
3097
3098 /* compliments of Tom Christiansen */
3099
3100 /* unexec() can be found in the Gnu emacs distribution */
3101 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3102
3103 void
3104 Perl_my_unexec(pTHX)
3105 {
3106 #ifdef UNEXEC
3107     SV*    prog;
3108     SV*    file;
3109     int    status = 1;
3110     extern int etext;
3111
3112     prog = newSVpv(BIN_EXP, 0);
3113     sv_catpv(prog, "/perl");
3114     file = newSVpv(PL_origfilename, 0);
3115     sv_catpv(file, ".perldump");
3116
3117     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3118     /* unexec prints msg to stderr in case of failure */
3119     PerlProc_exit(status);
3120 #else
3121 #  ifdef VMS
3122 #    include <lib$routines.h>
3123      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3124 #  else
3125     ABORT();            /* for use with undump */
3126 #  endif
3127 #endif
3128 }
3129
3130 /* initialize curinterp */
3131 STATIC void
3132 S_init_interp(pTHX)
3133 {
3134
3135 #ifdef MULTIPLICITY
3136 #  define PERLVAR(var,type)
3137 #  define PERLVARA(var,n,type)
3138 #  if defined(PERL_IMPLICIT_CONTEXT)
3139 #    if defined(USE_5005THREADS)
3140 #      define PERLVARI(var,type,init)           PERL_GET_INTERP->var = init;
3141 #      define PERLVARIC(var,type,init)          PERL_GET_INTERP->var = init;
3142 #    else /* !USE_5005THREADS */
3143 #      define PERLVARI(var,type,init)           aTHX->var = init;
3144 #      define PERLVARIC(var,type,init)  aTHX->var = init;
3145 #    endif /* USE_5005THREADS */
3146 #  else
3147 #    define PERLVARI(var,type,init)     PERL_GET_INTERP->var = init;
3148 #    define PERLVARIC(var,type,init)    PERL_GET_INTERP->var = init;
3149 #  endif
3150 #  include "intrpvar.h"
3151 #  ifndef USE_5005THREADS
3152 #    include "thrdvar.h"
3153 #  endif
3154 #  undef PERLVAR
3155 #  undef PERLVARA
3156 #  undef PERLVARI
3157 #  undef PERLVARIC
3158 #else
3159 #  define PERLVAR(var,type)
3160 #  define PERLVARA(var,n,type)
3161 #  define PERLVARI(var,type,init)       PL_##var = init;
3162 #  define PERLVARIC(var,type,init)      PL_##var = init;
3163 #  include "intrpvar.h"
3164 #  ifndef USE_5005THREADS
3165 #    include "thrdvar.h"
3166 #  endif
3167 #  undef PERLVAR
3168 #  undef PERLVARA
3169 #  undef PERLVARI
3170 #  undef PERLVARIC
3171 #endif
3172
3173 }
3174
3175 STATIC void
3176 S_init_main_stash(pTHX)
3177 {
3178     GV *gv;
3179
3180     PL_curstash = PL_defstash = newHV();
3181     PL_curstname = newSVpvn("main",4);
3182     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3183     SvREFCNT_dec(GvHV(gv));
3184     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
3185     SvREADONLY_on(gv);
3186     Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0);
3187     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3188     GvMULTI_on(PL_incgv);
3189     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3190     GvMULTI_on(PL_hintgv);
3191     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3192     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3193     GvMULTI_on(PL_errgv);
3194     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3195     GvMULTI_on(PL_replgv);
3196     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3197     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3198     sv_setpvn(ERRSV, "", 0);
3199     PL_curstash = PL_defstash;
3200     CopSTASH_set(&PL_compiling, PL_defstash);
3201     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3202     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
3203     /* We must init $/ before switches are processed. */
3204     sv_setpvn(get_sv("/", TRUE), "\n", 1);
3205 }
3206
3207 /* PSz 18 Nov 03  fdscript now global but do not change prototype */
3208 STATIC void
3209 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
3210 {
3211 #ifndef IAMSUID
3212     const char *quote;
3213     const char *code;
3214     const char *cpp_discard_flag;
3215     const char *perl;
3216 #endif
3217     dVAR;
3218
3219     PL_fdscript = -1;
3220     PL_suidscript = -1;
3221
3222     if (PL_e_script) {
3223         PL_origfilename = savepvn("-e", 2);
3224     }
3225     else {
3226         /* if find_script() returns, it returns a malloc()-ed value */
3227         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3228
3229         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3230             const char *s = scriptname + 8;
3231             PL_fdscript = atoi(s);
3232             while (isDIGIT(*s))
3233                 s++;
3234             if (*s) {
3235                 /* PSz 18 Feb 04
3236                  * Tell apart "normal" usage of fdscript, e.g.
3237                  * with bash on FreeBSD:
3238                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3239                  * from usage in suidperl.
3240                  * Does any "normal" usage leave garbage after the number???
3241                  * Is it a mistake to use a similar /dev/fd/ construct for
3242                  * suidperl?
3243                  */
3244                 PL_suidscript = 1;
3245                 /* PSz 20 Feb 04
3246                  * Be supersafe and do some sanity-checks.
3247                  * Still, can we be sure we got the right thing?
3248                  */
3249                 if (*s != '/') {
3250                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3251                 }
3252                 if (! *(s+1)) {
3253                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3254                 }
3255                 scriptname = savepv(s + 1);
3256                 Safefree(PL_origfilename);
3257                 PL_origfilename = (char *)scriptname;
3258             }
3259         }
3260     }
3261
3262     CopFILE_free(PL_curcop);
3263     CopFILE_set(PL_curcop, PL_origfilename);
3264     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3265         scriptname = (char *)"";
3266     if (PL_fdscript >= 0) {
3267         PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
3268 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3269             if (PL_rsfp)
3270                 /* ensure close-on-exec */
3271                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3272 #       endif
3273     }
3274 #ifdef IAMSUID
3275     else {
3276         Perl_croak(aTHX_ "sperl needs fd script\n"
3277                    "You should not call sperl directly; do you need to "
3278                    "change a #! line\nfrom sperl to perl?\n");
3279
3280 /* PSz 11 Nov 03
3281  * Do not open (or do other fancy stuff) while setuid.
3282  * Perl does the open, and hands script to suidperl on a fd;
3283  * suidperl only does some checks, sets up UIDs and re-execs
3284  * perl with that fd as it has always done.
3285  */
3286     }
3287     if (PL_suidscript != 1) {
3288         Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3289     }
3290 #else /* IAMSUID */
3291     else if (PL_preprocess) {
3292         const char *cpp_cfg = CPPSTDIN;
3293         SV *cpp = newSVpvn("",0);
3294         SV *cmd = NEWSV(0,0);
3295
3296         if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3297              Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3298         if (strEQ(cpp_cfg, "cppstdin"))
3299             Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3300         sv_catpv(cpp, cpp_cfg);
3301
3302 #       ifndef VMS
3303             sv_catpvn(sv, "-I", 2);
3304             sv_catpv(sv,PRIVLIB_EXP);
3305 #       endif
3306
3307         DEBUG_P(PerlIO_printf(Perl_debug_log,
3308                               "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3309                               scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3310                               CPPMINUS));
3311
3312 #       if defined(MSDOS) || defined(WIN32) || defined(VMS)
3313             quote = "\"";
3314 #       else
3315             quote = "'";
3316 #       endif
3317
3318 #       ifdef VMS
3319             cpp_discard_flag = "";
3320 #       else
3321             cpp_discard_flag = "-C";
3322 #       endif
3323
3324 #       ifdef OS2
3325             perl = os2_execname(aTHX);
3326 #       else
3327             perl = PL_origargv[0];
3328 #       endif
3329
3330
3331         /* This strips off Perl comments which might interfere with
3332            the C pre-processor, including #!.  #line directives are
3333            deliberately stripped to avoid confusion with Perl's version
3334            of #line.  FWP played some golf with it so it will fit
3335            into VMS's 255 character buffer.
3336         */
3337         if( PL_doextract )
3338             code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3339         else
3340             code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3341
3342         Perl_sv_setpvf(aTHX_ cmd, "\
3343 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3344                        perl, quote, code, quote, scriptname, cpp,
3345                        cpp_discard_flag, sv, CPPMINUS);
3346
3347         PL_doextract = FALSE;
3348
3349         DEBUG_P(PerlIO_printf(Perl_debug_log,
3350                               "PL_preprocess: cmd=\"%s\"\n",
3351                               SvPVX_const(cmd)));
3352
3353         PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
3354         SvREFCNT_dec(cmd);
3355         SvREFCNT_dec(cpp);
3356     }
3357     else if (!*scriptname) {
3358         forbid_setid("program input from stdin");
3359         PL_rsfp = PerlIO_stdin();
3360     }
3361     else {
3362         PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3363 #       if defined(HAS_FCNTL) && defined(F_SETFD)
3364             if (PL_rsfp)
3365                 /* ensure close-on-exec */
3366                 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3367 #       endif
3368     }
3369 #endif /* IAMSUID */
3370     if (!PL_rsfp) {
3371         /* PSz 16 Sep 03  Keep neat error message */
3372         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3373                 CopFILE(PL_curcop), Strerror(errno));
3374     }
3375 }
3376
3377 /* Mention
3378  * I_SYSSTATVFS HAS_FSTATVFS
3379  * I_SYSMOUNT
3380  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3381  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3382  * here so that metaconfig picks them up. */
3383
3384 #ifdef IAMSUID
3385 STATIC int
3386 S_fd_on_nosuid_fs(pTHX_ int fd)
3387 {
3388 /* PSz 27 Feb 04
3389  * We used to do this as "plain" user (after swapping UIDs with setreuid);
3390  * but is needed also on machines without setreuid.
3391  * Seems safe enough to run as root.
3392  */
3393     int check_okay = 0; /* able to do all the required sys/libcalls */
3394     int on_nosuid  = 0; /* the fd is on a nosuid fs */
3395     /* PSz 12 Nov 03
3396      * Need to check noexec also: nosuid might not be set, the average
3397      * sysadmin would say that nosuid is irrelevant once he sets noexec.
3398      */
3399     int on_noexec  = 0; /* the fd is on a noexec fs */
3400
3401 /*
3402  * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3403  * fstatvfs() is UNIX98.
3404  * fstatfs() is 4.3 BSD.
3405  * ustat()+getmnt() is pre-4.3 BSD.
3406  * getmntent() is O(number-of-mounted-filesystems) and can hang on
3407  * an irrelevant filesystem while trying to reach the right one.
3408  */
3409
3410 #undef FD_ON_NOSUID_CHECK_OKAY  /* found the syscalls to do the check? */
3411
3412 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3413         defined(HAS_FSTATVFS)
3414 #   define FD_ON_NOSUID_CHECK_OKAY
3415     struct statvfs stfs;
3416
3417     check_okay = fstatvfs(fd, &stfs) == 0;
3418     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
3419 #ifdef ST_NOEXEC
3420     /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3421        on platforms where it is present.  */
3422     on_noexec  = check_okay && (stfs.f_flag  & ST_NOEXEC);
3423 #endif
3424 #   endif /* fstatvfs */
3425
3426 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3427         defined(PERL_MOUNT_NOSUID)      && \
3428         defined(PERL_MOUNT_NOEXEC)      && \
3429         defined(HAS_FSTATFS)            && \
3430         defined(HAS_STRUCT_STATFS)      && \
3431         defined(HAS_STRUCT_STATFS_F_FLAGS)
3432 #   define FD_ON_NOSUID_CHECK_OKAY
3433     struct statfs  stfs;
3434
3435     check_okay = fstatfs(fd, &stfs)  == 0;
3436     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3437     on_noexec  = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3438 #   endif /* fstatfs */
3439
3440 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3441         defined(PERL_MOUNT_NOSUID)      && \
3442         defined(PERL_MOUNT_NOEXEC)      && \
3443         defined(HAS_FSTAT)              && \
3444         defined(HAS_USTAT)              && \
3445         defined(HAS_GETMNT)             && \
3446         defined(HAS_STRUCT_FS_DATA)     && \
3447         defined(NOSTAT_ONE)
3448 #   define FD_ON_NOSUID_CHECK_OKAY
3449     Stat_t fdst;
3450
3451     if (fstat(fd, &fdst) == 0) {
3452         struct ustat us;
3453         if (ustat(fdst.st_dev, &us) == 0) {
3454             struct fs_data fsd;
3455             /* NOSTAT_ONE here because we're not examining fields which
3456              * vary between that case and STAT_ONE. */
3457             if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3458                 size_t cmplen = sizeof(us.f_fname);
3459                 if (sizeof(fsd.fd_req.path) < cmplen)
3460                     cmplen = sizeof(fsd.fd_req.path);
3461                 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3462                     fdst.st_dev == fsd.fd_req.dev) {
3463                         check_okay = 1;
3464                         on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3465                         on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3466                     }
3467                 }
3468             }
3469         }
3470     }
3471 #   endif /* fstat+ustat+getmnt */
3472
3473 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3474         defined(HAS_GETMNTENT)          && \
3475         defined(HAS_HASMNTOPT)          && \
3476         defined(MNTOPT_NOSUID)          && \
3477         defined(MNTOPT_NOEXEC)
3478 #   define FD_ON_NOSUID_CHECK_OKAY
3479     FILE                *mtab = fopen("/etc/mtab", "r");
3480     struct mntent       *entry;
3481     Stat_t              stb, fsb;
3482
3483     if (mtab && (fstat(fd, &stb) == 0)) {
3484         while (entry = getmntent(mtab)) {
3485             if (stat(entry->mnt_dir, &fsb) == 0
3486                 && fsb.st_dev == stb.st_dev)
3487             {
3488                 /* found the filesystem */
3489                 check_okay = 1;
3490                 if (hasmntopt(entry, MNTOPT_NOSUID))
3491                     on_nosuid = 1;
3492                 if (hasmntopt(entry, MNTOPT_NOEXEC))
3493                     on_noexec = 1;
3494                 break;
3495             } /* A single fs may well fail its stat(). */
3496         }
3497     }
3498     if (mtab)
3499         fclose(mtab);
3500 #   endif /* getmntent+hasmntopt */
3501
3502     if (!check_okay)
3503         Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3504     if (on_nosuid)
3505         Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3506     if (on_noexec)
3507         Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3508     return ((!check_okay) || on_nosuid || on_noexec);
3509 }
3510 #endif /* IAMSUID */
3511
3512 STATIC void
3513 S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
3514 {
3515     dVAR;
3516 #ifdef IAMSUID
3517     /* int which; */
3518 #endif /* IAMSUID */
3519
3520     /* do we need to emulate setuid on scripts? */
3521
3522     /* This code is for those BSD systems that have setuid #! scripts disabled
3523      * in the kernel because of a security problem.  Merely defining DOSUID
3524      * in perl will not fix that problem, but if you have disabled setuid
3525      * scripts in the kernel, this will attempt to emulate setuid and setgid
3526      * on scripts that have those now-otherwise-useless bits set.  The setuid
3527      * root version must be called suidperl or sperlN.NNN.  If regular perl
3528      * discovers that it has opened a setuid script, it calls suidperl with
3529      * the same argv that it had.  If suidperl finds that the script it has
3530      * just opened is NOT setuid root, it sets the effective uid back to the
3531      * uid.  We don't just make perl setuid root because that loses the
3532      * effective uid we had before invoking perl, if it was different from the
3533      * uid.
3534      * PSz 27 Feb 04
3535      * Description/comments above do not match current workings:
3536      *   suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3537      *   suidperl called with script open and name changed to /dev/fd/N/X;
3538      *   suidperl croaks if script is not setuid;
3539      *   making perl setuid would be a huge security risk (and yes, that
3540      *     would lose any euid we might have had).
3541      *
3542      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3543      * be defined in suidperl only.  suidperl must be setuid root.  The
3544      * Configure script will set this up for you if you want it.
3545      */
3546
3547 #ifdef DOSUID
3548     const char *s, *s2;
3549
3550     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0)  /* normal stat is insecure */
3551         Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3552     if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3553         I32 len;
3554         const char *linestr;
3555
3556 #ifdef IAMSUID
3557         if (PL_fdscript < 0 || PL_suidscript != 1)
3558             Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n");     /* We already checked this */
3559         /* PSz 11 Nov 03
3560          * Since the script is opened by perl, not suidperl, some of these
3561          * checks are superfluous. Leaving them in probably does not lower
3562          * security(?!).
3563          */
3564         /* PSz 27 Feb 04
3565          * Do checks even for systems with no HAS_SETREUID.
3566          * We used to swap, then re-swap UIDs with
3567 #ifdef HAS_SETREUID
3568             if (setreuid(PL_euid,PL_uid) < 0
3569                 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3570                 Perl_croak(aTHX_ "Can't swap uid and euid");
3571 #endif
3572 #ifdef HAS_SETREUID
3573             if (setreuid(PL_uid,PL_euid) < 0
3574                 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3575                 Perl_croak(aTHX_ "Can't reswap uid and euid");
3576 #endif
3577          */
3578
3579         /* On this access check to make sure the directories are readable,
3580          * there is actually a small window that the user could use to make
3581          * filename point to an accessible directory.  So there is a faint
3582          * chance that someone could execute a setuid script down in a
3583          * non-accessible directory.  I don't know what to do about that.
3584          * But I don't think it's too important.  The manual lies when
3585          * it says access() is useful in setuid programs.
3586          *
3587          * So, access() is pretty useless... but not harmful... do anyway.
3588          */
3589         if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3590             Perl_croak(aTHX_ "Can't access() script\n");
3591         }
3592
3593         /* If we can swap euid and uid, then we can determine access rights
3594          * with a simple stat of the file, and then compare device and
3595          * inode to make sure we did stat() on the same file we opened.
3596          * Then we just have to make sure he or she can execute it.
3597          *
3598          * PSz 24 Feb 04
3599          * As the script is opened by perl, not suidperl, we do not need to
3600          * care much about access rights.
3601          *
3602          * The 'script changed' check is needed, or we can get lied to
3603          * about $0 with e.g.
3604          *  suidperl /dev/fd/4//bin/x 4<setuidscript
3605          * Without HAS_SETREUID, is it safe to stat() as root?
3606          *
3607          * Are there any operating systems that pass /dev/fd/xxx for setuid
3608          * scripts, as suggested/described in perlsec(1)? Surely they do not
3609          * pass the script name as we do, so the "script changed" test would
3610          * fail for them... but we never get here with
3611          * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3612          *
3613          * This is one place where we must "lie" about return status: not
3614          * say if the stat() failed. We are doing this as root, and could
3615          * be tricked into reporting existence or not of files that the
3616          * "plain" user cannot even see.
3617          */
3618         {
3619             Stat_t tmpstatbuf;
3620             if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3621                 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3622                 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3623                 Perl_croak(aTHX_ "Setuid script changed\n");
3624             }
3625
3626         }
3627         if (!cando(S_IXUSR,FALSE,&PL_statbuf))          /* can real uid exec? */
3628             Perl_croak(aTHX_ "Real UID cannot exec script\n");
3629
3630         /* PSz 27 Feb 04
3631          * We used to do this check as the "plain" user (after swapping
3632          * UIDs). But the check for nosuid and noexec filesystem is needed,
3633          * and should be done even without HAS_SETREUID. (Maybe those
3634          * operating systems do not have such mount options anyway...)
3635          * Seems safe enough to do as root.
3636          */
3637 #if !defined(NO_NOSUID_CHECK)
3638         if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3639             Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3640         }
3641 #endif
3642 #endif /* IAMSUID */
3643
3644         if (!S_ISREG(PL_statbuf.st_mode)) {
3645             Perl_croak(aTHX_ "Setuid script not plain file\n");
3646         }
3647         if (PL_statbuf.st_mode & S_IWOTH)
3648             Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3649         PL_doswitches = FALSE;          /* -s is insecure in suid */
3650         /* PSz 13 Nov 03  But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3651         CopLINE_inc(PL_curcop);
3652         linestr = SvPV_nolen_const(PL_linestr);
3653         if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3654           strnNE(linestr,"#!",2) )      /* required even on Sys V */
3655             Perl_croak(aTHX_ "No #! line");
3656         linestr+=2;
3657         s = linestr;
3658         /* PSz 27 Feb 04 */
3659         /* Sanity check on line length */
3660         if (strlen(s) < 1 || strlen(s) > 4000)
3661             Perl_croak(aTHX_ "Very long #! line");
3662         /* Allow more than a single space after #! */
3663         while (isSPACE(*s)) s++;
3664         /* Sanity check on buffer end */
3665         while ((*s) && !isSPACE(*s)) s++;
3666         for (s2 = s;  (s2 > linestr &&
3667                        (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3668                         || s2[-1] == '-'));  s2--) ;
3669         /* Sanity check on buffer start */
3670         if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
3671               (s-9 < linestr || strnNE(s-9,"perl",4)) )
3672             Perl_croak(aTHX_ "Not a perl script");
3673         while (*s == ' ' || *s == '\t') s++;
3674         /*
3675          * #! arg must be what we saw above.  They can invoke it by
3676          * mentioning suidperl explicitly, but they may not add any strange
3677          * arguments beyond what #! says if they do invoke suidperl that way.
3678          */
3679         /*
3680          * The way validarg was set up, we rely on the kernel to start
3681          * scripts with argv[1] set to contain all #! line switches (the
3682          * whole line).
3683          */
3684         /*
3685          * Check that we got all the arguments listed in the #! line (not
3686          * just that there are no extraneous arguments). Might not matter
3687          * much, as switches from #! line seem to be acted upon (also), and
3688          * so may be checked and trapped in perl. But, security checks must
3689          * be done in suidperl and not deferred to perl. Note that suidperl
3690          * does not get around to parsing (and checking) the switches on
3691          * the #! line (but execs perl sooner).
3692          * Allow (require) a trailing newline (which may be of two
3693          * characters on some architectures?) (but no other trailing
3694          * whitespace).
3695          */
3696         len = strlen(validarg);
3697         if (strEQ(validarg," PHOOEY ") ||
3698             strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3699             !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
3700             Perl_croak(aTHX_ "Args must match #! line");
3701
3702 #ifndef IAMSUID
3703         if (PL_fdscript < 0 &&
3704             PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3705             PL_euid == PL_statbuf.st_uid)
3706             if (!PL_do_undump)
3707                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3708 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
3709 #endif /* IAMSUID */
3710
3711         if (PL_fdscript < 0 &&
3712             PL_euid) {  /* oops, we're not the setuid root perl */
3713             /* PSz 18 Feb 04
3714              * When root runs a setuid script, we do not go through the same
3715              * steps of execing sperl and then perl with fd scripts, but
3716              * simply set up UIDs within the same perl invocation; so do
3717              * not have the same checks (on options, whatever) that we have
3718              * for plain users. No problem really: would have to be a script
3719              * that does not actually work for plain users; and if root is
3720              * foolish and can be persuaded to run such an unsafe script, he
3721              * might run also non-setuid ones, and deserves what he gets.
3722              *
3723              * Or, we might drop the PL_euid check above (and rely just on
3724              * PL_fdscript to avoid loops), and do the execs
3725              * even for root.
3726              */
3727 #ifndef IAMSUID
3728             int which;
3729             /* PSz 11 Nov 03
3730              * Pass fd script to suidperl.
3731              * Exec suidperl, substituting fd script for scriptname.
3732              * Pass script name as "subdir" of fd, which perl will grok;
3733              * in fact will use that to distinguish this from "normal"
3734              * usage, see comments above.
3735              */
3736             PerlIO_rewind(PL_rsfp);
3737             PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3738             /* PSz 27 Feb 04  Sanity checks on scriptname */
3739             if ((!scriptname) || (!*scriptname) ) {
3740                 Perl_croak(aTHX_ "No setuid script name\n");
3741             }
3742             if (*scriptname == '-') {
3743                 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3744                 /* Or we might confuse it with an option when replacing
3745                  * name in argument list, below (though we do pointer, not
3746                  * string, comparisons).
3747                  */
3748             }
3749             for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3750             if (!PL_origargv[which]) {
3751                 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3752             }
3753             PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3754                                           PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3755 #if defined(HAS_FCNTL) && defined(F_SETFD)
3756             fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3757 #endif
3758             PERL_FPU_PRE_EXEC
3759             PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3760                                      (int)PERL_REVISION, (int)PERL_VERSION,
3761                                      (int)PERL_SUBVERSION), PL_origargv);
3762             PERL_FPU_POST_EXEC
3763 #endif /* IAMSUID */
3764             Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
3765         }
3766
3767         if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3768 /* PSz 26 Feb 04
3769  * This seems back to front: we try HAS_SETEGID first; if not available
3770  * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3771  * in the sense that we only want to set EGID; but are there any machines
3772  * with either of the latter, but not the former? Same with UID, later.
3773  */
3774 #ifdef HAS_SETEGID
3775             (void)setegid(PL_statbuf.st_gid);
3776 #else
3777 #ifdef HAS_SETREGID
3778            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3779 #else
3780 #ifdef HAS_SETRESGID
3781            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3782 #else
3783             PerlProc_setgid(PL_statbuf.st_gid);
3784 #endif
3785 #endif
3786 #endif
3787             if (PerlProc_getegid() != PL_statbuf.st_gid)
3788                 Perl_croak(aTHX_ "Can't do setegid!\n");
3789         }
3790         if (PL_statbuf.st_mode & S_ISUID) {
3791             if (PL_statbuf.st_uid != PL_euid)
3792 #ifdef HAS_SETEUID
3793                 (void)seteuid(PL_statbuf.st_uid);       /* all that for this */
3794 #else
3795 #ifdef HAS_SETREUID
3796                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3797 #else
3798 #ifdef HAS_SETRESUID
3799                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3800 #else
3801                 PerlProc_setuid(PL_statbuf.st_uid);
3802 #endif
3803 #endif
3804 #endif
3805             if (PerlProc_geteuid() != PL_statbuf.st_uid)
3806                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3807         }
3808         else if (PL_uid) {                      /* oops, mustn't run as root */
3809 #ifdef HAS_SETEUID
3810           (void)seteuid((Uid_t)PL_uid);
3811 #else
3812 #ifdef HAS_SETREUID
3813           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3814 #else
3815 #ifdef HAS_SETRESUID
3816           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3817 #else
3818           PerlProc_setuid((Uid_t)PL_uid);
3819 #endif
3820 #endif
3821 #endif
3822             if (PerlProc_geteuid() != PL_uid)
3823                 Perl_croak(aTHX_ "Can't do seteuid!\n");
3824         }
3825         init_ids();
3826         if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3827             Perl_croak(aTHX_ "Effective UID cannot exec script\n");     /* they can't do this */
3828     }
3829 #ifdef IAMSUID
3830     else if (PL_preprocess)     /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
3831         Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3832     else if (PL_fdscript < 0 || PL_suidscript != 1)
3833         /* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
3834         Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
3835     else {
3836 /* PSz 16 Sep 03  Keep neat error message */
3837         Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3838     }
3839
3840     /* We absolutely must clear out any saved ids here, so we */
3841     /* exec the real perl, substituting fd script for scriptname. */
3842     /* (We pass script name as "subdir" of fd, which perl will grok.) */
3843     /*
3844      * It might be thought that using setresgid and/or setresuid (changed to
3845      * set the saved IDs) above might obviate the need to exec, and we could
3846      * go on to "do the perl thing".
3847      *
3848      * Is there such a thing as "saved GID", and is that set for setuid (but
3849      * not setgid) execution like suidperl? Without exec, it would not be
3850      * cleared for setuid (but not setgid) scripts (or might need a dummy
3851      * setresgid).
3852      *
3853      * We need suidperl to do the exact same argument checking that perl
3854      * does. Thus it cannot be very small; while it could be significantly
3855      * smaller, it is safer (simpler?) to make it essentially the same
3856      * binary as perl (but they are not identical). - Maybe could defer that
3857      * check to the invoked perl, and suidperl be a tiny wrapper instead;
3858      * but prefer to do thorough checks in suidperl itself. Such deferral
3859      * would make suidperl security rely on perl, a design no-no.
3860      *
3861      * Setuid things should be short and simple, thus easy to understand and
3862      * verify. They should do their "own thing", without influence by
3863      * attackers. It may help if their internal execution flow is fixed,
3864      * regardless of platform: it may be best to exec anyway.
3865      *
3866      * Suidperl should at least be conceptually simple: a wrapper only,
3867      * never to do any real perl. Maybe we should put
3868      * #ifdef IAMSUID
3869      *         Perl_croak(aTHX_ "Suidperl should never do real perl\n");
3870      * #endif
3871      * into the perly bits.
3872      */
3873     PerlIO_rewind(PL_rsfp);
3874     PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
3875     /* PSz 11 Nov 03
3876      * Keep original arguments: suidperl already has fd script.
3877      */
3878 /*  for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;  */
3879 /*  if (!PL_origargv[which]) {                                          */
3880 /*      errno = EPERM;                                                  */
3881 /*      Perl_croak(aTHX_ "Permission denied\n");                        */
3882 /*  }                                                                   */
3883 /*  PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",        */
3884 /*                                PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
3885 #if defined(HAS_FCNTL) && defined(F_SETFD)
3886     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
3887 #endif
3888     PERL_FPU_PRE_EXEC
3889     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3890                              (int)PERL_REVISION, (int)PERL_VERSION,
3891                              (int)PERL_SUBVERSION), PL_origargv);/* try again */
3892     PERL_FPU_POST_EXEC
3893     Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
3894 #endif /* IAMSUID */
3895 #else /* !DOSUID */
3896     if (PL_euid != PL_uid || PL_egid != PL_gid) {       /* (suidperl doesn't exist, in fact) */
3897 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3898         PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
3899         if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3900             ||
3901             (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3902            )
3903             if (!PL_do_undump)
3904                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3905 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3906 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3907         /* not set-id, must be wrapped */
3908     }
3909 #endif /* DOSUID */
3910     (void)validarg;
3911     (void)scriptname;
3912 }
3913
3914 STATIC void
3915 S_find_beginning(pTHX)
3916 {
3917     register char *s;
3918     register const char *s2;
3919 #ifdef MACOS_TRADITIONAL
3920     int maclines = 0;
3921 #endif
3922
3923     /* skip forward in input to the real script? */
3924
3925     forbid_setid("-x");
3926 #ifdef MACOS_TRADITIONAL
3927     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3928
3929     while (PL_doextract || gMacPerl_AlwaysExtract) {
3930         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3931             if (!gMacPerl_AlwaysExtract)
3932                 Perl_croak(aTHX_ "No Perl script found in input\n");
3933
3934             if (PL_doextract)                   /* require explicit override ? */
3935                 if (!OverrideExtract(PL_origfilename))
3936                     Perl_croak(aTHX_ "User aborted script\n");
3937                 else
3938                     PL_doextract = FALSE;
3939
3940             /* Pater peccavi, file does not have #! */
3941             PerlIO_rewind(PL_rsfp);
3942
3943             break;
3944         }
3945 #else
3946     while (PL_doextract) {
3947         if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3948             Perl_croak(aTHX_ "No Perl script found in input\n");
3949 #endif
3950         s2 = s;
3951         if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3952             PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
3953             PL_doextract = FALSE;
3954             while (*s && !(isSPACE (*s) || *s == '#')) s++;
3955             s2 = s;
3956             while (*s == ' ' || *s == '\t') s++;
3957             if (*s++ == '-') {
3958                 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3959                        || s2[-1] == '_') s2--;
3960                 if (strnEQ(s2-4,"perl",4))
3961                     while ((s = moreswitches(s)))
3962                         ;
3963             }
3964 #ifdef MACOS_TRADITIONAL
3965             /* We are always searching for the #!perl line in MacPerl,
3966              * so if we find it, still keep the line count correct
3967              * by counting lines we already skipped over
3968              */
3969             for (; maclines > 0 ; maclines--)
3970                 PerlIO_ungetc(PL_rsfp, '\n');
3971
3972             break;
3973
3974         /* gMacPerl_AlwaysExtract is false in MPW tool */
3975         } else if (gMacPerl_AlwaysExtract) {
3976             ++maclines;
3977 #endif
3978         }
3979     }
3980 }
3981
3982
3983 STATIC void
3984 S_init_ids(pTHX)
3985 {
3986     PL_uid = PerlProc_getuid();
3987     PL_euid = PerlProc_geteuid();
3988     PL_gid = PerlProc_getgid();
3989     PL_egid = PerlProc_getegid();
3990 #ifdef VMS
3991     PL_uid |= PL_gid << 16;
3992     PL_euid |= PL_egid << 16;
3993 #endif
3994     /* Should not happen: */
3995     CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3996     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3997     /* BUG */
3998     /* PSz 27 Feb 04
3999      * Should go by suidscript, not uid!=euid: why disallow
4000      * system("ls") in scripts run from setuid things?
4001      * Or, is this run before we check arguments and set suidscript?
4002      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4003      * (We never have suidscript, can we be sure to have fdscript?)
4004      * Or must then go by UID checks? See comments in forbid_setid also.
4005      */
4006 }
4007
4008 /* This is used very early in the lifetime of the program,
4009  * before even the options are parsed, so PL_tainting has
4010  * not been initialized properly.  */
4011 bool
4012 Perl_doing_taint(int argc, char *argv[], char *envp[])
4013 {
4014 #ifndef PERL_IMPLICIT_SYS
4015     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4016      * before we have an interpreter-- and the whole point of this
4017      * function is to be called at such an early stage.  If you are on
4018      * a system with PERL_IMPLICIT_SYS but you do have a concept of
4019      * "tainted because running with altered effective ids', you'll
4020      * have to add your own checks somewhere in here.  The two most
4021      * known samples of 'implicitness' are Win32 and NetWare, neither
4022      * of which has much of concept of 'uids'. */
4023     int uid  = PerlProc_getuid();
4024     int euid = PerlProc_geteuid();
4025     int gid  = PerlProc_getgid();
4026     int egid = PerlProc_getegid();
4027     (void)envp;
4028
4029 #ifdef VMS
4030     uid  |=  gid << 16;
4031     euid |= egid << 16;
4032 #endif
4033     if (uid && (euid != uid || egid != gid))
4034         return 1;
4035 #endif /* !PERL_IMPLICIT_SYS */
4036     /* This is a really primitive check; environment gets ignored only
4037      * if -T are the first chars together; otherwise one gets
4038      *  "Too late" message. */
4039     if ( argc > 1 && argv[1][0] == '-'
4040          && (argv[1][1] == 't' || argv[1][1] == 'T') )
4041         return 1;
4042     return 0;
4043 }
4044
4045 STATIC void
4046 S_forbid_setid(pTHX_ const char *s)
4047 {
4048 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4049     if (PL_euid != PL_uid)
4050         Perl_croak(aTHX_ "No %s allowed while running setuid", s);
4051     if (PL_egid != PL_gid)
4052         Perl_croak(aTHX_ "No %s allowed while running setgid", s);
4053 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4054     /* PSz 29 Feb 04
4055      * Checks for UID/GID above "wrong": why disallow
4056      *   perl -e 'print "Hello\n"'
4057      * from within setuid things?? Simply drop them: replaced by
4058      * fdscript/suidscript and #ifdef IAMSUID checks below.
4059      *
4060      * This may be too late for command-line switches. Will catch those on
4061      * the #! line, after finding the script name and setting up
4062      * fdscript/suidscript. Note that suidperl does not get around to
4063      * parsing (and checking) the switches on the #! line, but checks that
4064      * the two sets are identical.
4065      *
4066      * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4067      * instead, or would that be "too late"? (We never have suidscript, can
4068      * we be sure to have fdscript?)
4069      *
4070      * Catch things with suidscript (in descendant of suidperl), even with
4071      * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4072      * below; but I am paranoid.
4073      *
4074      * Also see comments about root running a setuid script, elsewhere.
4075      */
4076     if (PL_suidscript >= 0)
4077         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
4078 #ifdef IAMSUID
4079     /* PSz 11 Nov 03  Catch it in suidperl, always! */
4080     Perl_croak(aTHX_ "No %s allowed in suidperl", s);
4081 #endif /* IAMSUID */
4082 }
4083
4084 void
4085 Perl_init_debugger(pTHX)
4086 {
4087     HV *ostash = PL_curstash;
4088
4089     PL_curstash = PL_debstash;
4090     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
4091     AvREAL_off(PL_dbargs);
4092     PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
4093     PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4094     PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
4095     PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
4096     sv_setiv(PL_DBsingle, 0);
4097     PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
4098     sv_setiv(PL_DBtrace, 0);
4099     PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
4100     sv_setiv(PL_DBsignal, 0);
4101     PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
4102     sv_setiv(PL_DBassertion, 0);
4103     PL_curstash = ostash;
4104 }
4105
4106 #ifndef STRESS_REALLOC
4107 #define REASONABLE(size) (size)
4108 #else
4109 #define REASONABLE(size) (1) /* unreasonable */
4110 #endif
4111
4112 void
4113 Perl_init_stacks(pTHX)
4114 {
4115     /* start with 128-item stack and 8K cxstack */
4116     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4117                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4118     PL_curstackinfo->si_type = PERLSI_MAIN;
4119     PL_curstack = PL_curstackinfo->si_stack;
4120     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4121
4122     PL_stack_base = AvARRAY(PL_curstack);
4123     PL_stack_sp = PL_stack_base;
4124     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4125
4126     New(50,PL_tmps_stack,REASONABLE(128),SV*);
4127     PL_tmps_floor = -1;
4128     PL_tmps_ix = -1;
4129     PL_tmps_max = REASONABLE(128);
4130
4131     New(54,PL_markstack,REASONABLE(32),I32);
4132     PL_markstack_ptr = PL_markstack;
4133     PL_markstack_max = PL_markstack + REASONABLE(32);
4134
4135     SET_MARK_OFFSET;
4136
4137     New(54,PL_scopestack,REASONABLE(32),I32);
4138     PL_scopestack_ix = 0;
4139     PL_scopestack_max = REASONABLE(32);
4140
4141     New(54,PL_savestack,REASONABLE(128),ANY);
4142     PL_savestack_ix = 0;
4143     PL_savestack_max = REASONABLE(128);
4144 }
4145
4146 #undef REASONABLE
4147
4148 STATIC void
4149 S_nuke_stacks(pTHX)
4150 {
4151     while (PL_curstackinfo->si_next)
4152         PL_curstackinfo = PL_curstackinfo->si_next;
4153     while (PL_curstackinfo) {
4154         PERL_SI *p = PL_curstackinfo->si_prev;
4155         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4156         Safefree(PL_curstackinfo->si_cxstack);
4157         Safefree(PL_curstackinfo);
4158         PL_curstackinfo = p;
4159     }
4160     Safefree(PL_tmps_stack);
4161     Safefree(PL_markstack);
4162     Safefree(PL_scopestack);
4163     Safefree(PL_savestack);
4164 }
4165
4166 STATIC void
4167 S_init_lexer(pTHX)
4168 {
4169     PerlIO *tmpfp;
4170     tmpfp = PL_rsfp;
4171     PL_rsfp = Nullfp;
4172     lex_start(PL_linestr);
4173     PL_rsfp = tmpfp;
4174     PL_subname = newSVpvn("main",4);
4175 }
4176
4177 STATIC void
4178 S_init_predump_symbols(pTHX)
4179 {
4180     GV *tmpgv;
4181     IO *io;
4182
4183     sv_setpvn(get_sv("\"", TRUE), " ", 1);
4184     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
4185     GvMULTI_on(PL_stdingv);
4186     io = GvIOp(PL_stdingv);
4187     IoTYPE(io) = IoTYPE_RDONLY;
4188     IoIFP(io) = PerlIO_stdin();
4189     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
4190     GvMULTI_on(tmpgv);
4191     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4192
4193     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
4194     GvMULTI_on(tmpgv);
4195     io = GvIOp(tmpgv);
4196     IoTYPE(io) = IoTYPE_WRONLY;
4197     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4198     setdefout(tmpgv);
4199     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
4200     GvMULTI_on(tmpgv);
4201     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4202
4203     PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4204     GvMULTI_on(PL_stderrgv);
4205     io = GvIOp(PL_stderrgv);
4206     IoTYPE(io) = IoTYPE_WRONLY;
4207     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4208     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
4209     GvMULTI_on(tmpgv);
4210     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4211
4212     PL_statname = NEWSV(66,0);          /* last filename we did stat on */
4213
4214     if (PL_osname)
4215         Safefree(PL_osname);
4216     PL_osname = savepv(OSNAME);
4217 }
4218
4219 void
4220 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4221 {
4222     char *s;
4223     argc--,argv++;      /* skip name of script */
4224     if (PL_doswitches) {
4225         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4226             if (!argv[0][1])
4227                 break;
4228             if (argv[0][1] == '-' && !argv[0][2]) {
4229                 argc--,argv++;
4230                 break;
4231             }
4232             if ((s = strchr(argv[0], '='))) {
4233                 *s++ = '\0';
4234                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
4235             }
4236             else
4237                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
4238         }
4239     }
4240     if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4241         GvMULTI_on(PL_argvgv);
4242         (void)gv_AVadd(PL_argvgv);
4243         av_clear(GvAVn(PL_argvgv));
4244         for (; argc > 0; argc--,argv++) {
4245             SV *sv = newSVpv(argv[0],0);
4246             av_push(GvAVn(PL_argvgv),sv);
4247             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4248                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4249                       SvUTF8_on(sv);
4250             }
4251             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4252                  (void)sv_utf8_decode(sv);
4253         }
4254     }
4255 }
4256
4257 STATIC void
4258 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4259 {
4260     dVAR;
4261     GV* tmpgv;
4262
4263     PL_toptarget = NEWSV(0,0);
4264     sv_upgrade(PL_toptarget, SVt_PVFM);
4265     sv_setpvn(PL_toptarget, "", 0);
4266     PL_bodytarget = NEWSV(0,0);
4267     sv_upgrade(PL_bodytarget, SVt_PVFM);
4268     sv_setpvn(PL_bodytarget, "", 0);
4269     PL_formtarget = PL_bodytarget;
4270
4271     TAINT;
4272
4273     init_argv_symbols(argc,argv);
4274
4275     if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4276 #ifdef MACOS_TRADITIONAL
4277         /* $0 is not majick on a Mac */
4278         sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4279 #else
4280         sv_setpv(GvSV(tmpgv),PL_origfilename);
4281         magicname("0", "0", 1);
4282 #endif
4283     }
4284     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4285         HV *hv;
4286         GvMULTI_on(PL_envgv);
4287         hv = GvHVn(PL_envgv);
4288         hv_magic(hv, Nullgv, PERL_MAGIC_env);
4289 #ifndef PERL_MICRO
4290 #ifdef USE_ENVIRON_ARRAY
4291         /* Note that if the supplied env parameter is actually a copy
4292            of the global environ then it may now point to free'd memory
4293            if the environment has been modified since. To avoid this
4294            problem we treat env==NULL as meaning 'use the default'
4295         */
4296         if (!env)
4297             env = environ;
4298         if (env != environ
4299 #  ifdef USE_ITHREADS
4300             && PL_curinterp == aTHX
4301 #  endif
4302            )
4303         {
4304             environ[0] = Nullch;
4305         }
4306         if (env) {
4307           char** origenv = environ;
4308           char *s;
4309           SV *sv;
4310           for (; *env; env++) {
4311             if (!(s = strchr(*env,'=')) || s == *env)
4312                 continue;
4313 #if defined(MSDOS) && !defined(DJGPP)
4314             *s = '\0';
4315             (void)strupr(*env);
4316             *s = '=';
4317 #endif
4318             sv = newSVpv(s+1, 0);
4319             (void)hv_store(hv, *env, s - *env, sv, 0);
4320             if (env != environ)
4321                 mg_set(sv);
4322             if (origenv != environ) {
4323               /* realloc has shifted us */
4324               env = (env - origenv) + environ;
4325               origenv = environ;
4326             }
4327           }
4328       }
4329 #endif /* USE_ENVIRON_ARRAY */
4330 #endif /* !PERL_MICRO */
4331     }
4332     TAINT_NOT;
4333     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4334         SvREADONLY_off(GvSV(tmpgv));
4335         sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4336         SvREADONLY_on(GvSV(tmpgv));
4337     }
4338 #ifdef THREADS_HAVE_PIDS
4339     PL_ppid = (IV)getppid();
4340 #endif
4341
4342     /* touch @F array to prevent spurious warnings 20020415 MJD */
4343     if (PL_minus_a) {
4344       (void) get_av("main::F", TRUE | GV_ADDMULTI);
4345     }
4346     /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4347     (void) get_av("main::-", TRUE | GV_ADDMULTI);
4348     (void) get_av("main::+", TRUE | GV_ADDMULTI);
4349 }
4350
4351 STATIC void
4352 S_init_perllib(pTHX)
4353 {
4354     char *s;
4355     if (!PL_tainting) {
4356 #ifndef VMS
4357         s = PerlEnv_getenv("PERL5LIB");
4358         if (s)
4359             incpush(s, TRUE, TRUE, TRUE, FALSE);
4360         else
4361             incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
4362 #else /* VMS */
4363         /* Treat PERL5?LIB as a possible search list logical name -- the
4364          * "natural" VMS idiom for a Unix path string.  We allow each
4365          * element to be a set of |-separated directories for compatibility.
4366          */
4367         char buf[256];
4368         int idx = 0;
4369         if (my_trnlnm("PERL5LIB",buf,0))
4370             do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4371         else
4372             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
4373 #endif /* VMS */
4374     }
4375
4376 /* Use the ~-expanded versions of APPLLIB (undocumented),
4377     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4378 */
4379 #ifdef APPLLIB_EXP
4380     incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
4381 #endif
4382
4383 #ifdef ARCHLIB_EXP
4384     incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4385 #endif
4386 #ifdef MACOS_TRADITIONAL
4387     {
4388         Stat_t tmpstatbuf;
4389         SV * privdir = NEWSV(55, 0);
4390         char * macperl = PerlEnv_getenv("MACPERL");
4391
4392         if (!macperl)
4393             macperl = "";
4394
4395         Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4396         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4397             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4398         Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4399         if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4400             incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4401
4402         SvREFCNT_dec(privdir);
4403     }
4404     if (!PL_tainting)
4405         incpush(":", FALSE, FALSE, TRUE, FALSE);
4406 #else
4407 #ifndef PRIVLIB_EXP
4408 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4409 #endif
4410 #if defined(WIN32)
4411     incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
4412 #else
4413     incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4414 #endif
4415
4416 #ifdef SITEARCH_EXP
4417     /* sitearch is always relative to sitelib on Windows for
4418      * DLL-based path intuition to work correctly */
4419 #  if !defined(WIN32)
4420     incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4421 #  endif
4422 #endif
4423
4424 #ifdef SITELIB_EXP
4425 #  if defined(WIN32)
4426     /* this picks up sitearch as well */
4427     incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
4428 #  else
4429     incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
4430 #  endif
4431 #endif
4432
4433 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
4434     incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
4435 #endif
4436
4437 #ifdef PERL_VENDORARCH_EXP
4438     /* vendorarch is always relative to vendorlib on Windows for
4439      * DLL-based path intuition to work correctly */
4440 #  if !defined(WIN32)
4441     incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4442 #  endif
4443 #endif
4444
4445 #ifdef PERL_VENDORLIB_EXP
4446 #  if defined(WIN32)
4447     incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE);       /* this picks up vendorarch as well */
4448 #  else
4449     incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4450 #  endif
4451 #endif
4452
4453 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4454     incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
4455 #endif
4456
4457 #ifdef PERL_OTHERLIBDIRS
4458     incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
4459 #endif
4460
4461     if (!PL_tainting)
4462         incpush(".", FALSE, FALSE, TRUE, FALSE);
4463 #endif /* MACOS_TRADITIONAL */
4464 }
4465
4466 #if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
4467 #    define PERLLIB_SEP ';'
4468 #else
4469 #  if defined(VMS)
4470 #    define PERLLIB_SEP '|'
4471 #  else
4472 #    if defined(MACOS_TRADITIONAL)
4473 #      define PERLLIB_SEP ','
4474 #    else
4475 #      define PERLLIB_SEP ':'
4476 #    endif
4477 #  endif
4478 #endif
4479 #ifndef PERLLIB_MANGLE
4480 #  define PERLLIB_MANGLE(s,n) (s)
4481 #endif
4482
4483 /* Push a directory onto @INC if it exists.
4484    Generate a new SV if we do this, to save needing to copy the SV we push
4485    onto @INC  */
4486 STATIC SV *
4487 S_incpush_if_exists(pTHX_ SV *dir)
4488 {
4489     Stat_t tmpstatbuf;
4490     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4491         S_ISDIR(tmpstatbuf.st_mode)) {
4492         av_push(GvAVn(PL_incgv), dir);
4493         dir = NEWSV(0,0);
4494     }
4495     return dir;
4496 }
4497
4498 STATIC void
4499 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4500           bool canrelocate)
4501 {
4502     SV *subdir = Nullsv;
4503     const char *p = dir;
4504
4505     if (!p || !*p)
4506         return;
4507
4508     if (addsubdirs || addoldvers) {
4509         subdir = NEWSV(0,0);
4510     }
4511
4512     /* Break at all separators */
4513     while (p && *p) {
4514         SV *libdir = NEWSV(55,0);
4515         const char *s;
4516
4517         /* skip any consecutive separators */
4518         if (usesep) {
4519             while ( *p == PERLLIB_SEP ) {
4520                 /* Uncomment the next line for PATH semantics */
4521                 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4522                 p++;
4523             }
4524         }
4525
4526         if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
4527             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4528                       (STRLEN)(s - p));
4529             p = s + 1;
4530         }
4531         else {
4532             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4533             p = Nullch; /* break out */
4534         }
4535 #ifdef MACOS_TRADITIONAL
4536         if (!strchr(SvPVX(libdir), ':')) {
4537             char buf[256];
4538
4539             sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4540         }
4541         if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4542             sv_catpv(libdir, ":");
4543 #endif
4544
4545         /* Do the if() outside the #ifdef to avoid warnings about an unused
4546            parameter.  */
4547         if (canrelocate) {
4548 #ifdef PERL_RELOCATABLE_INC
4549         /*
4550          * Relocatable include entries are marked with a leading .../
4551          *
4552          * The algorithm is
4553          * 0: Remove that leading ".../"
4554          * 1: Remove trailing executable name (anything after the last '/')
4555          *    from the perl path to give a perl prefix
4556          * Then
4557          * While the @INC element starts "../" and the prefix ends with a real
4558          * directory (ie not . or ..) chop that real directory off the prefix
4559          * and the leading "../" from the @INC element. ie a logical "../"
4560          * cleanup
4561          * Finally concatenate the prefix and the remainder of the @INC element
4562          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4563          * generates /usr/local/lib/perl5
4564          */
4565             char *libpath = SvPVX(libdir);
4566             STRLEN libpath_len = SvCUR(libdir);
4567             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4568                 /* Game on!  */
4569                 SV *caret_X = get_sv("\030", 0);
4570                 /* Going to use the SV just as a scratch buffer holding a C
4571                    string:  */
4572                 SV *prefix_sv;
4573                 char *prefix;
4574                 char *lastslash;
4575
4576                 /* $^X is *the* source of taint if tainting is on, hence
4577                    SvPOK() won't be true.  */
4578                 assert(caret_X);
4579                 assert(SvPOKp(caret_X));
4580                 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4581                 /* Firstly take off the leading .../
4582                    If all else fail we'll do the paths relative to the current
4583                    directory.  */
4584                 sv_chop(libdir, libpath + 4);
4585                 /* Don't use SvPV as we're intentionally bypassing taining,
4586                    mortal copies that the mg_get of tainting creates, and
4587                    corruption that seems to come via the save stack.
4588                    I guess that the save stack isn't correctly set up yet.  */
4589                 libpath = SvPVX(libdir);
4590                 libpath_len = SvCUR(libdir);
4591
4592                 /* This would work more efficiently with memrchr, but as it's
4593                    only a GNU extension we'd need to probe for it and
4594                    implement our own. Not hard, but maybe not worth it?  */
4595
4596                 prefix = SvPVX(prefix_sv);
4597                 lastslash = strrchr(prefix, '/');
4598
4599                 /* First time in with the *lastslash = '\0' we just wipe off
4600                    the trailing /perl from (say) /usr/foo/bin/perl
4601                 */
4602                 if (lastslash) {
4603                     SV *tempsv;
4604                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4605                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4606                             && (lastslash = strrchr(prefix, '/')))) {
4607                         if (lastslash[1] == '\0'
4608                             || (lastslash[1] == '.'
4609                                 && (lastslash[2] == '/' /* ends "/."  */
4610                                     || (lastslash[2] == '/'
4611                                         && lastslash[3] == '/' /* or "/.."  */
4612                                         )))) {
4613                             /* Prefix ends "/" or "/." or "/..", any of which
4614                                are fishy, so don't do any more logical cleanup.
4615                             */
4616                             break;
4617                         }
4618                         /* Remove leading "../" from path  */
4619                         libpath += 3;
4620                         libpath_len -= 3;
4621                         /* Next iteration round the loop removes the last
4622                            directory name from prefix by writing a '\0' in
4623                            the while clause.  */
4624                     }
4625                     /* prefix has been terminated with a '\0' to the correct
4626                        length. libpath points somewhere into the libdir SV.
4627                        We need to join the 2 with '/' and drop the result into
4628                        libdir.  */
4629                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4630                     SvREFCNT_dec(libdir);
4631                     /* And this is the new libdir.  */
4632                     libdir = tempsv;
4633                     if (PL_tainting &&
4634                         (PL_uid != PL_euid || PL_gid != PL_egid)) {
4635                         /* Need to taint reloccated paths if running set ID  */
4636                         SvTAINTED_on(libdir);
4637                     }
4638                 }
4639                 SvREFCNT_dec(prefix_sv);
4640             }
4641 #endif
4642         }
4643         /*
4644          * BEFORE pushing libdir onto @INC we may first push version- and
4645          * archname-specific sub-directories.
4646          */
4647         if (addsubdirs || addoldvers) {
4648 #ifdef PERL_INC_VERSION_LIST
4649             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4650             const char *incverlist[] = { PERL_INC_VERSION_LIST };
4651             const char **incver;
4652 #endif
4653 #ifdef VMS
4654             char *unix;
4655             STRLEN len;
4656
4657             if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
4658                 len = strlen(unix);
4659                 while (unix[len-1] == '/') len--;  /* Cosmetic */
4660                 sv_usepvn(libdir,unix,len);
4661             }
4662             else
4663                 PerlIO_printf(Perl_error_log,
4664                               "Failed to unixify @INC element \"%s\"\n",
4665                               SvPV(libdir,len));
4666 #endif
4667             if (addsubdirs) {
4668 #ifdef MACOS_TRADITIONAL
4669 #define PERL_AV_SUFFIX_FMT      ""
4670 #define PERL_ARCH_FMT           "%s:"
4671 #define PERL_ARCH_FMT_PATH      PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
4672 #else
4673 #define PERL_AV_SUFFIX_FMT      "/"
4674 #define PERL_ARCH_FMT           "/%s"
4675 #define PERL_ARCH_FMT_PATH      PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4676 #endif
4677                 /* .../version/archname if -d .../version/archname */
4678                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4679                                 libdir,
4680                                (int)PERL_REVISION, (int)PERL_VERSION,
4681                                (int)PERL_SUBVERSION, ARCHNAME);
4682                 subdir = S_incpush_if_exists(aTHX_ subdir);
4683
4684                 /* .../version if -d .../version */
4685                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4686                                (int)PERL_REVISION, (int)PERL_VERSION,
4687                                (int)PERL_SUBVERSION);
4688                 subdir = S_incpush_if_exists(aTHX_ subdir);
4689
4690                 /* .../archname if -d .../archname */
4691                 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4692                 subdir = S_incpush_if_exists(aTHX_ subdir);
4693
4694             }
4695
4696 #ifdef PERL_INC_VERSION_LIST
4697             if (addoldvers) {
4698                 for (incver = incverlist; *incver; incver++) {
4699                     /* .../xxx if -d .../xxx */
4700                     Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
4701                     subdir = S_incpush_if_exists(aTHX_ subdir);
4702                 }
4703             }
4704 #endif
4705         }
4706
4707         /* finally push this lib directory on the end of @INC */
4708         av_push(GvAVn(PL_incgv), libdir);
4709     }
4710     if (subdir) {
4711         assert (SvREFCNT(subdir) == 1);
4712         SvREFCNT_dec(subdir);
4713     }
4714 }
4715
4716 #ifdef USE_5005THREADS
4717 STATIC struct perl_thread *
4718 S_init_main_thread(pTHX)
4719 {
4720 #if !defined(PERL_IMPLICIT_CONTEXT)
4721     struct perl_thread *thr;
4722 #endif
4723     XPV *xpv;
4724
4725     Newz(53, thr, 1, struct perl_thread);
4726     PL_curcop = &PL_compiling;
4727     thr->interp = PERL_GET_INTERP;
4728     thr->cvcache = newHV();
4729     thr->threadsv = newAV();
4730     /* thr->threadsvp is set when find_threadsv is called */
4731     thr->specific = newAV();
4732     thr->flags = THRf_R_JOINABLE;
4733     MUTEX_INIT(&thr->mutex);
4734     /* Handcraft thrsv similarly to mess_sv */
4735     New(53, PL_thrsv, 1, SV);
4736     Newz(53, xpv, 1, XPV);
4737     SvFLAGS(PL_thrsv) = SVt_PV;
4738     SvANY(PL_thrsv) = (void*)xpv;
4739     SvREFCNT(PL_thrsv) = 1 << 30;       /* practically infinite */
4740     SvPV_set(PL_thrsvr, (char*)thr);
4741     SvCUR_set(PL_thrsv, sizeof(thr));
4742     SvLEN_set(PL_thrsv, sizeof(thr));
4743     *SvEND(PL_thrsv) = '\0';    /* in the trailing_nul field */
4744     thr->oursv = PL_thrsv;
4745     PL_chopset = " \n-";
4746     PL_dumpindent = 4;
4747
4748     MUTEX_LOCK(&PL_threads_mutex);
4749     PL_nthreads++;
4750     thr->tid = 0;
4751     thr->next = thr;
4752     thr->prev = thr;
4753     thr->thr_done = 0;
4754     MUTEX_UNLOCK(&PL_threads_mutex);
4755
4756 #ifdef HAVE_THREAD_INTERN
4757     Perl_init_thread_intern(thr);
4758 #endif
4759
4760 #ifdef SET_THREAD_SELF
4761     SET_THREAD_SELF(thr);
4762 #else
4763     thr->self = pthread_self();
4764 #endif /* SET_THREAD_SELF */
4765     PERL_SET_THX(thr);
4766
4767     /*
4768      * These must come after the thread self setting
4769      * because sv_setpvn does SvTAINT and the taint
4770      * fields thread selfness being set.
4771      */
4772     PL_toptarget = NEWSV(0,0);
4773     sv_upgrade(PL_toptarget, SVt_PVFM);
4774     sv_setpvn(PL_toptarget, "", 0);
4775     PL_bodytarget = NEWSV(0,0);
4776     sv_upgrade(PL_bodytarget, SVt_PVFM);
4777     sv_setpvn(PL_bodytarget, "", 0);
4778     PL_formtarget = PL_bodytarget;
4779     thr->errsv = newSVpvn("", 0);
4780     (void) find_threadsv("@");  /* Ensure $@ is initialised early */
4781
4782     PL_maxscream = -1;
4783     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
4784     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4785     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4786     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4787     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4788     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
4789     PL_regindent = 0;
4790     PL_reginterp_cnt = 0;
4791
4792     return thr;
4793 }
4794 #endif /* USE_5005THREADS */
4795
4796 void
4797 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4798 {
4799     dVAR;
4800     SV *atsv;
4801     const line_t oldline = CopLINE(PL_curcop);
4802     CV *cv;
4803     STRLEN len;
4804     int ret;
4805     dJMPENV;
4806
4807     while (av_len(paramList) >= 0) {
4808         cv = (CV*)av_shift(paramList);
4809         if (PL_savebegin) {
4810             if (paramList == PL_beginav) {
4811                 /* save PL_beginav for compiler */
4812                 if (! PL_beginav_save)
4813                     PL_beginav_save = newAV();
4814                 av_push(PL_beginav_save, (SV*)cv);
4815             }
4816             else if (paramList == PL_checkav) {
4817                 /* save PL_checkav for compiler */
4818                 if (! PL_checkav_save)
4819                     PL_checkav_save = newAV();
4820                 av_push(PL_checkav_save, (SV*)cv);
4821             }
4822         } else {
4823             SAVEFREESV(cv);
4824         }
4825         JMPENV_PUSH(ret);
4826         switch (ret) {
4827         case 0:
4828             call_list_body(cv);
4829             atsv = ERRSV;
4830             (void)SvPV_const(atsv, len);
4831             if (len) {
4832                 PL_curcop = &PL_compiling;
4833                 CopLINE_set(PL_curcop, oldline);
4834                 if (paramList == PL_beginav)
4835                     sv_catpv(atsv, "BEGIN failed--compilation aborted");
4836                 else
4837                     Perl_sv_catpvf(aTHX_ atsv,
4838                                    "%s failed--call queue aborted",
4839                                    paramList == PL_checkav ? "CHECK"
4840                                    : paramList == PL_initav ? "INIT"
4841                                    : "END");
4842                 while (PL_scopestack_ix > oldscope)
4843                     LEAVE;
4844                 JMPENV_POP;
4845                 Perl_croak(aTHX_ "%"SVf"", atsv);
4846             }
4847             break;
4848         case 1:
4849             STATUS_ALL_FAILURE;
4850             /* FALL THROUGH */
4851         case 2:
4852             /* my_exit() was called */
4853             while (PL_scopestack_ix > oldscope)
4854                 LEAVE;
4855             FREETMPS;
4856             PL_curstash = PL_defstash;
4857             PL_curcop = &PL_compiling;
4858             CopLINE_set(PL_curcop, oldline);
4859             JMPENV_POP;
4860             if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4861                 if (paramList == PL_beginav)
4862                     Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4863                 else
4864                     Perl_croak(aTHX_ "%s failed--call queue aborted",
4865                                paramList == PL_checkav ? "CHECK"
4866                                : paramList == PL_initav ? "INIT"
4867                                : "END");
4868             }
4869             my_exit_jump();
4870             /* NOTREACHED */
4871         case 3:
4872             if (PL_restartop) {
4873                 PL_curcop = &PL_compiling;
4874                 CopLINE_set(PL_curcop, oldline);
4875                 JMPENV_JUMP(3);
4876             }
4877             PerlIO_printf(Perl_error_log, "panic: restartop\n");
4878             FREETMPS;
4879             break;
4880         }
4881         JMPENV_POP;
4882     }
4883 }
4884
4885 STATIC void *
4886 S_call_list_body(pTHX_ CV *cv)
4887 {
4888     PUSHMARK(PL_stack_sp);
4889     call_sv((SV*)cv, G_EVAL|G_DISCARD);
4890     return NULL;
4891 }
4892
4893 void
4894 Perl_my_exit(pTHX_ U32 status)
4895 {
4896     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4897                           thr, (unsigned long) status));
4898     switch (status) {
4899     case 0:
4900         STATUS_ALL_SUCCESS;
4901         break;
4902     case 1:
4903         STATUS_ALL_FAILURE;
4904         break;
4905     default:
4906         STATUS_NATIVE_SET(status);
4907         break;
4908     }
4909     my_exit_jump();
4910 }
4911
4912 void
4913 Perl_my_failure_exit(pTHX)
4914 {
4915 #ifdef VMS
4916     if (vaxc$errno & 1) {
4917         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
4918             STATUS_NATIVE_SET(44);
4919     }
4920     else {
4921         if (!vaxc$errno)                /* unlikely */
4922             STATUS_NATIVE_SET(44);
4923         else
4924             STATUS_NATIVE_SET(vaxc$errno);
4925     }
4926 #else
4927     int exitstatus;
4928     if (errno & 255)
4929         STATUS_UNIX_SET(errno);
4930     else {
4931         exitstatus = STATUS_UNIX >> 8;
4932         if (exitstatus & 255)
4933             STATUS_UNIX_SET(exitstatus);
4934         else
4935             STATUS_UNIX_SET(255);
4936     }
4937 #endif
4938     my_exit_jump();
4939 }
4940
4941 STATIC void
4942 S_my_exit_jump(pTHX)
4943 {
4944     dVAR;
4945     register PERL_CONTEXT *cx;
4946     I32 gimme;
4947     SV **newsp;
4948
4949     if (PL_e_script) {
4950         SvREFCNT_dec(PL_e_script);
4951         PL_e_script = Nullsv;
4952     }
4953
4954     POPSTACK_TO(PL_mainstack);
4955     if (cxstack_ix >= 0) {
4956         if (cxstack_ix > 0)
4957             dounwind(0);
4958         POPBLOCK(cx,PL_curpm);
4959         LEAVE;
4960     }
4961
4962     JMPENV_JUMP(2);
4963 }
4964
4965 static I32
4966 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4967 {
4968     const char *p, *nl;
4969     (void)idx;
4970     (void)maxlen;
4971
4972     p  = SvPVX_const(PL_e_script);
4973     nl = strchr(p, '\n');
4974     nl = (nl) ? nl+1 : SvEND(PL_e_script);
4975     if (nl-p == 0) {
4976         filter_del(read_e_script);
4977         return 0;
4978     }
4979     sv_catpvn(buf_sv, p, nl-p);
4980     sv_chop(PL_e_script, nl);
4981     return 1;
4982 }
4983
4984 /*
4985  * Local variables:
4986  * c-indentation-style: bsd
4987  * c-basic-offset: 4
4988  * indent-tabs-mode: t
4989  * End:
4990  *
4991  * ex: set ts=8 sts=4 sw=4 noet:
4992  */