Rewrite delimcpy to use memchr and Copy, not per-byte

[perl5.git] / util.c

/*    util.c
 *
 *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
 *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
 *  not content.'                                    --Gandalf to Pippin
 *
 *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
 */

/* This file contains assorted utility routines.
 * Which is a polite way of saying any stuff that people couldn't think of
 * a better place for. Amongst other things, it includes the warning and
 * dieing stuff, plus wrappers for malloc code.
 */

#include "EXTERN.h"
#define PERL_IN_UTIL_C
#include "perl.h"
#include "reentr.h"

#if defined(USE_PERLIO)
#include "perliol.h" /* For PerlIOUnix_refcnt */
#endif

#ifndef PERL_MICRO
#include <signal.h>
#ifndef SIG_ERR
# define SIG_ERR ((Sighandler_t) -1)
#endif
#endif

#include <math.h>
#include <stdlib.h>

#ifdef __Lynx__
/* Missing protos on LynxOS */
int putenv(char *);
#endif

#ifdef __amigaos__
# include "amigaos4/amigaio.h"
#endif

#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
#  include <sys/select.h>
# endif
#endif

#ifdef USE_C_BACKTRACE
#  ifdef I_BFD
#    define USE_BFD
#    ifdef PERL_DARWIN
#      undef USE_BFD /* BFD is useless in OS X. */
#    endif
#    ifdef USE_BFD
#      include <bfd.h>
#    endif
#  endif
#  ifdef I_DLFCN
#    include <dlfcn.h>
#  endif
#  ifdef I_EXECINFO
#    include <execinfo.h>
#  endif
#endif

#ifdef PERL_DEBUG_READONLY_COW
# include <sys/mman.h>
#endif

#define FLUSH

/* NOTE:  Do not call the next three routines directly.  Use the macros
 * in handy.h, so that we can easily redefine everything to do tracking of
 * allocated hunks back to the original New to track down any memory leaks.
 * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
 */

#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
#  define ALWAYS_NEED_THX
#endif

#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
static void
S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
{
    if (header->readonly
     && mprotect(header, header->size, PROT_READ|PROT_WRITE))
	Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
			 header, header->size, errno);
}

static void
S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
{
    if (header->readonly
     && mprotect(header, header->size, PROT_READ))
	Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
			 header, header->size, errno);
}
# define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
# define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
#else
# define maybe_protect_rw(foo) NOOP
# define maybe_protect_ro(foo) NOOP
#endif

#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
 /* Use memory_debug_header */
# define USE_MDH
# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
   || defined(PERL_DEBUG_READONLY_COW)
#  define MDH_HAS_SIZE
# endif
#endif

/* paranoid version of system's malloc() */

Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
#ifdef ALWAYS_NEED_THX
    dTHX;
#endif
    Malloc_t ptr;
    dSAVEDERRNO;

#ifdef USE_MDH
    if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
        goto out_of_memory;
    size += PERL_MEMORY_DEBUG_HEADER_SIZE;
#endif
#ifdef DEBUGGING
    if ((SSize_t)size < 0)
	Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
#endif
    if (!size) size = 1;	/* malloc(0) is NASTY on our system */
    SAVE_ERRNO;
#ifdef PERL_DEBUG_READONLY_COW
    if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
		    MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
	perror("mmap failed");
	abort();
    }
#else
    ptr = (Malloc_t)PerlMem_malloc(size);
#endif
    PERL_ALLOC_CHECK(ptr);
    if (ptr != NULL) {
#ifdef USE_MDH
	struct perl_memory_debug_header *const header
	    = (struct perl_memory_debug_header *)ptr;
#endif

#ifdef PERL_POISON
	PoisonNew(((char *)ptr), size, char);
#endif

#ifdef PERL_TRACK_MEMPOOL
	header->interpreter = aTHX;
	/* Link us into the list.  */
	header->prev = &PL_memory_debug_header;
	header->next = PL_memory_debug_header.next;
	PL_memory_debug_header.next = header;
	maybe_protect_rw(header->next);
	header->next->prev = header;
	maybe_protect_ro(header->next);
#  ifdef PERL_DEBUG_READONLY_COW
	header->readonly = 0;
#  endif
#endif
#ifdef MDH_HAS_SIZE
	header->size = size;
#endif
	ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));

        /* malloc() can modify errno() even on success, but since someone
	   writing perl code doesn't have any control over when perl calls
	   malloc() we need to hide that.
	*/
        RESTORE_ERRNO;
    }
    else {
#ifdef USE_MDH
      out_of_memory:
#endif
        {
#ifndef ALWAYS_NEED_THX
            dTHX;
#endif
            if (PL_nomemok)
                ptr =  NULL;
            else
                croak_no_mem();
        }
    }
    return ptr;
}

/* paranoid version of system's realloc() */

Malloc_t
Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
{
#ifdef ALWAYS_NEED_THX
    dTHX;
#endif
    Malloc_t ptr;
#ifdef PERL_DEBUG_READONLY_COW
    const MEM_SIZE oldsize = where
	? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
	: 0;
#endif

    if (!size) {
	safesysfree(where);
	ptr = NULL;
    }
    else if (!where) {
	ptr = safesysmalloc(size);
    }
    else {
        dSAVE_ERRNO;
#ifdef USE_MDH
	where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
        if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
            goto out_of_memory;
	size += PERL_MEMORY_DEBUG_HEADER_SIZE;
	{
	    struct perl_memory_debug_header *const header
		= (struct perl_memory_debug_header *)where;

# ifdef PERL_TRACK_MEMPOOL
	    if (header->interpreter != aTHX) {
		Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
				     header->interpreter, aTHX);
	    }
	    assert(header->next->prev == header);
	    assert(header->prev->next == header);
#  ifdef PERL_POISON
	    if (header->size > size) {
		const MEM_SIZE freed_up = header->size - size;
		char *start_of_freed = ((char *)where) + size;
		PoisonFree(start_of_freed, freed_up, char);
	    }
#  endif
# endif
# ifdef MDH_HAS_SIZE
	    header->size = size;
# endif
	}
#endif
#ifdef DEBUGGING
	if ((SSize_t)size < 0)
	    Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
#endif
#ifdef PERL_DEBUG_READONLY_COW
	if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
			MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
	    perror("mmap failed");
	    abort();
	}
	Copy(where,ptr,oldsize < size ? oldsize : size,char);
	if (munmap(where, oldsize)) {
	    perror("munmap failed");
	    abort();
	}
#else
	ptr = (Malloc_t)PerlMem_realloc(where,size);
#endif
	PERL_ALLOC_CHECK(ptr);

    /* MUST do this fixup first, before doing ANYTHING else, as anything else
       might allocate memory/free/move memory, and until we do the fixup, it
       may well be chasing (and writing to) free memory.  */
	if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
	    struct perl_memory_debug_header *const header
		= (struct perl_memory_debug_header *)ptr;

#  ifdef PERL_POISON
	    if (header->size < size) {
		const MEM_SIZE fresh = size - header->size;
		char *start_of_fresh = ((char *)ptr) + size;
		PoisonNew(start_of_fresh, fresh, char);
	    }
#  endif

	    maybe_protect_rw(header->next);
	    header->next->prev = header;
	    maybe_protect_ro(header->next);
	    maybe_protect_rw(header->prev);
	    header->prev->next = header;
	    maybe_protect_ro(header->prev);
#endif
	    ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);

	    /* realloc() can modify errno() even on success, but since someone
	       writing perl code doesn't have any control over when perl calls
	       realloc() we need to hide that.
	    */
	    RESTORE_ERRNO;
	}

    /* In particular, must do that fixup above before logging anything via
     *printf(), as it can reallocate memory, which can cause SEGVs.  */

	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));

	if (ptr == NULL) {
#ifdef USE_MDH
          out_of_memory:
#endif
            {
#ifndef ALWAYS_NEED_THX
                dTHX;
#endif
                if (PL_nomemok)
                    ptr = NULL;
                else
                    croak_no_mem();
            }
	}
    }
    return ptr;
}

/* safe version of system's free() */

Free_t
Perl_safesysfree(Malloc_t where)
{
#ifdef ALWAYS_NEED_THX
    dTHX;
#endif
    DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
    if (where) {
#ifdef USE_MDH
	Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
	{
	    struct perl_memory_debug_header *const header
		= (struct perl_memory_debug_header *)where_intrn;

# ifdef MDH_HAS_SIZE
	    const MEM_SIZE size = header->size;
# endif
# ifdef PERL_TRACK_MEMPOOL
	    if (header->interpreter != aTHX) {
		Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
				     header->interpreter, aTHX);
	    }
	    if (!header->prev) {
		Perl_croak_nocontext("panic: duplicate free");
	    }
	    if (!(header->next))
		Perl_croak_nocontext("panic: bad free, header->next==NULL");
	    if (header->next->prev != header || header->prev->next != header) {
		Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
				     "header=%p, ->prev->next=%p",
				     header->next->prev, header,
				     header->prev->next);
	    }
	    /* Unlink us from the chain.  */
	    maybe_protect_rw(header->next);
	    header->next->prev = header->prev;
	    maybe_protect_ro(header->next);
	    maybe_protect_rw(header->prev);
	    header->prev->next = header->next;
	    maybe_protect_ro(header->prev);
	    maybe_protect_rw(header);
#  ifdef PERL_POISON
	    PoisonNew(where_intrn, size, char);
#  endif
	    /* Trigger the duplicate free warning.  */
	    header->next = NULL;
# endif
# ifdef PERL_DEBUG_READONLY_COW
	    if (munmap(where_intrn, size)) {
		perror("munmap failed");
		abort();
	    }	
# endif
	}
#else
	Malloc_t where_intrn = where;
#endif /* USE_MDH */
#ifndef PERL_DEBUG_READONLY_COW
	PerlMem_free(where_intrn);
#endif
    }
}

/* safe version of system's calloc() */

Malloc_t
Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
{
#ifdef ALWAYS_NEED_THX
    dTHX;
#endif
    Malloc_t ptr;
#if defined(USE_MDH) || defined(DEBUGGING)
    MEM_SIZE total_size = 0;
#endif

    /* Even though calloc() for zero bytes is strange, be robust. */
    if (size && (count <= MEM_SIZE_MAX / size)) {
#if defined(USE_MDH) || defined(DEBUGGING)
	total_size = size * count;
#endif
    }
    else
	croak_memory_wrap();
#ifdef USE_MDH
    if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
	total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
    else
	croak_memory_wrap();
#endif
#ifdef DEBUGGING
    if ((SSize_t)size < 0 || (SSize_t)count < 0)
	Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
			     (UV)size, (UV)count);
#endif
#ifdef PERL_DEBUG_READONLY_COW
    if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
		    MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
	perror("mmap failed");
	abort();
    }
#elif defined(PERL_TRACK_MEMPOOL)
    /* Have to use malloc() because we've added some space for our tracking
       header.  */
    /* malloc(0) is non-portable. */
    ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
#else
    /* Use calloc() because it might save a memset() if the memory is fresh
       and clean from the OS.  */
    if (count && size)
	ptr = (Malloc_t)PerlMem_calloc(count, size);
    else /* calloc(0) is non-portable. */
	ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
#endif
    PERL_ALLOC_CHECK(ptr);
    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %zu x %zu = %zu bytes\n",PTR2UV(ptr),(long)PL_an++, count, size, total_size));
    if (ptr != NULL) {
#ifdef USE_MDH
	{
	    struct perl_memory_debug_header *const header
		= (struct perl_memory_debug_header *)ptr;

#  ifndef PERL_DEBUG_READONLY_COW
	    memset((void*)ptr, 0, total_size);
#  endif
#  ifdef PERL_TRACK_MEMPOOL
	    header->interpreter = aTHX;
	    /* Link us into the list.  */
	    header->prev = &PL_memory_debug_header;
	    header->next = PL_memory_debug_header.next;
	    PL_memory_debug_header.next = header;
	    maybe_protect_rw(header->next);
	    header->next->prev = header;
	    maybe_protect_ro(header->next);
#    ifdef PERL_DEBUG_READONLY_COW
	    header->readonly = 0;
#    endif
#  endif
#  ifdef MDH_HAS_SIZE
	    header->size = total_size;
#  endif
	    ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
	}
#endif
	return ptr;
    }
    else {
#ifndef ALWAYS_NEED_THX
	dTHX;
#endif
	if (PL_nomemok)
	    return NULL;
	croak_no_mem();
    }
}

/* These must be defined when not using Perl's malloc for binary
 * compatibility */

#ifndef MYMALLOC

Malloc_t Perl_malloc (MEM_SIZE nbytes)
{
#ifdef PERL_IMPLICIT_SYS
    dTHX;
#endif
    return (Malloc_t)PerlMem_malloc(nbytes);
}

Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
{
#ifdef PERL_IMPLICIT_SYS
    dTHX;
#endif
    return (Malloc_t)PerlMem_calloc(elements, size);
}

Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
{
#ifdef PERL_IMPLICIT_SYS
    dTHX;
#endif
    return (Malloc_t)PerlMem_realloc(where, nbytes);
}

Free_t   Perl_mfree (Malloc_t where)
{
#ifdef PERL_IMPLICIT_SYS
    dTHX;
#endif
    PerlMem_free(where);
}

#endif

/* This is the value stored in *retlen in the two delimcpy routines below when
 * there wasn't enough room in the destination to store everything it was asked
 * to.  The value is deliberately very large so that hopefully if code uses it
 * unquestioninly to access memory, it will likely segfault.  And it is small
 * enough that if the caller does some arithmetic on it before accessing, it
 * won't overflow into a small legal number. */
#define DELIMCPY_OUT_OF_BOUNDS_RET  I32_MAX

/*
=for apidoc_section String Handling
=for apidoc delimcpy_no_escape

Copy a source buffer to a destination buffer, stopping at (but not including)
the first occurrence of the delimiter byte C<delim>, in the source.  The source
is the bytes between C<from> and C<fromend> inclusive.  The dest is C<to>
through C<toend>.

Nothing is copied beyond what fits between C<to> through C<toend>.  If C<delim>
doesn't occur in the source buffer, as much of the source as will fit is copied
to the destination.

The actual number of bytes copied is written to C<*retlen>.

If there is room in the destination available after the copy, an extra
terminating safety NUL byte is written (not included in the returned length).

=cut
*/
char *
Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
			const char *fromend, int delim, I32 *retlen)
{
    const char * delim_pos;
    Ptrdiff_t to_len = toend - to;

    /* Only use the minimum of the available source/dest */
    Ptrdiff_t copy_len = MIN(fromend - from, to_len);

    PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;

    assert(copy_len >= 0);

    /* Look for the first delimiter in the portion of the source we are allowed
     * to look at (determined by the input bounds). */
    delim_pos = (const char *) memchr(from, delim, copy_len);
    if (delim_pos) {
        copy_len = delim_pos - from;
    } /* else didn't find it: copy all of the source permitted */

    Copy(from, to, copy_len, char);

    if (retlen) {
        *retlen = copy_len;
    }

    /* If there is extra space available, add a trailing NUL */
    if (copy_len < to_len) {
        to[copy_len] = '\0';
    }

    return (char *) from + copy_len;
}

/*
=for apidoc delimcpy

Copy a source buffer to a destination buffer, stopping at (but not including)
the first occurrence in the source of an unescaped (defined below) delimiter
byte, C<delim>.  The source is the bytes between S<C<from> and C<from_end> -
1>.  Similarly, the dest is C<to> up to C<to_end>.

The number of bytes copied is written to C<*retlen>.

Returns the position of the first uncopied C<delim> in the C<from> buffer, but
if there is no such occurrence before C<from_end>, then C<from_end> is returned,
and the entire buffer S<C<from> .. C<from_end> - 1> is copied.

If there is room in the destination available after the copy, an extra
terminating safety C<NUL> byte is appended (not included in the returned
length).

The error case is if the destination buffer is not large enough to accommodate
everything that should be copied.  In this situation, a value larger than
S<C<to_end> - C<to>> is written to C<*retlen>, and as much of the source as
fits will be written to the destination.  Not having room for the safety C<NUL>
is not considered an error.

In the following examples, let C<x> be the delimiter, and C<0> represent a C<NUL>
byte (B<NOT> the digit C<0>).  Then we would have

  Source     Destination
 abcxdef        abc0

provided the destination buffer is at least 4 bytes long.

An escaped delimiter is one which is immediately preceded by a single
backslash.  Escaped delimiters are copied, and the copy continues past the
delimiter; the backslash is not copied:

  Source       Destination
 abc\xdef       abcxdef0

(provided the destination buffer is at least 8 bytes long).

It's actually somewhat more complicated than that. A sequence of any odd number
of backslashes escapes the following delimiter, and the copy continues with
exactly one of the backslashes stripped.

     Source         Destination
     abc\xdef          abcxdef0
   abc\\\xdef        abc\\xdef0
 abc\\\\\xdef      abc\\\\xdef0

(as always, if the destination is large enough)

An even number of preceding backslashes does not escape the delimiter, so that
the copy stops just before it, and includes all the backslashes (no stripping;
zero is considered even):

      Source         Destination
      abcxdef          abc0
    abc\\xdef          abc\\0
  abc\\\\xdef          abc\\\\0

=cut
*/

char *
Perl_delimcpy(char *to, const char *to_end,
              const char *from, const char *from_end,
              const int delim, I32 *retlen)
{
    const char * const orig_to = to;
    Ptrdiff_t copy_len = 0;
    bool stopped_early = FALSE;     /* Ran out of room to copy to */

    PERL_ARGS_ASSERT_DELIMCPY;
    assert(from_end >= from);
    assert(to_end >= to);

    /* Don't use the loop for the trivial case of the first character being the
     * delimiter; otherwise would have to worry inside the loop about backing
     * up before the start of 'from' */
    if (LIKELY(from_end > from && *from != delim)) {
        while ((copy_len = from_end - from) > 0) {
            const char * backslash_pos;
            const char * delim_pos;

            /* Look for the next delimiter in the remaining portion of the
             * source. A loop invariant is that we already know that the copy
             * should include *from; this comes from the conditional before the
             * loop, and how we set things up at the end of each iteration */
            delim_pos = (const char *) memchr(from + 1, delim, copy_len - 1);

            /* If didn't find it, done looking; set up so copies all of the
             * source */
            if (! delim_pos) {
                copy_len = from_end - from;
                break;
            }

            /* Look for a backslash immediately before the delimiter */
            backslash_pos = delim_pos - 1;

            /* If the delimiter is not escaped, this ends the copy */
            if (*backslash_pos != '\\') {
                copy_len = delim_pos - from;
                break;
            }

            /* Here there is a backslash just before the delimiter, but it
             * could be the final backslash in a sequence of them.  Backup to
             * find the first one in it. */
            do {
                backslash_pos--;
            }
            while (backslash_pos >= from && *backslash_pos == '\\');

            /* If the number of backslashes is even, they just escape one
             * another, leaving the delimiter unescaped, and stopping the copy.
             * */
            if (! ((delim_pos - (backslash_pos + 1)) & 1)) {
                copy_len = delim_pos - from;  /* even, copy up to delimiter */
                break;
            }

            /* Here is odd, so the delimiter is escaped.  We will try to copy
             * all but the final backslash in the sequence */
            copy_len = delim_pos - 1 - from;

            /* Do the copy, but not beyond the end of the destination */
            if (copy_len >= to_end - to) {
                Copy(from, to, to_end - to, char);
                stopped_early = TRUE;
                to = (char *) to_end;
            }
            else {
                Copy(from, to, copy_len, char);
                to += copy_len;
            }

            /* Set up so next iteration will include the delimiter */
            from = delim_pos;
        }
    }

    /* Here, have found the final segment to copy.  Copy that, but not beyond
     * the size of the destination.  If not enough room, copy as much as can
     * fit, and set error return */
    if (stopped_early || copy_len > to_end - to) {
        Copy(from, to, to_end - to, char);
        *retlen = DELIMCPY_OUT_OF_BOUNDS_RET;
    }
    else {
        Copy(from, to, copy_len, char);

        to += copy_len;

        /* If there is extra space available, add a trailing NUL */
        if (to < to_end) {
            *to = '\0';
        }

        *retlen = to - orig_to;
    }

    return (char *) from + copy_len;
}

/*
=for apidoc ninstr

Find the first (leftmost) occurrence of a sequence of bytes within another
sequence.  This is the Perl version of C<strstr()>, extended to handle
arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
is what the initial C<n> in the function name stands for; some systems have an
equivalent, C<memmem()>, but with a somewhat different API).

Another way of thinking about this function is finding a needle in a haystack.
C<big> points to the first byte in the haystack.  C<big_end> points to one byte
beyond the final byte in the haystack.  C<little> points to the first byte in
the needle.  C<little_end> points to one byte beyond the final byte in the
needle.  All the parameters must be non-C<NULL>.

The function returns C<NULL> if there is no occurrence of C<little> within
C<big>.  If C<little> is the empty string, C<big> is returned.

Because this function operates at the byte level, and because of the inherent
characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
needle and the haystack are strings with the same UTF-8ness, but not if the
UTF-8ness differs.

=cut

*/

char *
Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
    PERL_ARGS_ASSERT_NINSTR;

#ifdef HAS_MEMMEM
    return ninstr(big, bigend, little, lend);
#else

    if (little >= lend) {
        return (char*) big;
    }
    else {
        const U8 first = *little;
        Size_t lsize;

        /* No match can start closer to the end of the haystack than the length
         * of the needle. */
        bigend -= lend - little;
        little++;       /* Look for 'first', then the remainder is in here */
        lsize = lend - little;

        while (big <= bigend) {
            big = (char *) memchr((U8 *) big, first, bigend - big + 1);
            if (big == NULL || big > bigend) {
                return NULL;
            }

            if (memEQ(big + 1, little, lsize)) {
                return (char*) big;
            }
            big++;
        }
    }

    return NULL;

#endif

}

/*
=for apidoc rninstr

Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
sequence of bytes within another sequence, returning C<NULL> if there is no
such occurrence.

=cut

*/

char *
Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
    const Ptrdiff_t little_len = lend - little;
    const Ptrdiff_t big_len = bigend - big;

    PERL_ARGS_ASSERT_RNINSTR;

    /* A non-existent needle trivially matches the rightmost possible position
     * in the haystack */
    if (UNLIKELY(little_len <= 0)) {
	return (char*)bigend;
    }

    /* If the needle is larger than the haystack, the needle can't possibly fit
     * inside the haystack. */
    if (UNLIKELY(little_len > big_len)) {
        return NULL;
    }

    /* Special case length 1 needles.  It's trivial if we have memrchr();
     * and otherwise we just do a per-byte search backwards.
     *
     * XXX When we don't have memrchr, we could use something like
     * S_find_next_masked( or S_find_span_end() to do per-word searches */
    if (little_len == 1) {
        const char final = *little;

#ifdef HAS_MEMRCHR

        return (char *) memrchr(big, final, big_len);
#else
        const char * cur = bigend - 1;

        do {
            if (*cur == final) {
                return (char *) cur;
            }
        } while (--cur >= big);

        return NULL;
#endif

    }
    else {  /* Below, the needle is longer than a single byte */

        /* We search backwards in the haystack for the final character of the
         * needle.  Each time one is found, we see if the characters just
         * before it in the haystack match the rest of the needle. */
        const char final = *(lend - 1);

        /* What matches consists of 'little_len'-1 characters, then the final
         * one */
        const Size_t prefix_len = little_len - 1;

        /* If the final character in the needle is any closer than this to the
         * left edge, there wouldn't be enough room for all of it to fit in the
         * haystack */
        const char * const left_fence = big + prefix_len;

        /* Start at the right edge */
        char * cur = (char *) bigend;

        /* memrchr() makes the search easy (and fast); otherwise, look
         * backwards byte-by-byte. */
        do {

#ifdef HAS_MEMRCHR

            cur = (char *) memrchr(left_fence, final, cur - left_fence);
            if (cur == NULL) {
                return NULL;
            }
#else
            do {
                cur--;
                if (cur < left_fence) {
                    return NULL;
                }
            }
            while (*cur != final);
#endif

            /* Here, we know that *cur is 'final'; see if the preceding bytes
             * of the needle also match the corresponding haystack bytes */
            if memEQ(cur - prefix_len, little, prefix_len) {
                return cur - prefix_len;
            }
        } while (cur > left_fence);

        return NULL;
    }
}

/* As a space optimization, we do not compile tables for strings of length
   0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
   special-cased in fbm_instr().

   If FBMcf_TAIL, the table is created as if the string has a trailing \n. */

/*

=for apidoc fbm_compile

Analyzes the string in order to make fast searches on it using C<fbm_instr()>
-- the Boyer-Moore algorithm.

=cut
*/

void
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
    const U8 *s;
    STRLEN i;
    STRLEN len;
    MAGIC *mg;

    PERL_ARGS_ASSERT_FBM_COMPILE;

    if (isGV_with_GP(sv) || SvROK(sv))
	return;

    if (SvVALID(sv))
	return;

    if (flags & FBMcf_TAIL) {
	MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
	sv_catpvs(sv, "\n");		/* Taken into account in fbm_instr() */
	if (mg && mg->mg_len >= 0)
	    mg->mg_len++;
    }
    if (!SvPOK(sv) || SvNIOKp(sv))
	s = (U8*)SvPV_force_mutable(sv, len);
    else s = (U8 *)SvPV_mutable(sv, len);
    if (len == 0)		/* TAIL might be on a zero-length string. */
	return;
    SvUPGRADE(sv, SVt_PVMG);
    SvIOK_off(sv);
    SvNOK_off(sv);

    /* add PERL_MAGIC_bm magic holding the FBM lookup table */

    assert(!mg_find(sv, PERL_MAGIC_bm));
    mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
    assert(mg);

    if (len > 2) {
	/* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
	   the BM table.  */
	const U8 mlen = (len>255) ? 255 : (U8)len;
	const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
	U8 *table;

	Newx(table, 256, U8);
	memset((void*)table, mlen, 256);
	mg->mg_ptr = (char *)table;
	mg->mg_len = 256;

	s += len - 1; /* last char */
	i = 0;
	while (s >= sb) {
	    if (table[*s] == mlen)
		table[*s] = (U8)i;
	    s--, i++;
	}
    }

    BmUSEFUL(sv) = 100;			/* Initial value */
    ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
}


/*
=for apidoc fbm_instr

Returns the location of the SV in the string delimited by C<big> and
C<bigend> (C<bigend>) is the char following the last char).
It returns C<NULL> if the string can't be found.  The C<sv>
does not have to be C<fbm_compiled>, but the search will not be as fast
then.

=cut

If SvTAIL(littlestr) is true, a fake "\n" was appended to the string
during FBM compilation due to FBMcf_TAIL in flags. It indicates that
the littlestr must be anchored to the end of bigstr (or to any \n if
FBMrf_MULTILINE).

E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
while /abc$/ compiles to "abc\n" with SvTAIL() true.

A littlestr of "abc", !SvTAIL matches as /abc/;
a littlestr of "ab\n", SvTAIL matches as:
   without FBMrf_MULTILINE: /ab\n?\z/
   with    FBMrf_MULTILINE: /ab\n/ || /ab\z/;

(According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
  "If SvTAIL is actually due to \Z or \z, this gives false positives
  if multiline".
*/


char *
Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
{
    unsigned char *s;
    STRLEN l;
    const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
    STRLEN littlelen = l;
    const I32 multiline = flags & FBMrf_MULTILINE;
    bool valid = SvVALID(littlestr);
    bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE;

    PERL_ARGS_ASSERT_FBM_INSTR;

    assert(bigend >= big);

    if ((STRLEN)(bigend - big) < littlelen) {
	if (     tail
	     && ((STRLEN)(bigend - big) == littlelen - 1)
	     && (littlelen == 1
		 || (*big == *little &&
		     memEQ((char *)big, (char *)little, littlelen - 1))))
	    return (char*)big;
	return NULL;
    }

    switch (littlelen) { /* Special cases for 0, 1 and 2  */
    case 0:
	return (char*)big;		/* Cannot be SvTAIL! */

    case 1:
	    if (tail && !multiline) /* Anchor only! */
		/* [-1] is safe because we know that bigend != big.  */
		return (char *) (bigend - (bigend[-1] == '\n'));

	    s = (unsigned char *)memchr((void*)big, *little, bigend-big);
            if (s)
                return (char *)s;
	    if (tail)
		return (char *) bigend;
	    return NULL;

    case 2:
	if (tail && !multiline) {
            /* a littlestr with SvTAIL must be of the form "X\n" (where X
             * is a single char). It is anchored, and can only match
             * "....X\n"  or  "....X" */
            if (bigend[-2] == *little && bigend[-1] == '\n')
		return (char*)bigend - 2;
	    if (bigend[-1] == *little)
		return (char*)bigend - 1;
	    return NULL;
	}

	{
            /* memchr() is likely to be very fast, possibly using whatever
             * hardware support is available, such as checking a whole
             * cache line in one instruction.
             * So for a 2 char pattern, calling memchr() is likely to be
             * faster than running FBM, or rolling our own. The previous
             * version of this code was roll-your-own which typically
             * only needed to read every 2nd char, which was good back in
             * the day, but no longer.
             */
	    unsigned char c1 = little[0];
	    unsigned char c2 = little[1];

            /* *** for all this case, bigend points to the last char,
             * not the trailing \0: this makes the conditions slightly
             * simpler */
            bigend--;
	    s = big;
            if (c1 != c2) {
                while (s < bigend) {
                    /* do a quick test for c1 before calling memchr();
                     * this avoids the expensive fn call overhead when
                     * there are lots of c1's */
                    if (LIKELY(*s != c1)) {
                        s++;
                        s = (unsigned char *)memchr((void*)s, c1, bigend - s);
                        if (!s)
                            break;
                    }
                    if (s[1] == c2)
                        return (char*)s;

                    /* failed; try searching for c2 this time; that way
                     * we don't go pathologically slow when the string
                     * consists mostly of c1's or vice versa.
                     */
                    s += 2;
                    if (s > bigend)
                        break;
                    s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
                    if (!s)
                        break;
                    if (s[-1] == c1)
                        return (char*)s - 1;
                }
            }
            else {
                /* c1, c2 the same */
                while (s < bigend) {
                    if (s[0] == c1) {
                      got_1char:
                        if (s[1] == c1)
                            return (char*)s;
                        s += 2;
                    }
                    else {
                        s++;
                        s = (unsigned char *)memchr((void*)s, c1, bigend - s);
                        if (!s || s >= bigend)
                            break;
                        goto got_1char;
                    }
                }
            }

            /* failed to find 2 chars; try anchored match at end without
             * the \n */
            if (tail && bigend[0] == little[0])
                return (char *)bigend;
            return NULL;
        }

    default:
	break; /* Only lengths 0 1 and 2 have special-case code.  */
    }

    if (tail && !multiline) {	/* tail anchored? */
	s = bigend - littlelen;
	if (s >= big && bigend[-1] == '\n' && *s == *little
	    /* Automatically of length > 2 */
	    && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
	{
	    return (char*)s;		/* how sweet it is */
	}
	if (s[1] == *little
	    && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
	{
	    return (char*)s + 1;	/* how sweet it is */
	}
	return NULL;
    }

    if (!valid) {
        /* not compiled; use Perl_ninstr() instead */
	char * const b = ninstr((char*)big,(char*)bigend,
			 (char*)little, (char*)little + littlelen);

        assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
	return b;
    }

    /* Do actual FBM.  */
    if (littlelen > (STRLEN)(bigend - big))
	return NULL;

    {
	const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
	const unsigned char *oldlittle;

	assert(mg);

	--littlelen;			/* Last char found by table lookup */

	s = big + littlelen;
	little += littlelen;		/* last char */
	oldlittle = little;
	if (s < bigend) {
	    const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
            const unsigned char lastc = *little;
	    I32 tmp;

	  top2:
	    if ((tmp = table[*s])) {
                /* *s != lastc; earliest position it could match now is
                 * tmp slots further on */
		if ((s += tmp) >= bigend)
                    goto check_end;
                if (LIKELY(*s != lastc)) {
                    s++;
                    s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
                    if (!s) {
                        s = bigend;
                        goto check_end;
                    }
                    goto top2;
                }
	    }


            /* hand-rolled strncmp(): less expensive than calling the
             * real function (maybe???) */
	    {
		unsigned char * const olds = s;

		tmp = littlelen;

		while (tmp--) {
		    if (*--s == *--little)
			continue;
		    s = olds + 1;	/* here we pay the price for failure */
		    little = oldlittle;
		    if (s < bigend)	/* fake up continue to outer loop */
			goto top2;
		    goto check_end;
		}
		return (char *)s;
	    }
	}
      check_end:
	if ( s == bigend
	     && tail
	     && memEQ((char *)(bigend - littlelen),
		      (char *)(oldlittle - littlelen), littlelen) )
	    return (char*)bigend - littlelen;
	return NULL;
    }
}

const char *
Perl_cntrl_to_mnemonic(const U8 c)
{
    /* Returns the mnemonic string that represents character 'c', if one
     * exists; NULL otherwise.  The only ones that exist for the purposes of
     * this routine are a few control characters */

    switch (c) {
        case '\a':       return "\\a";
        case '\b':       return "\\b";
        case ESC_NATIVE: return "\\e";
        case '\f':       return "\\f";
        case '\n':       return "\\n";
        case '\r':       return "\\r";
        case '\t':       return "\\t";
    }

    return NULL;
}

/* copy a string to a safe spot */

/*
=for apidoc_section String Handling
=for apidoc savepv

Perl's version of C<strdup()>.  Returns a pointer to a newly allocated
string which is a duplicate of C<pv>.  The size of the string is
determined by C<strlen()>, which means it may not contain embedded C<NUL>
characters and must have a trailing C<NUL>.  To prevent memory leaks, the
memory allocated for the new string needs to be freed when no longer needed.
This can be done with the C<L</Safefree>> function, or
L<C<SAVEFREEPV>|perlguts/SAVEFREEPV(p)>.

On some platforms, Windows for example, all allocated memory owned by a thread
is deallocated when that thread ends.  So if you need that not to happen, you
need to use the shared memory functions, such as C<L</savesharedpv>>.

=cut
*/

char *
Perl_savepv(pTHX_ const char *pv)
{
    PERL_UNUSED_CONTEXT;
    if (!pv)
	return NULL;
    else {
	char *newaddr;
	const STRLEN pvlen = strlen(pv)+1;
	Newx(newaddr, pvlen, char);
	return (char*)memcpy(newaddr, pv, pvlen);
    }
}

/* same thing but with a known length */

/*
=for apidoc savepvn

Perl's version of what C<strndup()> would be if it existed.  Returns a
pointer to a newly allocated string which is a duplicate of the first
C<len> bytes from C<pv>, plus a trailing
C<NUL> byte.  The memory allocated for
the new string can be freed with the C<Safefree()> function.

On some platforms, Windows for example, all allocated memory owned by a thread
is deallocated when that thread ends.  So if you need that not to happen, you
need to use the shared memory functions, such as C<L</savesharedpvn>>.

=cut
*/

char *
Perl_savepvn(pTHX_ const char *pv, Size_t len)
{
    char *newaddr;
    PERL_UNUSED_CONTEXT;

    Newx(newaddr,len+1,char);
    /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
    if (pv) {
	/* might not be null terminated */
    	newaddr[len] = '\0';
    	return (char *) CopyD(pv,newaddr,len,char);
    }
    else {
	return (char *) ZeroD(newaddr,len+1,char);
    }
}

/*
=for apidoc savesharedpv

A version of C<savepv()> which allocates the duplicate string in memory
which is shared between threads.

=cut
*/
char *
Perl_savesharedpv(pTHX_ const char *pv)
{
    char *newaddr;
    STRLEN pvlen;

    PERL_UNUSED_CONTEXT;

    if (!pv)
	return NULL;

    pvlen = strlen(pv)+1;
    newaddr = (char*)PerlMemShared_malloc(pvlen);
    if (!newaddr) {
	croak_no_mem();
    }
    return (char*)memcpy(newaddr, pv, pvlen);
}

/*
=for apidoc savesharedpvn

A version of C<savepvn()> which allocates the duplicate string in memory
which is shared between threads.  (With the specific difference that a C<NULL>
pointer is not acceptable)

=cut
*/
char *
Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
{
    char *const newaddr = (char*)PerlMemShared_malloc(len + 1);

    PERL_UNUSED_CONTEXT;
    /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */

    if (!newaddr) {
	croak_no_mem();
    }
    newaddr[len] = '\0';
    return (char*)memcpy(newaddr, pv, len);
}

/*
=for apidoc savesvpv

A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
the passed in SV using C<SvPV()>

On some platforms, Windows for example, all allocated memory owned by a thread
is deallocated when that thread ends.  So if you need that not to happen, you
need to use the shared memory functions, such as C<L</savesharedsvpv>>.

=cut
*/

char *
Perl_savesvpv(pTHX_ SV *sv)
{
    STRLEN len;
    const char * const pv = SvPV_const(sv, len);
    char *newaddr;

    PERL_ARGS_ASSERT_SAVESVPV;

    ++len;
    Newx(newaddr,len,char);
    return (char *) CopyD(pv,newaddr,len,char);
}

/*
=for apidoc savesharedsvpv

A version of C<savesharedpv()> which allocates the duplicate string in
memory which is shared between threads.

=cut
*/

char *
Perl_savesharedsvpv(pTHX_ SV *sv)
{
    STRLEN len;
    const char * const pv = SvPV_const(sv, len);

    PERL_ARGS_ASSERT_SAVESHAREDSVPV;

    return savesharedpvn(pv, len);
}

/* the SV for Perl_form() and mess() is not kept in an arena */

STATIC SV *
S_mess_alloc(pTHX)
{
    SV *sv;
    XPVMG *any;

    if (PL_phase != PERL_PHASE_DESTRUCT)
	return newSVpvs_flags("", SVs_TEMP);

    if (PL_mess_sv)
	return PL_mess_sv;

    /* Create as PVMG now, to avoid any upgrading later */
    Newx(sv, 1, SV);
    Newxz(any, 1, XPVMG);
    SvFLAGS(sv) = SVt_PVMG;
    SvANY(sv) = (void*)any;
    SvPV_set(sv, NULL);
    SvREFCNT(sv) = 1 << 30; /* practically infinite */
    PL_mess_sv = sv;
    return sv;
}

#if defined(PERL_IMPLICIT_CONTEXT)
char *
Perl_form_nocontext(const char* pat, ...)
{
    dTHX;
    char *retval;
    va_list args;
    PERL_ARGS_ASSERT_FORM_NOCONTEXT;
    va_start(args, pat);
    retval = vform(pat, &args);
    va_end(args);
    return retval;
}
#endif /* PERL_IMPLICIT_CONTEXT */

/*
=for apidoc_section Display and Dump functions
=for apidoc form
=for apidoc_item form_nocontext

These take a sprintf-style format pattern and conventional
(non-SV) arguments and return the formatted string.

    (char *) Perl_form(pTHX_ const char* pat, ...)

can be used any place a string (char *) is required:

    char * s = Perl_form("%d.%d",major,minor);

They use a single private buffer so if you want to format several strings you
must explicitly copy the earlier strings away (and free the copies when you
are done).

The two forms differ only in that C<form_nocontext> does not take a thread
context (C<aTHX>) parameter, so is used in situations where the caller doesn't
already have the thread context.

=for apidoc vform
Like C<L</form>> but but the arguments are an encapsulated argument list.

=cut
*/

char *
Perl_form(pTHX_ const char* pat, ...)
{
    char *retval;
    va_list args;
    PERL_ARGS_ASSERT_FORM;
    va_start(args, pat);
    retval = vform(pat, &args);
    va_end(args);
    return retval;
}

char *
Perl_vform(pTHX_ const char *pat, va_list *args)
{
    SV * const sv = mess_alloc();
    PERL_ARGS_ASSERT_VFORM;
    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
    return SvPVX(sv);
}

/*
=for apidoc mess
=for apidoc_item mess_nocontext

These take a sprintf-style format pattern and argument list, which are used to
generate a string message.  If the message does not end with a newline, then it
will be extended with some indication of the current location in the code, as
described for C<L</mess_sv>>.

Normally, the resulting message is returned in a new mortal SV.
But during global destruction a single SV may be shared between uses of
this function.

The two forms differ only in that C<mess_nocontext> does not take a thread
context (C<aTHX>) parameter, so is used in situations where the caller doesn't
already have the thread context.

=cut
*/

#if defined(PERL_IMPLICIT_CONTEXT)
SV *
Perl_mess_nocontext(const char *pat, ...)
{
    dTHX;
    SV *retval;
    va_list args;
    PERL_ARGS_ASSERT_MESS_NOCONTEXT;
    va_start(args, pat);
    retval = vmess(pat, &args);
    va_end(args);
    return retval;
}
#endif /* PERL_IMPLICIT_CONTEXT */

SV *
Perl_mess(pTHX_ const char *pat, ...)
{
    SV *retval;
    va_list args;
    PERL_ARGS_ASSERT_MESS;
    va_start(args, pat);
    retval = vmess(pat, &args);
    va_end(args);
    return retval;
}

const COP*
Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
		       bool opnext)
{
    /* Look for curop starting from o.  cop is the last COP we've seen. */
    /* opnext means that curop is actually the ->op_next of the op we are
       seeking. */

    PERL_ARGS_ASSERT_CLOSEST_COP;

    if (!o || !curop || (
	opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
    ))
	return cop;

    if (o->op_flags & OPf_KIDS) {
	const OP *kid;
	for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
	    const COP *new_cop;

	    /* If the OP_NEXTSTATE has been optimised away we can still use it
	     * the get the file and line number. */

	    if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
		cop = (const COP *)kid;

	    /* Keep searching, and return when we've found something. */

	    new_cop = closest_cop(cop, kid, curop, opnext);
	    if (new_cop)
		return new_cop;
	}
    }

    /* Nothing found. */

    return NULL;
}

/*
=for apidoc mess_sv

Expands a message, intended for the user, to include an indication of
the current location in the code, if the message does not already appear
to be complete.

C<basemsg> is the initial message or object.  If it is a reference, it
will be used as-is and will be the result of this function.  Otherwise it
is used as a string, and if it already ends with a newline, it is taken
to be complete, and the result of this function will be the same string.
If the message does not end with a newline, then a segment such as C<at
foo.pl line 37> will be appended, and possibly other clauses indicating
the current state of execution.  The resulting message will end with a
dot and a newline.

Normally, the resulting message is returned in a new mortal SV.
During global destruction a single SV may be shared between uses of this
function.  If C<consume> is true, then the function is permitted (but not
required) to modify and return C<basemsg> instead of allocating a new SV.

=cut
*/

SV *
Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
{
    SV *sv;

#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
    {
        char *ws;
        UV wi;
        /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
        if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
            && grok_atoUV(ws, &wi, NULL)
            && wi <= PERL_INT_MAX
        ) {
            Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
        }
    }
#endif

    PERL_ARGS_ASSERT_MESS_SV;

    if (SvROK(basemsg)) {
	if (consume) {
	    sv = basemsg;
	}
	else {
	    sv = mess_alloc();
	    sv_setsv(sv, basemsg);
	}
	return sv;
    }

    if (SvPOK(basemsg) && consume) {
	sv = basemsg;
    }
    else {
	sv = mess_alloc();
	sv_copypv(sv, basemsg);
    }

    if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
	/*
	 * Try and find the file and line for PL_op.  This will usually be
	 * PL_curcop, but it might be a cop that has been optimised away.  We
	 * can try to find such a cop by searching through the optree starting
	 * from the sibling of PL_curcop.
	 */

        if (PL_curcop) {
            const COP *cop =
                closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
            if (!cop)
                cop = PL_curcop;

            if (CopLINE(cop))
                Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
                                OutCopFILE(cop), (IV)CopLINE(cop));
        }

	/* Seems that GvIO() can be untrustworthy during global destruction. */
	if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
		&& IoLINES(GvIOp(PL_last_in_gv)))
	{
	    STRLEN l;
	    const bool line_mode = (RsSIMPLE(PL_rs) &&
				   *SvPV_const(PL_rs,l) == '\n' && l == 1);
	    Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
			   SVfARG(PL_last_in_gv == PL_argvgv
                                 ? &PL_sv_no
                                 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
			   line_mode ? "line" : "chunk",
			   (IV)IoLINES(GvIOp(PL_last_in_gv)));
	}
	if (PL_phase == PERL_PHASE_DESTRUCT)
	    sv_catpvs(sv, " during global destruction");
	sv_catpvs(sv, ".\n");
    }
    return sv;
}

/*
=for apidoc vmess

C<pat> and C<args> are a sprintf-style format pattern and encapsulated
argument list, respectively.  These are used to generate a string message.  If
the
message does not end with a newline, then it will be extended with
some indication of the current location in the code, as described for
L</mess_sv>.

Normally, the resulting message is returned in a new mortal SV.
During global destruction a single SV may be shared between uses of
this function.

=cut
*/

SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
    SV * const sv = mess_alloc();

    PERL_ARGS_ASSERT_VMESS;

    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
    return mess_sv(sv, 1);
}

void
Perl_write_to_stderr(pTHX_ SV* msv)
{
    IO *io;
    MAGIC *mg;

    PERL_ARGS_ASSERT_WRITE_TO_STDERR;

    if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
	&& (io = GvIO(PL_stderrgv))
	&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
	Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
			    G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
    else {
	PerlIO * const serr = Perl_error_log;

	do_print(msv, serr);
	(void)PerlIO_flush(serr);
    }
}

/*
=for apidoc_section Warning and Dieing
*/

/* Common code used in dieing and warning */

STATIC SV *
S_with_queued_errors(pTHX_ SV *ex)
{
    PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
    if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
	sv_catsv(PL_errors, ex);
	ex = sv_mortalcopy(PL_errors);
	SvCUR_set(PL_errors, 0);
    }
    return ex;
}

STATIC bool
S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
    HV *stash;
    GV *gv;
    CV *cv;
    SV **const hook = warn ? &PL_warnhook : &PL_diehook;
    /* sv_2cv might call Perl_croak() or Perl_warner() */
    SV * const oldhook = *hook;

    if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
	return FALSE;

    ENTER;
    SAVESPTR(*hook);
    *hook = NULL;
    cv = sv_2cv(oldhook, &stash, &gv, 0);
    LEAVE;
    if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
	dSP;
	SV *exarg;

	ENTER;
	save_re_context();
	if (warn) {
	    SAVESPTR(*hook);
	    *hook = NULL;
	}
	exarg = newSVsv(ex);
	SvREADONLY_on(exarg);
	SAVEFREESV(exarg);

	PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
	PUSHMARK(SP);
	XPUSHs(exarg);
	PUTBACK;
	call_sv(MUTABLE_SV(cv), G_DISCARD);
	POPSTACK;
	LEAVE;
	return TRUE;
    }
    return FALSE;
}

/*
=for apidoc die_sv
=for apidoc_item die_nocontext

These ehave the same as L</croak_sv>, except for the return type.
It should be used only where the C<OP *> return type is required.
The functions never actually return.

The two forms differ only in that C<die_nocontext> does not take a thread
context (C<aTHX>) parameter, so is used in situations where the caller doesn't
already have the thread context.

=cut
*/

/* silence __declspec(noreturn) warnings */
MSVC_DIAG_IGNORE(4646 4645)
OP *
Perl_die_sv(pTHX_ SV *baseex)
{
    PERL_ARGS_ASSERT_DIE_SV;
    croak_sv(baseex);
    /* NOTREACHED */
    NORETURN_FUNCTION_END;
}
MSVC_DIAG_RESTORE

/*
=for apidoc die

Behaves the same as L</croak>, except for the return type.
It should be used only where the C<OP *> return type is required.
The function never actually returns.

=cut
*/

#if defined(PERL_IMPLICIT_CONTEXT)

/* silence __declspec(noreturn) warnings */
MSVC_DIAG_IGNORE(4646 4645)
OP *
Perl_die_nocontext(const char* pat, ...)
{
    dTHX;
    va_list args;
    va_start(args, pat);
    vcroak(pat, &args);
    NOT_REACHED; /* NOTREACHED */
    va_end(args);
    NORETURN_FUNCTION_END;
}
MSVC_DIAG_RESTORE

#endif /* PERL_IMPLICIT_CONTEXT */

/* silence __declspec(noreturn) warnings */
MSVC_DIAG_IGNORE(4646 4645)
OP *
Perl_die(pTHX_ const char* pat, ...)
{
    va_list args;
    va_start(args, pat);
    vcroak(pat, &args);
    NOT_REACHED; /* NOTREACHED */
    va_end(args);
    NORETURN_FUNCTION_END;
}
MSVC_DIAG_RESTORE

/*
=for apidoc croak_sv

This is an XS interface to Perl's C<die> function.

C<baseex> is the error message or object.  If it is a reference, it
will be used as-is.  Otherwise it is used as a string, and if it does
not end with a newline then it will be extended with some indication of
the current location in the code, as described for L</mess_sv>.

The error message or object will be used as an exception, by default
returning control to the nearest enclosing C<eval>, but subject to
modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
function never returns normally.

To die with a simple string message, the L</croak> function may be
more convenient.

=cut
*/

void
Perl_croak_sv(pTHX_ SV *baseex)
{
    SV *ex = with_queued_errors(mess_sv(baseex, 0));
    PERL_ARGS_ASSERT_CROAK_SV;
    invoke_exception_hook(ex, FALSE);
    die_unwind(ex);
}

/*
=for apidoc vcroak

This is an XS interface to Perl's C<die> function.

C<pat> and C<args> are a sprintf-style format pattern and encapsulated
argument list.  These are used to generate a string message.  If the
message does not end with a newline, then it will be extended with
some indication of the current location in the code, as described for
L</mess_sv>.

The error message will be used as an exception, by default
returning control to the nearest enclosing C<eval>, but subject to
modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
function never returns normally.

For historical reasons, if C<pat> is null then the contents of C<ERRSV>
(C<$@>) will be used as an error message or object instead of building an
error message from arguments.  If you want to throw a non-string object,
or build an error message in an SV yourself, it is preferable to use
the L</croak_sv> function, which does not involve clobbering C<ERRSV>.

=cut
*/

void
Perl_vcroak(pTHX_ const char* pat, va_list *args)
{
    SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
    invoke_exception_hook(ex, FALSE);
    die_unwind(ex);
}

/*
=for apidoc croak
=for apidoc_item croak_nocontext

These are XS interfaces to Perl's C<die> function.

They take a sprintf-style format pattern and argument list, which are used to
generate a string message.  If the message does not end with a newline, then it
will be extended with some indication of the current location in the code, as
described for C<L</mess_sv>>.

The error message will be used as an exception, by default
returning control to the nearest enclosing C<eval>, but subject to
modification by a C<$SIG{__DIE__}> handler.  In any case, these croak
functions never return normally.

For historical reasons, if C<pat> is null then the contents of C<ERRSV>
(C<$@>) will be used as an error message or object instead of building an
error message from arguments.  If you want to throw a non-string object,
or build an error message in an SV yourself, it is preferable to use
the C<L</croak_sv>> function, which does not involve clobbering C<ERRSV>.

The two forms differ only in that C<croak_nocontext> does not take a thread
context (C<aTHX>) parameter.  It is usually preferred as it takes up fewer
bytes of code than plain C<Perl_croak>, and time is rarely a critical resource
when you are about to throw an exception.

=cut
*/

#if defined(PERL_IMPLICIT_CONTEXT)
void
Perl_croak_nocontext(const char *pat, ...)
{
    dTHX;
    va_list args;
    va_start(args, pat);
    vcroak(pat, &args);
    NOT_REACHED; /* NOTREACHED */
    va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */

/* saves machine code for a common noreturn idiom typically used in Newx*() */
GCC_DIAG_IGNORE_DECL(-Wunused-function);
void
Perl_croak_memory_wrap(void)
{
    Perl_croak_nocontext("%s",PL_memory_wrap);
}
GCC_DIAG_RESTORE_DECL;

void
Perl_croak(pTHX_ const char *pat, ...)
{
    va_list args;
    va_start(args, pat);
    vcroak(pat, &args);
    NOT_REACHED; /* NOTREACHED */
    va_end(args);
}

/*
=for apidoc croak_no_modify

This encapsulates a common reason for dying, generating terser object code than
using the generic C<Perl_croak>.  It is exactly equivalent to
C<Perl_croak(aTHX_ "%s", PL_no_modify)> (which expands to something like
"Modification of a read-only value attempted").

Less code used on exception code paths reduces CPU cache pressure.

=cut
*/

void
Perl_croak_no_modify(void)
{
    Perl_croak_nocontext( "%s", PL_no_modify);
}

/* does not return, used in util.c perlio.c and win32.c
   This is typically called when malloc returns NULL.
*/
void
Perl_croak_no_mem(void)
{
    dTHX;

    int fd = PerlIO_fileno(Perl_error_log);
    if (fd < 0)
        SETERRNO(EBADF,RMS_IFI);
    else {
        /* Can't use PerlIO to write as it allocates memory */
        PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
    }
    my_exit(1);
}

/* does not return, used only in POPSTACK */
void
Perl_croak_popstack(void)
{
    dTHX;
    PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
    my_exit(1);
}

/*
=for apidoc warn_sv

This is an XS interface to Perl's C<warn> function.

C<baseex> is the error message or object.  If it is a reference, it
will be used as-is.  Otherwise it is used as a string, and if it does
not end with a newline then it will be extended with some indication of
the current location in the code, as described for L</mess_sv>.

The error message or object will by default be written to standard error,
but this is subject to modification by a C<$SIG{__WARN__}> handler.

To warn with a simple string message, the L</warn> function may be
more convenient.

=cut
*/

void
Perl_warn_sv(pTHX_ SV *baseex)
{
    SV *ex = mess_sv(baseex, 0);
    PERL_ARGS_ASSERT_WARN_SV;
    if (!invoke_exception_hook(ex, TRUE))
	write_to_stderr(ex);
}

/*
=for apidoc vwarn

This is an XS interface to Perl's C<warn> function.

This is like C<L</warn>>, but C<args> are an encapsulated
argument list.

Unlike with L</vcroak>, C<pat> is not permitted to be null.

=cut
*/

void
Perl_vwarn(pTHX_ const char* pat, va_list *args)
{
    SV *ex = vmess(pat, args);
    PERL_ARGS_ASSERT_VWARN;
    if (!invoke_exception_hook(ex, TRUE))
	write_to_stderr(ex);
}

/*
=for apidoc warn
=for apidoc_item warn_nocontext

These are XS interfaces to Perl's C<warn> function.

They take a sprintf-style format pattern and argument list, which  are used to
generate a string message.  If the message does not end with a newline, then it
will be extended with some indication of the current location in the code, as
described for C<L</mess_sv>>.

The error message or object will by default be written to standard error,
but this is subject to modification by a C<$SIG{__WARN__}> handler.

Unlike with C<L</croak>>, C<pat> is not permitted to be null.

The two forms differ only in that C<warn_nocontext> does not take a thread
context (C<aTHX>) parameter, so is used in situations where the caller doesn't
already have the thread context.

=cut
*/

#if defined(PERL_IMPLICIT_CONTEXT)
void
Perl_warn_nocontext(const char *pat, ...)
{
    dTHX;
    va_list args;
    PERL_ARGS_ASSERT_WARN_NOCONTEXT;
    va_start(args, pat);
    vwarn(pat, &args);
    va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */

void
Perl_warn(pTHX_ const char *pat, ...)
{
    va_list args;
    PERL_ARGS_ASSERT_WARN;
    va_start(args, pat);
    vwarn(pat, &args);
    va_end(args);
}

/*
=for apidoc warner
=for apidoc_item warner_nocontext

These output a warning of the specified category (or categories) given by
C<err>, using the sprintf-style format pattern C<pat>, and argument list.

C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
C<packWARN4> macros populated with the appropriate number of warning
categories.  If any of the warning categories they specify is fatal, a fatal
exception is thrown.

In any event a message is generated by the pattern and arguments.  If the
message does not end with a newline, then it will be extended with some
indication of the current location in the code, as described for L</mess_sv>.

The error message or object will by default be written to standard error,
but this is subject to modification by a C<$SIG{__WARN__}> handler.

C<pat> is not permitted to be null.

The two forms differ only in that C<warner_nocontext> does not take a thread
context (C<aTHX>) parameter, so is used in situations where the caller doesn't
already have the thread context.

These functions differ from the similarly named C<L</warn>> functions, in that
the latter are for XS code to unconditionally display a warning, whereas these
are for code that may be compiling a perl program, and does extra checking to
see if the warning should be fatal.

=for apidoc ck_warner
=for apidoc_item ck_warner_d
If none of the warning categories given by C<err> are enabled, do nothing;
otherwise call C<L</warner>>  or C<L</warner_nocontext>> with the passed-in
parameters;.

C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
C<packWARN4> macros populated with the appropriate number of warning
categories.

The two forms differ only in that C<ck_warner_d> should be used if warnings for
any of the categories are by default enabled.

=for apidoc vwarner
This is like C<L</warner>>, but C<args> are an encapsulated argument list.

=cut
*/

#if defined(PERL_IMPLICIT_CONTEXT)
void
Perl_warner_nocontext(U32 err, const char *pat, ...)
{
    dTHX; 
    va_list args;
    PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
    va_start(args, pat);
    vwarner(err, pat, &args);
    va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */

void
Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
{
    PERL_ARGS_ASSERT_CK_WARNER_D;

    if (Perl_ckwarn_d(aTHX_ err)) {
	va_list args;
	va_start(args, pat);
	vwarner(err, pat, &args);
	va_end(args);
    }
}

void
Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
{
    PERL_ARGS_ASSERT_CK_WARNER;

    if (Perl_ckwarn(aTHX_ err)) {
	va_list args;
	va_start(args, pat);
	vwarner(err, pat, &args);
	va_end(args);
    }
}

void
Perl_warner(pTHX_ U32  err, const char* pat,...)
{
    va_list args;
    PERL_ARGS_ASSERT_WARNER;
    va_start(args, pat);
    vwarner(err, pat, &args);
    va_end(args);
}

void
Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
{
    PERL_ARGS_ASSERT_VWARNER;
    if (
        (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
        !(PL_in_eval & EVAL_KEEPERR)
    ) {
	SV * const msv = vmess(pat, args);

	if (PL_parser && PL_parser->error_count) {
	    qerror(msv);
	}
	else {
	    invoke_exception_hook(msv, FALSE);
	    die_unwind(msv);
	}
    }
    else {
	Perl_vwarn(aTHX_ pat, args);
    }
}

/* implements the ckWARN? macros */

bool
Perl_ckwarn(pTHX_ U32 w)
{
    /* If lexical warnings have not been set, use $^W.  */
    if (isLEXWARN_off)
	return PL_dowarn & G_WARN_ON;

    return ckwarn_common(w);
}

/* implements the ckWARN?_d macro */

bool
Perl_ckwarn_d(pTHX_ U32 w)
{
    /* If lexical warnings have not been set then default classes warn.  */
    if (isLEXWARN_off)
	return TRUE;

    return ckwarn_common(w);
}

static bool
S_ckwarn_common(pTHX_ U32 w)
{
    if (PL_curcop->cop_warnings == pWARN_ALL)
	return TRUE;

    if (PL_curcop->cop_warnings == pWARN_NONE)
	return FALSE;

    /* Check the assumption that at least the first slot is non-zero.  */
    assert(unpackWARN1(w));

    /* Check the assumption that it is valid to stop as soon as a zero slot is
       seen.  */
    if (!unpackWARN2(w)) {
	assert(!unpackWARN3(w));
	assert(!unpackWARN4(w));
    } else if (!unpackWARN3(w)) {
	assert(!unpackWARN4(w));
    }
	
    /* Right, dealt with all the special cases, which are implemented as non-
       pointers, so there is a pointer to a real warnings mask.  */
    do {
	if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
	    return TRUE;
    } while (w >>= WARNshift);

    return FALSE;
}

/* Set buffer=NULL to get a new one.  */
STRLEN *
Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
			   STRLEN size) {
    const MEM_SIZE len_wanted =
	sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
    PERL_UNUSED_CONTEXT;
    PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;

    buffer = (STRLEN*)
	(specialWARN(buffer) ?
	 PerlMemShared_malloc(len_wanted) :
	 PerlMemShared_realloc(buffer, len_wanted));
    buffer[0] = size;
    Copy(bits, (buffer + 1), size, char);
    if (size < WARNsize)
	Zero((char *)(buffer + 1) + size, WARNsize - size, char);
    return buffer;
}

/* since we've already done strlen() for both nam and val
 * we can use that info to make things faster than
 * sprintf(s, "%s=%s", nam, val)
 */
#define my_setenv_format(s, nam, nlen, val, vlen) \
   Copy(nam, s, nlen, char); \
   *(s+nlen) = '='; \
   Copy(val, s+(nlen+1), vlen, char); \
   *(s+(nlen+1+vlen)) = '\0'



#ifdef USE_ENVIRON_ARRAY
/* NB: VMS' my_setenv() is in vms.c */

/* Configure doesn't test for HAS_SETENV yet, so decide based on platform.
 * For Solaris, setenv() and unsetenv() were introduced in Solaris 9, so
 * testing for HAS UNSETENV is sufficient.
 */
#  if defined(__CYGWIN__)|| defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
#    define MY_HAS_SETENV
#  endif

/* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if
 * 'current' is non-null, with up to three sizes that are added together.
 * It handles integer overflow.
 */
#  ifndef MY_HAS_SETENV
static char *
S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
{
    void *p;
    Size_t sl, l = l1 + l2;

    if (l < l2)
        goto panic;
    l += l3;
    if (l < l3)
        goto panic;
    sl = l * size;
    if (sl < l)
        goto panic;

    p = current
            ? safesysrealloc(current, sl)
            : safesysmalloc(sl);
    if (p)
        return (char*)p;

  panic:
    croak_memory_wrap();
}
#  endif


#  if !defined(WIN32) && !defined(NETWARE)

/*
=for apidoc_section Utility Functions
=for apidoc my_setenv

A wrapper for the C library L<setenv(3)>.  Don't use the latter, as the perl
version has desirable safeguards

=cut
*/

void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
#    ifdef __amigaos4__
  amigaos4_obtain_environ(__FUNCTION__);
#    endif

#    ifdef USE_ITHREADS
  /* only parent thread can modify process environment, so no need to use a
   * mutex */
  if (PL_curinterp == aTHX)
#    endif
  {

#    ifndef PERL_USE_SAFE_PUTENV
    if (!PL_use_safe_putenv) {
        /* most putenv()s leak, so we manipulate environ directly */
        UV i;
        Size_t vlen, nlen = strlen(nam);

        /* where does it go? */
        for (i = 0; environ[i]; i++) {
            if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
                break;
        }

        if (environ == PL_origenviron) {   /* need we copy environment? */
            UV j, max;
            char **tmpenv;

            max = i;
            while (environ[max])
                max++;

            /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */
            tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*));

            for (j=0; j<max; j++) {         /* copy environment */
                const Size_t len = strlen(environ[j]);
                tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
                Copy(environ[j], tmpenv[j], len+1, char);
            }

            tmpenv[max] = NULL;
            environ = tmpenv;               /* tell exec where it is now */
        }

        if (!val) {
            safesysfree(environ[i]);
            while (environ[i]) {
                environ[i] = environ[i+1];
                i++;
            }
#      ifdef __amigaos4__
            goto my_setenv_out;
#      else
            return;
#      endif
        }

        if (!environ[i]) {                 /* does not exist yet */
            environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
            environ[i+1] = NULL;    /* make sure it's null terminated */
        }
        else
            safesysfree(environ[i]);

        vlen = strlen(val);

        environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
        /* all that work just for this */
        my_setenv_format(environ[i], nam, nlen, val, vlen);
    }
    else {

#    endif /* !PERL_USE_SAFE_PUTENV */

#    ifdef MY_HAS_SETENV
#      if defined(HAS_UNSETENV)
        if (val == NULL) {
            (void)unsetenv(nam);
        } else {
            (void)setenv(nam, val, 1);
        }
#      else /* ! HAS_UNSETENV */
        (void)setenv(nam, val, 1);
#      endif /* HAS_UNSETENV */

#    elif defined(HAS_UNSETENV)

        if (val == NULL) {
            if (environ) /* old glibc can crash with null environ */
                (void)unsetenv(nam);
        } else {
	    const Size_t nlen = strlen(nam);
	    const Size_t vlen = strlen(val);
	    char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
            my_setenv_format(new_env, nam, nlen, val, vlen);
            (void)putenv(new_env);
        }

#    else /* ! HAS_UNSETENV */

        char *new_env;
	const Size_t nlen = strlen(nam);
	Size_t vlen;
        if (!val) {
	   val = "";
        }
        vlen = strlen(val);
        new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
        /* all that work just for this */
        my_setenv_format(new_env, nam, nlen, val, vlen);
        (void)putenv(new_env);

#    endif /* MY_HAS_SETENV */

#    ifndef PERL_USE_SAFE_PUTENV
    }
#    endif
  }

#    ifdef __amigaos4__
my_setenv_out:
  amigaos4_release_environ(__FUNCTION__);
#    endif
}

#  else /* WIN32 || NETWARE */

void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
    char *envstr;
    const Size_t nlen = strlen(nam);
    Size_t vlen;

    if (!val) {
       val = "";
    }
    vlen = strlen(val);
    envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
    my_setenv_format(envstr, nam, nlen, val, vlen);
    (void)PerlEnv_putenv(envstr);
    safesysfree(envstr);
}

#  endif /* WIN32 || NETWARE */

#endif /* USE_ENVIRON_ARRAY */




#ifdef UNLINK_ALL_VERSIONS
I32
Perl_unlnk(pTHX_ const char *f)	/* unlink all versions of a file */
{
    I32 retries = 0;

    PERL_ARGS_ASSERT_UNLNK;

    while (PerlLIO_unlink(f) >= 0)
	retries++;
    return retries ? 0 : -1;
}
#endif

PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
    int p[2];
    I32 This, that;
    Pid_t pid;
    SV *sv;
    I32 did_pipes = 0;
    int pp[2];

    PERL_ARGS_ASSERT_MY_POPEN_LIST;

    PERL_FLUSHALL_FOR_CHILD;
    This = (*mode == 'w');
    that = !This;
    if (TAINTING_get) {
	taint_env();
	taint_proper("Insecure %s%s", "EXEC");
    }
    if (PerlProc_pipe_cloexec(p) < 0)
	return NULL;
    /* Try for another pipe pair for error return */
    if (PerlProc_pipe_cloexec(pp) >= 0)
	did_pipes = 1;
    while ((pid = PerlProc_fork()) < 0) {
	if (errno != EAGAIN) {
	    PerlLIO_close(p[This]);
	    PerlLIO_close(p[that]);
	    if (did_pipes) {
		PerlLIO_close(pp[0]);
		PerlLIO_close(pp[1]);
	    }
	    return NULL;
	}
	Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
	sleep(5);
    }
    if (pid == 0) {
	/* Child */
#undef THIS
#undef THAT
#define THIS that
#define THAT This
	/* Close parent's end of error status pipe (if any) */
	if (did_pipes)
	    PerlLIO_close(pp[0]);
	/* Now dup our end of _the_ pipe to right position */
	if (p[THIS] != (*mode == 'r')) {
	    PerlLIO_dup2(p[THIS], *mode == 'r');
	    PerlLIO_close(p[THIS]);
	    if (p[THAT] != (*mode == 'r'))	/* if dup2() didn't close it */
		PerlLIO_close(p[THAT]);	/* close parent's end of _the_ pipe */
	}
	else {
	    setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
	    PerlLIO_close(p[THAT]);	/* close parent's end of _the_ pipe */
        }
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
	/* No automatic close - do it by hand */
#  ifndef NOFILE
#  define NOFILE 20
#  endif
	{
	    int fd;

	    for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
		if (fd != pp[1])
		    PerlLIO_close(fd);
	    }
	}
#endif
	do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
	PerlProc__exit(1);
#undef THIS
#undef THAT
    }
    /* Parent */
    if (did_pipes)
	PerlLIO_close(pp[1]);
    /* Keep the lower of the two fd numbers */
    if (p[that] < p[This]) {
	PerlLIO_dup2_cloexec(p[This], p[that]);
	PerlLIO_close(p[This]);
	p[This] = p[that];
    }
    else
	PerlLIO_close(p[that]);		/* close child's end of pipe */

    sv = *av_fetch(PL_fdpid,p[This],TRUE);
    SvUPGRADE(sv,SVt_IV);
    SvIV_set(sv, pid);
    PL_forkprocess = pid;
    /* If we managed to get status pipe check for exec fail */
    if (did_pipes && pid > 0) {
	int errkid;
	unsigned read_total = 0;

	while (read_total < sizeof(int)) {
            const SSize_t n1 = PerlLIO_read(pp[0],
			      (void*)(((char*)&errkid)+read_total),
			      (sizeof(int)) - read_total);
	    if (n1 <= 0)
		break;
	    read_total += n1;
	}
	PerlLIO_close(pp[0]);
	did_pipes = 0;
	if (read_total) {			/* Error */
	    int pid2, status;
	    PerlLIO_close(p[This]);
	    if (read_total != sizeof(int))
		Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total);
	    do {
		pid2 = wait4pid(pid, &status, 0);
	    } while (pid2 == -1 && errno == EINTR);
	    errno = errkid;		/* Propagate errno from kid */
	    return NULL;
	}
    }
    if (did_pipes)
	 PerlLIO_close(pp[0]);
    return PerlIO_fdopen(p[This], mode);
#else
#  if defined(OS2)	/* Same, without fork()ing and all extra overhead... */
    return my_syspopen4(aTHX_ NULL, mode, n, args);
#  elif defined(WIN32)
    return win32_popenlist(mode, n, args);
#  else
    Perl_croak(aTHX_ "List form of piped open not implemented");
    return (PerlIO *) NULL;
#  endif
#endif
}

    /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
    int p[2];
    I32 This, that;
    Pid_t pid;
    SV *sv;
    const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
    I32 did_pipes = 0;
    int pp[2];

    PERL_ARGS_ASSERT_MY_POPEN;

    PERL_FLUSHALL_FOR_CHILD;
#ifdef OS2
    if (doexec) {
	return my_syspopen(aTHX_ cmd,mode);
    }
#endif
    This = (*mode == 'w');
    that = !This;
    if (doexec && TAINTING_get) {
	taint_env();
	taint_proper("Insecure %s%s", "EXEC");
    }
    if (PerlProc_pipe_cloexec(p) < 0)
	return NULL;
    if (doexec && PerlProc_pipe_cloexec(pp) >= 0)
	did_pipes = 1;
    while ((pid = PerlProc_fork()) < 0) {
	if (errno != EAGAIN) {
	    PerlLIO_close(p[This]);
	    PerlLIO_close(p[that]);
	    if (did_pipes) {
		PerlLIO_close(pp[0]);
		PerlLIO_close(pp[1]);
	    }
	    if (!doexec)
		Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
	    return NULL;
	}
	Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
	sleep(5);
    }
    if (pid == 0) {

#undef THIS
#undef THAT
#define THIS that
#define THAT This
	if (did_pipes)
	    PerlLIO_close(pp[0]);
	if (p[THIS] != (*mode == 'r')) {
	    PerlLIO_dup2(p[THIS], *mode == 'r');
	    PerlLIO_close(p[THIS]);
	    if (p[THAT] != (*mode == 'r'))	/* if dup2() didn't close it */
		PerlLIO_close(p[THAT]);
	}
	else {
	    setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
	    PerlLIO_close(p[THAT]);
	}
#ifndef OS2
	if (doexec) {
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
#ifndef NOFILE
#define NOFILE 20
#endif
	    {
		int fd;

		for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
		    if (fd != pp[1])
			PerlLIO_close(fd);
	    }
#endif
	    /* may or may not use the shell */
	    do_exec3(cmd, pp[1], did_pipes);
	    PerlProc__exit(1);
	}
#endif	/* defined OS2 */

#ifdef PERLIO_USING_CRLF
   /* Since we circumvent IO layers when we manipulate low-level
      filedescriptors directly, need to manually switch to the
      default, binary, low-level mode; see PerlIOBuf_open(). */
   PerlLIO_setmode((*mode == 'r'), O_BINARY);
#endif 
	PL_forkprocess = 0;
#ifdef PERL_USES_PL_PIDSTATUS
	hv_clear(PL_pidstatus);	/* we have no children */
#endif
	return NULL;
#undef THIS
#undef THAT
    }
    if (did_pipes)
	PerlLIO_close(pp[1]);
    if (p[that] < p[This]) {
	PerlLIO_dup2_cloexec(p[This], p[that]);
	PerlLIO_close(p[This]);
	p[This] = p[that];
    }
    else
	PerlLIO_close(p[that]);

    sv = *av_fetch(PL_fdpid,p[This],TRUE);
    SvUPGRADE(sv,SVt_IV);
    SvIV_set(sv, pid);
    PL_forkprocess = pid;
    if (did_pipes && pid > 0) {
	int errkid;
	unsigned n = 0;

	while (n < sizeof(int)) {
            const SSize_t n1 = PerlLIO_read(pp[0],
			      (void*)(((char*)&errkid)+n),
			      (sizeof(int)) - n);
	    if (n1 <= 0)
		break;
	    n += n1;
	}
	PerlLIO_close(pp[0]);
	did_pipes = 0;
	if (n) {			/* Error */
	    int pid2, status;
	    PerlLIO_close(p[This]);
	    if (n != sizeof(int))
		Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
	    do {
		pid2 = wait4pid(pid, &status, 0);
	    } while (pid2 == -1 && errno == EINTR);
	    errno = errkid;		/* Propagate errno from kid */
	    return NULL;
	}
    }
    if (did_pipes)
	 PerlLIO_close(pp[0]);
    return PerlIO_fdopen(p[This], mode);
}
#elif defined(DJGPP)
FILE *djgpp_popen();
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
    PERL_FLUSHALL_FOR_CHILD;
    /* Call system's popen() to get a FILE *, then import it.
       used 0 for 2nd parameter to PerlIO_importFILE;
       apparently not used
    */
    return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
}
#elif defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
    return NULL;
}

#endif /* !DOSISH */

/* this is called in parent before the fork() */
void
Perl_atfork_lock(void)
#if defined(USE_ITHREADS)
#  ifdef USE_PERLIO
  PERL_TSA_ACQUIRE(PL_perlio_mutex)
#  endif
#  ifdef MYMALLOC
  PERL_TSA_ACQUIRE(PL_malloc_mutex)
#  endif
  PERL_TSA_ACQUIRE(PL_op_mutex)
#endif
{
#if defined(USE_ITHREADS)
    /* locks must be held in locking order (if any) */
#  ifdef USE_PERLIO
    MUTEX_LOCK(&PL_perlio_mutex);
#  endif
#  ifdef MYMALLOC
    MUTEX_LOCK(&PL_malloc_mutex);
#  endif
    OP_REFCNT_LOCK;
#endif
}

/* this is called in both parent and child after the fork() */
void
Perl_atfork_unlock(void)
#if defined(USE_ITHREADS)
#  ifdef USE_PERLIO
  PERL_TSA_RELEASE(PL_perlio_mutex)
#  endif
#  ifdef MYMALLOC
  PERL_TSA_RELEASE(PL_malloc_mutex)
#  endif
  PERL_TSA_RELEASE(PL_op_mutex)
#endif
{
#if defined(USE_ITHREADS)
    /* locks must be released in same order as in atfork_lock() */
#  ifdef USE_PERLIO
    MUTEX_UNLOCK(&PL_perlio_mutex);
#  endif
#  ifdef MYMALLOC
    MUTEX_UNLOCK(&PL_malloc_mutex);
#  endif
    OP_REFCNT_UNLOCK;
#endif
}

Pid_t
Perl_my_fork(void)
{
#if defined(HAS_FORK)
    Pid_t pid;
#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
    atfork_lock();
    pid = fork();
    atfork_unlock();
#else
    /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
     * handlers elsewhere in the code */
    pid = fork();
#endif
    return pid;
#elif defined(__amigaos4__)
    return amigaos_fork();
#else
    /* this "canna happen" since nothing should be calling here if !HAS_FORK */
    Perl_croak_nocontext("fork() not available");
    return 0;
#endif /* HAS_FORK */
}

#ifndef HAS_DUP2
int
dup2(int oldfd, int newfd)
{
#if defined(HAS_FCNTL) && defined(F_DUPFD)
    if (oldfd == newfd)
	return oldfd;
    PerlLIO_close(newfd);
    return fcntl(oldfd, F_DUPFD, newfd);
#else
#define DUP2_MAX_FDS 256
    int fdtmp[DUP2_MAX_FDS];
    I32 fdx = 0;
    int fd;

    if (oldfd == newfd)
	return oldfd;
    PerlLIO_close(newfd);
    /* good enough for low fd's... */
    while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
	if (fdx >= DUP2_MAX_FDS) {
	    PerlLIO_close(fd);
	    fd = -1;
	    break;
	}
	fdtmp[fdx++] = fd;
    }
    while (fdx > 0)
	PerlLIO_close(fdtmp[--fdx]);
    return fd;
#endif
}
#endif

#ifndef PERL_MICRO
#ifdef HAS_SIGACTION

/*
=for apidoc_section Signals
=for apidoc rsignal

A wrapper for the C library L<signal(2)>.  Don't use the latter, as the Perl
version knows things that interact with the rest of the perl interpreter.

=cut
*/

Sighandler_t
Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
{
    struct sigaction act, oact;

#ifdef USE_ITHREADS
    /* only "parent" interpreter can diddle signals */
    if (PL_curinterp != aTHX)
	return (Sighandler_t) SIG_ERR;
#endif

    act.sa_handler = handler;
    sigemptyset(&act.sa_mask);
    act.sa_flags = 0;
#ifdef SA_RESTART
    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
        act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
#endif
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
    if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
	act.sa_flags |= SA_NOCLDWAIT;
#endif
    if (sigaction(signo, &act, &oact) == -1)
    	return (Sighandler_t) SIG_ERR;
    else
    	return (Sighandler_t) oact.sa_handler;
}

Sighandler_t
Perl_rsignal_state(pTHX_ int signo)
{
    struct sigaction oact;
    PERL_UNUSED_CONTEXT;

    if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
	return (Sighandler_t) SIG_ERR;
    else
	return (Sighandler_t) oact.sa_handler;
}

int
Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
{
#ifdef USE_ITHREADS
#endif
    struct sigaction act;

    PERL_ARGS_ASSERT_RSIGNAL_SAVE;

#ifdef USE_ITHREADS
    /* only "parent" interpreter can diddle signals */
    if (PL_curinterp != aTHX)
	return -1;
#endif

    act.sa_handler = handler;
    sigemptyset(&act.sa_mask);
    act.sa_flags = 0;
#ifdef SA_RESTART
    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
        act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
#endif
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
    if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
	act.sa_flags |= SA_NOCLDWAIT;
#endif
    return sigaction(signo, &act, save);
}

int
Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
{
#ifdef USE_ITHREADS
#endif
    PERL_UNUSED_CONTEXT;
#ifdef USE_ITHREADS
    /* only "parent" interpreter can diddle signals */
    if (PL_curinterp != aTHX)
	return -1;
#endif

    return sigaction(signo, save, (struct sigaction *)NULL);
}

#else /* !HAS_SIGACTION */

Sighandler_t
Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
{
#if defined(USE_ITHREADS) && !defined(WIN32)
    /* only "parent" interpreter can diddle signals */
    if (PL_curinterp != aTHX)
	return (Sighandler_t) SIG_ERR;
#endif

    return PerlProc_signal(signo, handler);
}

static Signal_t
sig_trap(int signo)
{
    PL_sig_trapped++;
}

Sighandler_t
Perl_rsignal_state(pTHX_ int signo)
{
    Sighandler_t oldsig;

#if defined(USE_ITHREADS) && !defined(WIN32)
    /* only "parent" interpreter can diddle signals */
    if (PL_curinterp != aTHX)
	return (Sighandler_t) SIG_ERR;
#endif

    PL_sig_trapped = 0;
    oldsig = PerlProc_signal(signo, sig_trap);
    PerlProc_signal(signo, oldsig);
    if (PL_sig_trapped)
	PerlProc_kill(PerlProc_getpid(), signo);
    return oldsig;
}

int
Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
{
#if defined(USE_ITHREADS) && !defined(WIN32)
    /* only "parent" interpreter can diddle signals */
    if (PL_curinterp != aTHX)
	return -1;
#endif
    *save = PerlProc_signal(signo, handler);
    return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
}

int
Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
{
#if defined(USE_ITHREADS) && !defined(WIN32)
    /* only "parent" interpreter can diddle signals */
    if (PL_curinterp != aTHX)
	return -1;
#endif
    return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
}

#endif /* !HAS_SIGACTION */
#endif /* !PERL_MICRO */

    /* VMS' my_pclose() is in VMS.c; same with OS/2 */
#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
    int status;
    SV **svp;
    Pid_t pid;
    Pid_t pid2 = 0;
    bool close_failed;
    dSAVEDERRNO;
    const int fd = PerlIO_fileno(ptr);
    bool should_wait;

    svp = av_fetch(PL_fdpid,fd,TRUE);
    pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
    SvREFCNT_dec(*svp);
    *svp = NULL;

#if defined(USE_PERLIO)
    /* Find out whether the refcount is low enough for us to wait for the
       child proc without blocking. */
    should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
#else
    should_wait = pid > 0;
#endif

#ifdef OS2
    if (pid == -1) {			/* Opened by popen. */
	return my_syspclose(ptr);
    }
#endif
    close_failed = (PerlIO_close(ptr) == EOF);
    SAVE_ERRNO;
    if (should_wait) do {
	pid2 = wait4pid(pid, &status, 0);
    } while (pid2 == -1 && errno == EINTR);
    if (close_failed) {
	RESTORE_ERRNO;
	return -1;
    }
    return(
      should_wait
       ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
       : 0
    );
}
#elif defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
    return -1;
}
#endif /* !DOSISH */

#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
    I32 result = 0;
    PERL_ARGS_ASSERT_WAIT4PID;
#ifdef PERL_USES_PL_PIDSTATUS
    if (!pid) {
        /* PERL_USES_PL_PIDSTATUS is only defined when neither
           waitpid() nor wait4() is available, or on OS/2, which
           doesn't appear to support waiting for a progress group
           member, so we can only treat a 0 pid as an unknown child.
        */
        errno = ECHILD;
        return -1;
    }
    {
	if (pid > 0) {
	    /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
	       pid, rather than a string form.  */
	    SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
	    if (svp && *svp != &PL_sv_undef) {
		*statusp = SvIVX(*svp);
		(void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
				G_DISCARD);
		return pid;
	    }
	}
	else {
	    HE *entry;

	    hv_iterinit(PL_pidstatus);
	    if ((entry = hv_iternext(PL_pidstatus))) {
		SV * const sv = hv_iterval(PL_pidstatus,entry);
		I32 len;
		const char * const spid = hv_iterkey(entry,&len);

		assert (len == sizeof(Pid_t));
		memcpy((char *)&pid, spid, len);
		*statusp = SvIVX(sv);
		/* The hash iterator is currently on this entry, so simply
		   calling hv_delete would trigger the lazy delete, which on
		   aggregate does more work, because next call to hv_iterinit()
		   would spot the flag, and have to call the delete routine,
		   while in the meantime any new entries can't re-use that
		   memory.  */
		hv_iterinit(PL_pidstatus);
		(void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
		return pid;
	    }
	}
    }
#endif
#ifdef HAS_WAITPID
#  ifdef HAS_WAITPID_RUNTIME
    if (!HAS_WAITPID_RUNTIME)
	goto hard_way;
#  endif
    result = PerlProc_waitpid(pid,statusp,flags);
    goto finish;
#endif
#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
    result = wait4(pid,statusp,flags,NULL);
    goto finish;
#endif
#ifdef PERL_USES_PL_PIDSTATUS
#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
  hard_way:
#endif
    {
	if (flags)
	    Perl_croak(aTHX_ "Can't do waitpid with flags");
	else {
	    while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
		pidgone(result,*statusp);
	    if (result < 0)
		*statusp = -1;
	}
    }
#endif
#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
  finish:
#endif
    if (result < 0 && errno == EINTR) {
	PERL_ASYNC_CHECK();
	errno = EINTR; /* reset in case a signal handler changed $! */
    }
    return result;
}
#endif /* !DOSISH || OS2 || WIN32 || NETWARE */

#ifdef PERL_USES_PL_PIDSTATUS
void
S_pidgone(pTHX_ Pid_t pid, int status)
{
    SV *sv;

    sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
    SvUPGRADE(sv,SVt_IV);
    SvIV_set(sv, status);
    return;
}
#endif

#if defined(OS2)
int pclose();
#ifdef HAS_FORK
int					/* Cannot prototype with I32
					   in os2ish.h. */
my_syspclose(PerlIO *ptr)
#else
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
#endif
{
    /* Needs work for PerlIO ! */
    FILE * const f = PerlIO_findFILE(ptr);
    const I32 result = pclose(f);
    PerlIO_releaseFILE(ptr,f);
    return result;
}
#endif

#if defined(DJGPP)
int djgpp_pclose();
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
    /* Needs work for PerlIO ! */
    FILE * const f = PerlIO_findFILE(ptr);
    I32 result = djgpp_pclose(f);
    result = (result << 8) & 0xff00;
    PerlIO_releaseFILE(ptr,f);
    return result;
}
#endif

#define PERL_REPEATCPY_LINEAR 4
void
Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
{
    PERL_ARGS_ASSERT_REPEATCPY;

    assert(len >= 0);

    if (count < 0)
	croak_memory_wrap();

    if (len == 1)
	memset(to, *from, count);
    else if (count) {
	char *p = to;
	IV items, linear, half;

	linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
	for (items = 0; items < linear; ++items) {
	    const char *q = from;
	    IV todo;
	    for (todo = len; todo > 0; todo--)
		*p++ = *q++;
        }

	half = count / 2;
	while (items <= half) {
	    IV size = items * len;
	    memcpy(p, to, size);
	    p     += size;
	    items *= 2;
	}

	if (count > items)
	    memcpy(p, to, (count - items) * len);
    }
}

#ifndef HAS_RENAME
I32
Perl_same_dirent(pTHX_ const char *a, const char *b)
{
    char *fa = strrchr(a,'/');
    char *fb = strrchr(b,'/');
    Stat_t tmpstatbuf1;
    Stat_t tmpstatbuf2;
    SV * const tmpsv = sv_newmortal();

    PERL_ARGS_ASSERT_SAME_DIRENT;

    if (fa)
	fa++;
    else
	fa = a;
    if (fb)
	fb++;
    else
	fb = b;
    if (strNE(a,b))
	return FALSE;
    if (fa == a)
	sv_setpvs(tmpsv, ".");
    else
	sv_setpvn(tmpsv, a, fa - a);
    if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
	return FALSE;
    if (fb == b)
	sv_setpvs(tmpsv, ".");
    else
	sv_setpvn(tmpsv, b, fb - b);
    if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
	return FALSE;
    return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
	   tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
}
#endif /* !HAS_RENAME */

char*
Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
		 const char *const *const search_ext, I32 flags)
{
    const char *xfound = NULL;
    char *xfailed = NULL;
    char tmpbuf[MAXPATHLEN];
    char *s;
    I32 len = 0;
    int retval;
    char *bufend;
#if defined(DOSISH) && !defined(OS2)
#  define SEARCH_EXTS ".bat", ".cmd", NULL
#  define MAX_EXT_LEN 4
#endif
#ifdef OS2
#  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
#  define MAX_EXT_LEN 4
#endif
#ifdef VMS
#  define SEARCH_EXTS ".pl", ".com", NULL
#  define MAX_EXT_LEN 4
#endif
    /* additional extensions to try in each dir if scriptname not found */
#ifdef SEARCH_EXTS
    static const char *const exts[] = { SEARCH_EXTS };
    const char *const *const ext = search_ext ? search_ext : exts;
    int extidx = 0, i = 0;
    const char *curext = NULL;
#else
    PERL_UNUSED_ARG(search_ext);
#  define MAX_EXT_LEN 0
#endif

    PERL_ARGS_ASSERT_FIND_SCRIPT;

    /*
     * If dosearch is true and if scriptname does not contain path
     * delimiters, search the PATH for scriptname.
     *
     * If SEARCH_EXTS is also defined, will look for each
     * scriptname{SEARCH_EXTS} whenever scriptname is not found
     * while searching the PATH.
     *
     * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
     * proceeds as follows:
     *   If DOSISH or VMSISH:
     *     + look for ./scriptname{,.foo,.bar}
     *     + search the PATH for scriptname{,.foo,.bar}
     *
     *   If !DOSISH:
     *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
     *       this will not look in '.' if it's not in the PATH)
     */
    tmpbuf[0] = '\0';

#ifdef VMS
#  ifdef ALWAYS_DEFTYPES
    len = strlen(scriptname);
    if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
	int idx = 0, deftypes = 1;
	bool seen_dot = 1;

	const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
#  else
    if (dosearch) {
	int idx = 0, deftypes = 1;
	bool seen_dot = 1;

	const int hasdir = (strpbrk(scriptname,":[</") != NULL);
#  endif
	/* The first time through, just add SEARCH_EXTS to whatever we
	 * already have, so we can check for default file types. */
	while (deftypes ||
	       (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
	{
	    Stat_t statbuf;
	    if (deftypes) {
		deftypes = 0;
		*tmpbuf = '\0';
	    }
	    if ((strlen(tmpbuf) + strlen(scriptname)
		 + MAX_EXT_LEN) >= sizeof tmpbuf)
		continue;	/* don't search dir with too-long name */
	    my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
#else  /* !VMS */

#ifdef DOSISH
    if (strEQ(scriptname, "-"))
 	dosearch = 0;
    if (dosearch) {		/* Look in '.' first. */
	const char *cur = scriptname;
#ifdef SEARCH_EXTS
	if ((curext = strrchr(scriptname,'.')))	/* possible current ext */
	    while (ext[i])
		if (strEQ(ext[i++],curext)) {
		    extidx = -1;		/* already has an ext */
		    break;
		}
	do {
#endif
	    DEBUG_p(PerlIO_printf(Perl_debug_log,
				  "Looking for %s\n",cur));
	    {
		Stat_t statbuf;
		if (PerlLIO_stat(cur,&statbuf) >= 0
		    && !S_ISDIR(statbuf.st_mode)) {
		    dosearch = 0;
		    scriptname = cur;
#ifdef SEARCH_EXTS
		    break;
#endif
		}
	    }
#ifdef SEARCH_EXTS
	    if (cur == scriptname) {
		len = strlen(scriptname);
		if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
		    break;
		my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
		cur = tmpbuf;
	    }
	} while (extidx >= 0 && ext[extidx]	/* try an extension? */
		 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
#endif
    }
#endif

    if (dosearch && !strchr(scriptname, '/')
#ifdef DOSISH
		 && !strchr(scriptname, '\\')
#endif
		 && (s = PerlEnv_getenv("PATH")))
    {
	bool seen_dot = 0;

	bufend = s + strlen(s);
	while (s < bufend) {
	    Stat_t statbuf;
#  ifdef DOSISH
	    for (len = 0; *s
		    && *s != ';'; len++, s++) {
		if (len < sizeof tmpbuf)
		    tmpbuf[len] = *s;
	    }
	    if (len < sizeof tmpbuf)
		tmpbuf[len] = '\0';
#  else
	    s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
                                   ':', &len);
#  endif
	    if (s < bufend)
		s++;
	    if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
		continue;	/* don't search dir with too-long name */
	    if (len