perl.c

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