[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;

#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 */
#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?size:1);
#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));

    }
    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 !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
    Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */

    if (!size) {
	safesysfree(where);
	ptr = NULL;
    }
    else if (!where) {
	ptr = safesysmalloc(size);
    }
    else {
#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);
	}

    /* 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 %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)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

/* copy a string up to some (non-backslashed) delimiter, if any */

char *
Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
{
    I32 tolen;

    PERL_ARGS_ASSERT_DELIMCPY;

    for (tolen = 0; from < fromend; from++, tolen++) {
	if (*from == '\\') {
	    if (from[1] != delim) {
		if (to < toend)
		    *to++ = *from;
		tolen++;
	    }
	    from++;
	}
	else if (*from == delim)
	    break;
	if (to < toend)
	    *to++ = *from;
    }
    if (to < toend)
	*to = '\0';
    *retlen = tolen;
    return (char *)from;
}

/*
=head1 Miscellaneous Functions

=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end

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;
    {
        const char first = *little;
        const char *s, *x;
        bigend -= lend - little++;
    OUTER:
        while (big <= bigend) {
            if (*big++ == first) {
                for (x=big,s=little; s < lend; x++,s++) {
                    if (*s != *x)
                        goto OUTER;
                }
                return (char*)(big-1);
            }
        }
    }
    return NULL;

#endif

}

/*
=head1 Miscellaneous Functions

=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end

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 char *bigbeg;
    const I32 first = *little;
    const char * const littleend = lend;

    PERL_ARGS_ASSERT_RNINSTR;

    if (little >= littleend)
	return (char*)bigend;
    bigbeg = big;
    big = bigend - (littleend - little++);
    while (big >= bigbeg) {
	const char *s, *x;
	if (*big-- != first)
	    continue;
	for (x=big+2,s=little; s < littleend; /**/ ) {
	    if (*s != *x)
		break;
	    else {
		x++;
		s++;
	    }
	}
	if (s >= littleend)
	    return (char*)(big+1);
    }
    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. */

/*
=head1 Miscellaneous Functions

=for apidoc fbm_compile

Analyses 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;
    U32 frequency = 256;
    MAGIC *mg;
    PERL_DEB( STRLEN rarest = 0 );

    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);
    SvVALID_on(sv);

    /* "deep magic", the comment used to add. The use of MAGIC itself isn't
       really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
       to call SvVALID_off() if the scalar was assigned to.

       The comment itself (and "deeper magic" below) date back to
       378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
       str->str_pok |= 2;
       where the magic (presumably) was that the scalar had a BM table hidden
       inside itself.

       As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
       the table instead of the previous (somewhat hacky) approach of co-opting
       the string buffer and storing it after the string.  */

    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++;
	}
    }

    s = (const unsigned char*)(SvPVX_const(sv));	/* deeper magic */
    for (i = 0; i < len; i++) {
	if (PL_freq[s[i]] < frequency) {
	    PERL_DEB( rarest = i );
	    frequency = PL_freq[s[i]];
	}
    }
    BmUSEFUL(sv) = 100;			/* Initial value */
    if (flags & FBMcf_TAIL)
	SvTAIL_on(sv);
    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
			  s[rarest], (UV)rarest));
}


/*
=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 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;

    PERL_ARGS_ASSERT_FBM_INSTR;

    if ((STRLEN)(bigend - big) < littlelen) {
	if ( SvTAIL(littlestr)
	     && ((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 (SvTAIL(littlestr) && !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 (SvTAIL(littlestr))
		return (char *) bigend;
	    return NULL;

    case 2:
	if (SvTAIL(littlestr) && !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 (SvTAIL(littlestr) && bigend[0] == little[0])
                return (char *)bigend;
            return NULL;
        }

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

    if (SvTAIL(littlestr) && !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 (!SvVALID(littlestr)) {
        /* not compiled; use Perl_ninstr() instead */
	char * const b = ninstr((char*)big,(char*)bigend,
			 (char*)little, (char*)little + littlelen);

	if (!b && SvTAIL(littlestr)) {	/* Automatically multiline!  */
	    /* Chop \n from littlestr: */
	    s = bigend - littlelen + 1;
	    if (*s == *little
		&& memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
	    {
		return (char*)s;
	    }
	    return NULL;
	}
	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
	     && SvTAIL(littlestr)
	     && memEQ((char *)(bigend - littlelen),
		      (char *)(oldlittle - littlelen), littlelen) )
	    return (char*)bigend - littlelen;
	return NULL;
    }
}


/*
=for apidoc foldEQ

Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
same
case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
match themselves and their opposite case counterparts.  Non-cased and non-ASCII
range bytes match only themselves.

=cut
*/


I32
Perl_foldEQ(const char *s1, const char *s2, I32 len)
{
    const U8 *a = (const U8 *)s1;
    const U8 *b = (const U8 *)s2;

    PERL_ARGS_ASSERT_FOLDEQ;

    assert(len >= 0);

    while (len--) {
	if (*a != *b && *a != PL_fold[*b])
	    return 0;
	a++,b++;
    }
    return 1;
}
I32
Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
{
    /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
     * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
     * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
     * does it check that the strings each have at least 'len' characters */

    const U8 *a = (const U8 *)s1;
    const U8 *b = (const U8 *)s2;

    PERL_ARGS_ASSERT_FOLDEQ_LATIN1;

    assert(len >= 0);

    while (len--) {
	if (*a != *b && *a != PL_fold_latin1[*b]) {
	    return 0;
	}
	a++, b++;
    }
    return 1;
}

/*
=for apidoc foldEQ_locale

Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
same case-insensitively in the current locale; false otherwise.

=cut
*/

I32
Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
{
    dVAR;
    const U8 *a = (const U8 *)s1;
    const U8 *b = (const U8 *)s2;

    PERL_ARGS_ASSERT_FOLDEQ_LOCALE;

    assert(len >= 0);

    while (len--) {
	if (*a != *b && *a != PL_fold_locale[*b])
	    return 0;
	a++,b++;
    }
    return 1;
}

/* copy a string to a safe spot */

/*
=head1 Memory Management

=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>.  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</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, I32 len)
{
    char *newaddr;
    PERL_UNUSED_CONTEXT;

    assert(len >= 0);

    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 */

/*
=head1 Miscellaneous Functions
=for apidoc form

Takes a sprintf-style format pattern and conventional
(non-SV) arguments and returns 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);

Uses 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).

=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 Am|SV *|mess|const char *pat|...

Take a sprintf-style format pattern and 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>.

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
*/

#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 Am|SV *|mess_sv|SV *basemsg|bool consume

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.
	 */

	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 Am|SV *|vmess|const char *pat|va_list *args

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);
    }
}

/*
=head1 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)
	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 Am|OP *|die_sv|SV *baseex

Behaves 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 function never actually returns.

=cut
*/

#ifdef _MSC_VER
#  pragma warning( push )
#  pragma warning( disable : 4646 ) /* warning C4646: function declared with
    __declspec(noreturn) has non-void return type */
#  pragma warning( disable : 4645 ) /* warning C4645: function declared with
__declspec(noreturn) has a return statement */
#endif
OP *
Perl_die_sv(pTHX_ SV *baseex)
{
    PERL_ARGS_ASSERT_DIE_SV;
    croak_sv(baseex);
    /* NOTREACHED */
    NORETURN_FUNCTION_END;
}
#ifdef _MSC_VER
#  pragma warning( pop )
#endif

/*
=for apidoc Am|OP *|die|const char *pat|...

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)
#ifdef _MSC_VER
#  pragma warning( push )
#  pragma warning( disable : 4646 ) /* warning C4646: function declared with
    __declspec(noreturn) has non-void return type */
#  pragma warning( disable : 4645 ) /* warning C4645: function declared with
__declspec(noreturn) has a return statement */
#endif
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;
}
#ifdef _MSC_VER
#  pragma warning( pop )
#endif
#endif /* PERL_IMPLICIT_CONTEXT */

#ifdef _MSC_VER
#  pragma warning( push )
#  pragma warning( disable : 4646 ) /* warning C4646: function declared with
    __declspec(noreturn) has non-void return type */
#  pragma warning( disable : 4645 ) /* warning C4645: function declared with
__declspec(noreturn) has a return statement */
#endif
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;
}
#ifdef _MSC_VER
#  pragma warning( pop )
#endif

/*
=for apidoc Am|void|croak_sv|SV *baseex

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 Am|void|vcroak|const char *pat|va_list *args

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 Am|void|croak|const char *pat|...

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

Take a sprintf-style format pattern and 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
*/

#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 */

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 Am|void|croak_no_modify

Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
terser object code than using C<Perl_croak>.  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 Am|void|warn_sv|SV *baseex

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 Am|void|vwarn|const char *pat|va_list *args

This is an XS interface to Perl's C<warn> 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 or object will by default be written to standard error,
but this is subject to modification by a C<$SIG{__WARN__}> handler.

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 Am|void|warn|const char *pat|...

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

Take a sprintf-style format pattern and 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 or object will by default be written to standard error,
but this is subject to modification by a C<$SIG{__WARN__}> handler.

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

=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);
}

#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)
{
    dVAR;
    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
       /* VMS' my_setenv() is in vms.c */
#if !defined(WIN32) && !defined(NETWARE)
void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
  dVAR;
#ifdef __amigaos4__
  amigaos4_obtain_environ(__FUNCTION__);
#endif
#ifdef USE_ITHREADS
  /* only parent thread can modify process environment */
  if (PL_curinterp == aTHX)
#endif
  {
#ifndef PERL_USE_SAFE_PUTENV
    if (!PL_use_safe_putenv) {
        /* most putenv()s leak, so we manipulate environ directly */
        I32 i;
        const I32 len = strlen(nam);
        int nlen, vlen;

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

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

            max = i;
            while (environ[max])
                max++;
            tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
            for (j=0; j<max; j++) {         /* copy environment */
                const int len = strlen(environ[j]);
                tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
                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**)safesysrealloc(environ, (i+2) * sizeof(char*));
            environ[i+1] = NULL;    /* make sure it's null terminated */
        }
        else
            safesysfree(environ[i]);
        nlen = strlen(nam);
        vlen = strlen(val);

        environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
        /* all that work just for this */
        my_setenv_format(environ[i], nam, nlen, val, vlen);
    } else {
# endif
    /* This next branch should only be called #if defined(HAS_SETENV), but
       Configure doesn't test for that yet.  For Solaris, setenv() and unsetenv()
       were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
    */
#   if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
#       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 */
#   else
#       if defined(HAS_UNSETENV)
        if (val == NULL) {
            if (environ) /* old glibc can crash with null environ */
                (void)unsetenv(nam);
        } else {
	    const int nlen = strlen(nam);
	    const int vlen = strlen(val);
	    char * const new_env =
                (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
            my_setenv_format(new_env, nam, nlen, val, vlen);
            (void)putenv(new_env);
        }
#       else /* ! HAS_UNSETENV */
        char *new_env;
	const int nlen = strlen(nam);
	int vlen;
        if (!val) {
	   val = "";
        }
        vlen = strlen(val);
        new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
        /* all that work just for this */
        my_setenv_format(new_env, nam, nlen, val, vlen);
        (void)putenv(new_env);
#       endif /* HAS_UNSETENV */
#   endif /* __CYGWIN__ */
#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)
{
    dVAR;
    char *envstr;
    const int nlen = strlen(nam);
    int vlen;

    if (!val) {
       val = "";
    }
    vlen = strlen(val);
    Newx(envstr, nlen+vlen+2, char);
    my_setenv_format(envstr, nam, nlen, val, vlen);
    (void)PerlEnv_putenv(envstr);
    Safefree(envstr);
}

#endif /* WIN32 || NETWARE */

#endif /* !VMS */

#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

/* this is a drop-in replacement for bcopy(), except for the return
 * value, which we need to be able to emulate memcpy()  */
#if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY))
void *
Perl_my_bcopy(const void *vfrom, void *vto, size_t len)
{
#if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
    bcopy(vfrom, vto, len);
#else
    const unsigned char *from = (const unsigned char *)vfrom;
    unsigned char *to = (unsigned char *)vto;

    PERL_ARGS_ASSERT_MY_BCOPY;

    if (from - to >= 0) {
	while (len--)
	    *to++ = *from++;
    }
    else {
	to += len;
	from += len;
	while (len--)
	    *(--to) = *(--from);
    }
#endif

    return vto;
}
#endif

/* this is a drop-in replacement for memset() */
#ifndef HAS_MEMSET
void *
Perl_my_memset(void *vloc, int ch, size_t len)
{
    unsigned char *loc = (unsigned char *)vloc;

    PERL_ARGS_ASSERT_MY_MEMSET;

    while (len--)
	*loc++ = ch;
    return vloc;
}
#endif

/* this is a drop-in replacement for bzero() */
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
void *
Perl_my_bzero(void *vloc, size_t len)
{
    unsigned char *loc = (unsigned char *)vloc;

    PERL_ARGS_ASSERT_MY_BZERO;

    while (len--)
	*loc++ = 0;
    return vloc;
}
#endif

/* this is a drop-in replacement for memcmp() */
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
int
Perl_my_memcmp(const void *vs1, const void *vs2, size_t len)
{
    const U8 *a = (const U8 *)vs1;
    const U8 *b = (const U8 *)vs2;
    int tmp;

    PERL_ARGS_ASSERT_MY_MEMCMP;

    while (len--) {
        if ((tmp = *a++ - *b++))
	    return tmp;
    }
    return 0;
}
#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */

#ifndef HAS_VPRINTF
/* This vsprintf replacement should generally never get used, since
   vsprintf was available in both System V and BSD 2.11.  (There may
   be some cross-compilation or embedded set-ups where it is needed,
   however.)

   If you encounter a problem in this function, it's probably a symptom
   that Configure failed to detect your system's vprintf() function.
   See the section on "item vsprintf" in the INSTALL file.

   This version may compile on systems with BSD-ish <stdio.h>,
   but probably won't on others.
*/

#ifdef USE_CHAR_VSPRINTF
char *
#else
int
#endif
vsprintf(char *dest, const char *pat, void *args)
{
    FILE fakebuf;

#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
    FILE_ptr(&fakebuf) = (STDCHAR *) dest;
    FILE_cnt(&fakebuf) = 32767;
#else
    /* These probably won't compile -- If you really need
       this, you'll have to figure out some other method. */
    fakebuf._ptr = dest;
    fakebuf._cnt = 32767;
#endif
#ifndef _IOSTRG
#define _IOSTRG 0
#endif
    fakebuf._flag = _IOWRT|_IOSTRG;
    _doprnt(pat, args, &fakebuf);	/* what a kludge */
#if defined(STDIO_PTR_LVALUE)
    *(FILE_ptr(&fakebuf)++) = '\0';
#else
    /* PerlIO has probably #defined away fputc, but we want it here. */
#  ifdef fputc
#    undef fputc  /* XXX Should really restore it later */
#  endif
    (void)fputc('\0', &fakebuf);
#endif
#ifdef USE_CHAR_VSPRINTF
    return(dest);
#else
    return 0;		/* perl doesn't use return value */
#endif
}

#endif /* HAS_VPRINTF */

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(p) < 0)
	return NULL;
    /* Try for another pipe pair for error return */
    if (PerlProc_pipe(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]);
#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
	    /* Close error pipe automatically if exec works */
	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
                return NULL;
#endif
	}
	/* 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
	    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 */
    do_execfree();	/* free any memory malloced by child on fork */
    if (did_pipes)
	PerlLIO_close(pp[1]);
    /* Keep the lower of the two fd numbers */
    if (p[that] < p[This]) {
	PerlLIO_dup2(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 n = 0;
	SSize_t n1;

	while (n < sizeof(int)) {
	    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);
#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(p) < 0)
	return NULL;
    if (doexec && PerlProc_pipe(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 defined(HAS_FCNTL) && defined(F_SETFD)
            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
                return NULL;
#endif
	}
	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
	    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
    }
    do_execfree();	/* free any memory malloced by child on vfork */
    if (did_pipes)
	PerlLIO_close(pp[1]);
    if (p[that] < p[This]) {
	PerlLIO_dup2(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;
	SSize_t n1;

	while (n < sizeof(int)) {
	    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);
}
#else
#if 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);
}
#else
#if defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
    return NULL;
}
#endif
#endif

#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)
    dVAR;
    /* 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)
    dVAR;
    /* 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

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

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

    act.sa_handler = (void(*)(int))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
    dVAR;
#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 = (void(*)(int))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
    dVAR;
#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)
{
    dVAR;
    PL_sig_trapped++;
}

Sighandler_t
Perl_rsignal_state(pTHX_ int signo)
{
    dVAR;
    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
    );
}
#else
#if defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
    return -1;
}
#endif
#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(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
#  ifdef DOSISH
		&& tmpbuf[len - 1] != '/'
		&& tmpbuf[len - 1] != '\\'
#  endif
	       )
		tmpbuf[len++] = '/';
	    if (len == 2 && tmpbuf[0] == '.')
		seen_dot = 1;
	    (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
#endif  /* !VMS */

#ifdef SEARCH_EXTS
	    len = strlen(tmpbuf);
	    if (extidx > 0)	/* reset after previous loop */
		extidx = 0;
	    do {
#endif
	    	DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
		retval = PerlLIO_stat(tmpbuf,&statbuf);
		if (S_ISDIR(statbuf.st_mode)) {
		    retval = -1;
		}
#ifdef SEARCH_EXTS
	    } while (  retval < 0		/* not there */
		    && extidx>=0 && ext[extidx]	/* try an extension? */
		    && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
		);
#endif
	    if (retval < 0)
		continue;
	    if (S_ISREG(statbuf.st_mode)
		&& cando(S_IRUSR,TRUE,&statbuf)
#if !defined(DOSISH)
		&& cando(S_IXUSR,TRUE,&statbuf)
#endif
		)
	    {
		xfound = tmpbuf;		/* bingo! */
		break;
	    }
	    if (!xfailed)
		xfailed = savepv(tmpbuf);
	}
#ifndef DOSISH
	{
	    Stat_t statbuf;
	    if (!xfound && !seen_dot && !xfailed &&
		(PerlLIO_stat(scriptname,&statbuf) < 0
		 || S_ISDIR(statbuf.st_mode)))
#endif
		seen_dot = 1;			/* Disable message. */
#ifndef DOSISH
	}
#endif
	if (!xfound) {
	    if (flags & 1) {			/* do or die? */
		/* diag_listed_as: Can't execute %s */
		Perl_croak(aTHX_ "Can't %s %s%s%s",
		      (xfailed ? "execute" : "find"),
		      (xfailed ? xfailed : scriptname),
		      (xfailed ? "" : " on PATH"),
		      (xfailed || seen_dot) ? "" : ", '.' not in PATH");
	    }
	    scriptname = NULL;
	}
	Safefree(xfailed);
	scriptname = xfound;
    }
    return (scriptname ? savepv(scriptname) : NULL);
}

#ifndef PERL_GET_CONTEXT_DEFINED

void *
Perl_get_context(void)
{
#if defined(USE_ITHREADS)
    dVAR;
#  ifdef OLD_PTHREADS_API
    pthread_addr_t t;
    int error = pthread_getspecific(PL_thr_key, &t)
    if (error)
	Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
    return (void*)t;
#  else
#    ifdef I_MACH_CTHREADS
    return (void*)cthread_data(cthread_self());
#    else
    return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
#    endif
#  endif
#else
    return (void*)NULL;
#endif
}

void
Perl_set_context(void *t)
{
#if defined(USE_ITHREADS)
    dVAR;
#endif
    PERL_ARGS_ASSERT_SET_CONTEXT;
#if defined(USE_ITHREADS)
#  ifdef I_MACH_CTHREADS
    cthread_set_data(cthread_self(), t);
#  else
    {
	const int error = pthread_setspecific(PL_thr_key, t);
	if (error)
	    Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
    }
#  endif
#else
    PERL_UNUSED_ARG(t);
#endif
}

#endif /* !PERL_GET_CONTEXT_DEFINED */

#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
struct perl_vars *
Perl_GetVars(pTHX)
{
    PERL_UNUSED_CONTEXT;
    return &PL_Vars;
}
#endif

char **
Perl_get_op_names(pTHX)
{
    PERL_UNUSED_CONTEXT;
    return (char **)PL_op_name;
}

char **
Perl_get_op_descs(pTHX)
{
    PERL_UNUSED_CONTEXT;
    return (char **)PL_op_desc;
}