Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Branch: codegen
Fetching contributors…

Cannot retrieve contributors at this time

6714 lines (5952 sloc) 167.31 kB
/* 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"
#ifndef PERL_MICRO
#include <signal.h>
#ifndef SIG_ERR
# define SIG_ERR ((Sighandler_t) -1)
#endif
#endif
#ifdef __Lynx__
/* Missing protos on LynxOS */
int putenv(char *);
#endif
#ifdef I_SYS_WAIT
# include <sys/wait.h>
#endif
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
# endif
#endif
#define FLUSH
#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
# define FD_CLOEXEC 1 /* NeXT needs this */
#endif
/* 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.
*/
static char *
S_write_no_mem(pTHX)
{
dVAR;
/* Can't use PerlIO to write as it allocates memory */
PerlLIO_write(PerlIO_fileno(Perl_error_log),
PL_no_mem, strlen(PL_no_mem));
my_exit(1);
NORETURN_FUNCTION_END;
}
#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
# define ALWAYS_NEED_THX
#endif
/* paranoid version of system's malloc() */
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
#ifdef ALWAYS_NEED_THX
dTHX;
#endif
Malloc_t ptr;
#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
PerlIO_printf(Perl_error_log,
"Allocation too large: %lx\n", size) FLUSH;
my_exit(1);
}
#endif /* HAS_64K_LIMIT */
#ifdef PERL_TRACK_MEMPOOL
size += sTHX;
#endif
#ifdef DEBUGGING
if ((long)size < 0)
Perl_croak_nocontext("panic: malloc");
#endif
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
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;
header->next->prev = header;
# ifdef PERL_POISON
header->size = size;
# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
return ptr;
}
else {
#ifndef ALWAYS_NEED_THX
dTHX;
#endif
if (PL_nomemok)
return NULL;
else {
return write_no_mem();
}
}
/*NOTREACHED*/
}
/* 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;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
PerlIO_printf(Perl_error_log,
"Reallocation too large: %lx\n", size) FLUSH;
my_exit(1);
}
#endif /* HAS_64K_LIMIT */
if (!size) {
safesysfree(where);
return NULL;
}
if (!where)
return safesysmalloc(size);
#ifdef PERL_TRACK_MEMPOOL
where = (Malloc_t)((char*)where-sTHX);
size += sTHX;
{
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)where;
if (header->interpreter != aTHX) {
Perl_croak_nocontext("panic: realloc from wrong pool");
}
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);
}
header->size = size;
# endif
}
#endif
#ifdef DEBUGGING
if ((long)size < 0)
Perl_croak_nocontext("panic: realloc");
#endif
ptr = (Malloc_t)PerlMem_realloc(where,size);
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. */
#ifdef PERL_TRACK_MEMPOOL
if (ptr != NULL) {
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
header->next->prev = header;
header->prev->next = header;
ptr = (Malloc_t)((char*)ptr+sTHX);
}
#endif
/* 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) {
return ptr;
}
else {
#ifndef ALWAYS_NEED_THX
dTHX;
#endif
if (PL_nomemok)
return NULL;
else {
return write_no_mem();
}
}
/*NOTREACHED*/
}
/* safe version of system's free() */
Free_t
Perl_safesysfree(Malloc_t where)
{
#ifdef ALWAYS_NEED_THX
dTHX;
#else
dVAR;
#endif
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
#ifdef PERL_TRACK_MEMPOOL
where = (Malloc_t)((char*)where-sTHX);
{
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)where;
if (header->interpreter != aTHX) {
Perl_croak_nocontext("panic: free from wrong pool");
}
if (!header->prev) {
Perl_croak_nocontext("panic: duplicate free");
}
if (!(header->next) || header->next->prev != header
|| header->prev->next != header) {
Perl_croak_nocontext("panic: bad free");
}
/* Unlink us from the chain. */
header->next->prev = header->prev;
header->prev->next = header->next;
# ifdef PERL_POISON
PoisonNew(where, header->size, char);
# endif
/* Trigger the duplicate free warning. */
header->next = NULL;
}
#endif
PerlMem_free(where);
}
}
/* 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;
MEM_SIZE total_size = 0;
/* Even though calloc() for zero bytes is strange, be robust. */
if (size && (count <= MEM_SIZE_MAX / size))
total_size = size * count;
else
Perl_croak_nocontext("%s", PL_memory_wrap);
#ifdef PERL_TRACK_MEMPOOL
if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
total_size += sTHX;
else
Perl_croak_nocontext("%s", PL_memory_wrap);
#endif
#ifdef HAS_64K_LIMIT
if (total_size > 0xffff) {
PerlIO_printf(Perl_error_log,
"Allocation too large: %lx\n", total_size) FLUSH;
my_exit(1);
}
#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
if ((long)size < 0 || (long)count < 0)
Perl_croak_nocontext("panic: calloc");
#endif
#ifdef 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 PERL_TRACK_MEMPOOL
{
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)ptr;
memset((void*)ptr, 0, total_size);
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;
header->next->prev = header;
# ifdef PERL_POISON
header->size = total_size;
# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
}
#endif
return ptr;
}
else {
#ifndef ALWAYS_NEED_THX
dTHX;
#endif
if (PL_nomemok)
return NULL;
return write_no_mem();
}
}
/* These must be defined when not using Perl's malloc for binary
* compatibility */
#ifndef MYMALLOC
Malloc_t Perl_malloc (MEM_SIZE nbytes)
{
dTHXs;
return (Malloc_t)PerlMem_malloc(nbytes);
}
Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
{
dTHXs;
return (Malloc_t)PerlMem_calloc(elements, size);
}
Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
{
dTHXs;
return (Malloc_t)PerlMem_realloc(where, nbytes);
}
Free_t Perl_mfree (Malloc_t where)
{
dTHXs;
PerlMem_free(where);
}
#endif
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
{
register 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;
}
/* return ptr to little string in big string, NULL if not found */
/* This routine was donated by Corey Satten. */
char *
Perl_instr(register const char *big, register const char *little)
{
register I32 first;
PERL_ARGS_ASSERT_INSTR;
if (!little)
return (char*)big;
first = *little++;
if (!first)
return (char*)big;
while (*big) {
register const char *s, *x;
if (*big++ != first)
continue;
for (x=big,s=little; *s; /**/ ) {
if (!*x)
return NULL;
if (*s != *x)
break;
else {
s++;
x++;
}
}
if (!*s)
return (char*)(big-1);
}
return NULL;
}
/* same as instr but allow embedded nulls */
char *
Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
PERL_ARGS_ASSERT_NINSTR;
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;
}
/* reverse of the above--find last substring */
char *
Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
{
register const char *bigbeg;
register const I32 first = *little;
register const char * const littleend = lend;
PERL_ARGS_ASSERT_RNINSTR;
if (little >= littleend)
return (char*)bigend;
bigbeg = big;
big = bigend - (littleend - little++);
while (big >= bigbeg) {
register 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 fbm_instr()
-- the Boyer-Moore algorithm.
=cut
*/
void
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
dVAR;
register const U8 *s;
register U32 i;
STRLEN len;
U32 rarest = 0;
U32 frequency = 256;
PERL_ARGS_ASSERT_FBM_COMPILE;
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++;
}
s = (U8*)SvPV_force_mutable(sv, len);
if (len == 0) /* TAIL might be on a zero-length string. */
return;
SvUPGRADE(sv, SVt_PVGV);
SvIOK_off(sv);
SvNOK_off(sv);
SvVALID_on(sv);
if (len > 2) {
const unsigned char *sb;
const U8 mlen = (len>255) ? 255 : (U8)len;
register U8 *table;
Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
table
= (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
memset((void*)table, mlen, 256);
i = 0;
sb = s - mlen + 1; /* first char (maybe) */
while (s >= sb) {
if (table[*s] == mlen)
table[*s] = (U8)i;
s--, i++;
}
} else {
Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
}
sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
if (PL_freq[s[i]] < frequency) {
rarest = i;
frequency = PL_freq[s[i]];
}
}
BmFLAGS(sv) = (U8)flags;
BmRARE(sv) = s[rarest];
BmPREVIOUS(sv) = rarest;
BmUSEFUL(sv) = 100; /* Initial value */
if (flags & FBMcf_TAIL)
SvTAIL_on(sv);
DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
}
/* If SvTAIL(littlestr), it has a fake '\n' at end. */
/* If SvTAIL is actually due to \Z or \z, this gives false positives
if multiline */
/*
=for apidoc fbm_instr
Returns the location of the SV in the string delimited by C<str> and
C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
does not have to be fbm_compiled, but the search will not be as fast
then.
=cut
*/
char *
Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
{
register unsigned char *s;
STRLEN l;
register const unsigned char *little
= (const unsigned char *)SvPV_const(littlestr,l);
register STRLEN littlelen = l;
register 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;
}
if (littlelen <= 2) { /* Special-cased */
if (littlelen == 1) {
if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
/* Know that bigend != big. */
if (bigend[-1] == '\n')
return (char *)(bigend - 1);
return (char *) bigend;
}
s = big;
while (s < bigend) {
if (*s == *little)
return (char *)s;
s++;
}
if (SvTAIL(littlestr))
return (char *) bigend;
return NULL;
}
if (!littlelen)
return (char*)big; /* Cannot be SvTAIL! */
/* littlelen is 2 */
if (SvTAIL(littlestr) && !multiline) {
if (bigend[-1] == '\n' && bigend[-2] == *little)
return (char*)bigend - 2;
if (bigend[-1] == *little)
return (char*)bigend - 1;
return NULL;
}
{
/* This should be better than FBM if c1 == c2, and almost
as good otherwise: maybe better since we do less indirection.
And we save a lot of memory by caching no table. */
const unsigned char c1 = little[0];
const unsigned char c2 = little[1];
s = big + 1;
bigend--;
if (c1 != c2) {
while (s <= bigend) {
if (s[0] == c2) {
if (s[-1] == c1)
return (char*)s - 1;
s += 2;
continue;
}
next_chars:
if (s[0] == c1) {
if (s == bigend)
goto check_1char_anchor;
if (s[1] == c2)
return (char*)s;
else {
s++;
goto next_chars;
}
}
else
s += 2;
}
goto check_1char_anchor;
}
/* Now c1 == c2 */
while (s <= bigend) {
if (s[0] == c1) {
if (s[-1] == c1)
return (char*)s - 1;
if (s == bigend)
goto check_1char_anchor;
if (s[1] == c1)
return (char*)s;
s += 3;
}
else
s += 2;
}
}
check_1char_anchor: /* One char and anchor! */
if (SvTAIL(littlestr) && (*bigend == *little))
return (char *)bigend; /* bigend is already decremented. */
return NULL;
}
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)) {
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;
{
register const unsigned char * const table
= little + littlelen + PERL_FBM_TABLE_OFFSET;
register const unsigned char *oldlittle;
--littlelen; /* Last char found by table lookup */
s = big + littlelen;
little += littlelen; /* last char */
oldlittle = little;
if (s < bigend) {
register I32 tmp;
top2:
if ((tmp = table[*s])) {
if ((s += tmp) < bigend)
goto top2;
goto check_end;
}
else { /* less expensive than calling strncmp() */
register 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
&& (BmFLAGS(littlestr) & FBMcf_TAIL)
&& memEQ((char *)(bigend - littlelen),
(char *)(oldlittle - littlelen), littlelen) )
return (char*)bigend - littlelen;
return NULL;
}
}
/* start_shift, end_shift are positive quantities which give offsets
of ends of some substring of bigstr.
If "last" we want the last occurrence.
old_posp is the way of communication between consequent calls if
the next call needs to find the .
The initial *old_posp should be -1.
Note that we take into account SvTAIL, so one can get extra
optimizations if _ALL flag is set.
*/
/* If SvTAIL is actually due to \Z or \z, this gives false positives
if PL_multiline. In fact if !PL_multiline the authoritative answer
is not supported yet. */
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
dVAR;
register const unsigned char *big;
register I32 pos;
register I32 previous;
register I32 first;
register const unsigned char *little;
register I32 stop_pos;
register const unsigned char *littleend;
I32 found = 0;
PERL_ARGS_ASSERT_SCREAMINSTR;
assert(SvTYPE(littlestr) == SVt_PVGV);
assert(SvVALID(littlestr));
if (*old_posp == -1
? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
: (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
cant_find:
if ( BmRARE(littlestr) == '\n'
&& BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
little = (const unsigned char *)(SvPVX_const(littlestr));
littleend = little + SvCUR(littlestr);
first = *little++;
goto check_tail;
}
return NULL;
}
little = (const unsigned char *)(SvPVX_const(littlestr));
littleend = little + SvCUR(littlestr);
first = *little++;
/* The value of pos we can start at: */
previous = BmPREVIOUS(littlestr);
big = (const unsigned char *)(SvPVX_const(bigstr));
/* The value of pos we can stop at: */
stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
if (previous + start_shift > stop_pos) {
/*
stop_pos does not include SvTAIL in the count, so this check is incorrect
(I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
*/
#if 0
if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
goto check_tail;
#endif
return NULL;
}
while (pos < previous + start_shift) {
if (!(pos += PL_screamnext[pos]))
goto cant_find;
}
big -= previous;
do {
register const unsigned char *s, *x;
if (pos >= stop_pos) break;
if (big[pos] != first)
continue;
for (x=big+pos+1,s=little; s < littleend; /**/ ) {
if (*s++ != *x++) {
s--;
break;
}
}
if (s == littleend) {
*old_posp = pos;
if (!last) return (char *)(big+pos);
found = 1;
}
} while ( pos += PL_screamnext[pos] );
if (last && found)
return (char *)(big+(*old_posp));
check_tail:
if (!SvTAIL(littlestr) || (end_shift > 0))
return NULL;
/* Ignore the trailing "\n". This code is not microoptimized */
big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
stop_pos = littleend - little; /* Actual littlestr len */
if (stop_pos == 0)
return (char*)big;
big -= stop_pos;
if (*big == first
&& ((stop_pos == 1) ||
memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
return (char*)big;
return NULL;
}
/*
=for apidoc foldEQ
Returns true if the leading len bytes of the strings s1 and 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, register I32 len)
{
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
PERL_ARGS_ASSERT_FOLDEQ;
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, register 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 */
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
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 len bytes of the strings s1 and s2 are the same
case-insensitively in the current locale; false otherwise.
=cut
*/
I32
Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
{
dVAR;
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
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()>. The memory allocated for the new string can
be freed with the C<Safefree()> function.
=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 NUL byte. The memory allocated for
the new string can be freed with the C<Safefree()> function.
=cut
*/
char *
Perl_savepvn(pTHX_ const char *pv, register I32 len)
{
register 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)
{
register char *newaddr;
STRLEN pvlen;
if (!pv)
return NULL;
pvlen = strlen(pv)+1;
newaddr = (char*)PerlMemShared_malloc(pvlen);
if (!newaddr) {
return write_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 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_ARGS_ASSERT_SAVESHAREDPVN;
if (!newaddr) {
return write_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()>
=cut
*/
char *
Perl_savesvpv(pTHX_ SV *sv)
{
STRLEN len;
const char * const pv = SvPV_const(sv, len);
register 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)
{
dVAR;
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;
}
STATIC const COP*
S_closest_cop(pTHX_ const COP *cop, const OP *o)
{
dVAR;
/* Look for PL_op starting from o. cop is the last COP we've seen. */
PERL_ARGS_ASSERT_CLOSEST_COP;
if (!o || o == PL_op)
return cop;
if (o->op_flags & OPf_KIDS) {
const OP *kid;
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
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);
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)
{
dVAR;
SV *sv;
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, PL_curcop->op_sibling);
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)))
{
const bool line_mode = (RsSIMPLE(PL_rs) &&
SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
PL_last_in_gv == PL_argvgv ? "" : GvNAME(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. 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)
{
dVAR;
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)
{
dVAR;
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)))
{
dSP;
ENTER;
SAVETMPS;
save_re_context();
SAVESPTR(PL_stderrgv);
PL_stderrgv = NULL;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
PUSHs(msv);
PUTBACK;
call_method("PRINT", G_SCALAR);
POPSTACK;
FREETMPS;
LEAVE;
}
else {
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
dSAVED_ERRNO;
#endif
PerlIO * const serr = Perl_error_log;
do_print(msv, serr);
(void)PerlIO_flush(serr);
#ifdef USE_SFIO
RESTORE_ERRNO;
#endif
}
}
/*
=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)
{
dVAR;
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
*/
OP *
Perl_die_sv(pTHX_ SV *baseex)
{
PERL_ARGS_ASSERT_DIE_SV;
croak_sv(baseex);
/* NOTREACHED */
return NULL;
}
/*
=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)
OP *
Perl_die_nocontext(const char* pat, ...)
{
dTHX;
va_list args;
va_start(args, pat);
vcroak(pat, &args);
/* NOTREACHED */
va_end(args);
return NULL;
}
#endif /* PERL_IMPLICIT_CONTEXT */
OP *
Perl_die(pTHX_ const char* pat, ...)
{
va_list args;
va_start(args, pat);
vcroak(pat, &args);
/* NOTREACHED */
va_end(args);
return NULL;
}
/*
=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);
/* 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);
/* 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(pTHX)
{
Perl_croak(aTHX_ "%s", PL_no_modify);
}
/*
=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)) {
SV * const msv = vmess(pat, args);
invoke_exception_hook(msv, FALSE);
die_unwind(msv);
}
else {
Perl_vwarn(aTHX_ pat, args);
}
}
/* implements the ckWARN? macros */
bool
Perl_ckwarn(pTHX_ U32 w)
{
dVAR;
/* 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)
{
dVAR;
/* 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;
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);
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 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 */
register I32 i;
register 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++;
}
return;
}
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
# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
# 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) {
(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
}
}
#else /* WIN32 || NETWARE */
void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
dVAR;
register 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 && !EPOC*/
#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() */
#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
char *
Perl_my_bcopy(register const char *from,register char *to,register I32 len)
{
char * const retval = to;
PERL_ARGS_ASSERT_MY_BCOPY;
if (from - to >= 0) {
while (len--)
*to++ = *from++;
}
else {
to += len;
from += len;
while (len--)
*(--to) = *(--from);
}
return retval;
}
#endif
/* this is a drop-in replacement for memset() */
#ifndef HAS_MEMSET
void *
Perl_my_memset(register char *loc, register I32 ch, register I32 len)
{
char * const retval = loc;
PERL_ARGS_ASSERT_MY_MEMSET;
while (len--)
*loc++ = ch;
return retval;
}
#endif
/* this is a drop-in replacement for bzero() */
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
char *
Perl_my_bzero(register char *loc, register I32 len)
{
char * const retval = loc;
PERL_ARGS_ASSERT_MY_BZERO;
while (len--)
*loc++ = 0;
return retval;
}
#endif
/* this is a drop-in replacement for memcmp() */
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
I32
Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
{
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
register I32 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 */
#ifdef MYSWAP
#if BYTEORDER != 0x4321
short
Perl_my_swap(pTHX_ short s)
{
#if (BYTEORDER & 1) == 0
short result;
result = ((s & 255) << 8) + ((s >> 8) & 255);
return result;
#else
return s;
#endif
}
long
Perl_my_htonl(pTHX_ long l)
{
union {
long result;
char c[sizeof(long)];
} u;
#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
#if BYTEORDER == 0x12345678
u.result = 0;
#endif
u.c[0] = (l >> 24) & 255;
u.c[1] = (l >> 16) & 255;
u.c[2] = (l >> 8) & 255;
u.c[3] = l & 255;
return u.result;
#else
#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
Perl_croak(aTHX_ "Unknown BYTEORDER\n");
#else
register I32 o;
register I32 s;
for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
u.c[o & 0xf] = (l >> s) & 255;
}
return u.result;
#endif
#endif
}
long
Perl_my_ntohl(pTHX_ long l)
{
union {
long l;
char c[sizeof(long)];
} u;
#if BYTEORDER == 0x1234
u.c[0] = (l >> 24) & 255;
u.c[1] = (l >> 16) & 255;
u.c[2] = (l >> 8) & 255;
u.c[3] = l & 255;
return u.l;
#else
#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
Perl_croak(aTHX_ "Unknown BYTEORDER\n");
#else
register I32 o;
register I32 s;
u.l = l;
l = 0;
for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
l |= (u.c[o & 0xf] & 255) << s;
}
return l;
#endif
#endif
}
#endif /* BYTEORDER != 0x4321 */
#endif /* MYSWAP */
/*
* Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
* If these functions are defined,
* the BYTEORDER is neither 0x1234 nor 0x4321.
* However, this is not assumed.
* -DWS
*/
#define HTOLE(name,type) \
type \
name (register type n) \
{ \
union { \
type value; \
char c[sizeof(type)]; \
} u; \
register U32 i; \
register U32 s = 0; \
for (i = 0; i < sizeof(u.c); i++, s += 8) { \
u.c[i] = (n >> s) & 0xFF; \
} \
return u.value; \
}
#define LETOH(name,type) \
type \
name (register type n) \
{ \
union { \
type value; \
char c[sizeof(type)]; \
} u; \
register U32 i; \
register U32 s = 0; \
u.value = n; \
n = 0; \
for (i = 0; i < sizeof(u.c); i++, s += 8) { \
n |= ((type)(u.c[i] & 0xFF)) << s; \
} \
return n; \
}
/*
* Big-endian byte order functions.
*/
#define HTOBE(name,type) \
type \
name (register type n) \
{ \
union { \
type value; \
char c[sizeof(type)]; \
} u; \
register U32 i; \
register U32 s = 8*(sizeof(u.c)-1); \
for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
u.c[i] = (n >> s) & 0xFF; \
} \
return u.value; \
}
#define BETOH(name,type) \
type \
name (register type n) \
{ \
union { \
type value; \
char c[sizeof(type)]; \
} u; \
register U32 i; \
register U32 s = 8*(sizeof(u.c)-1); \
u.value = n; \
n = 0; \
for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
n |= ((type)(u.c[i] & 0xFF)) << s; \
} \
return n; \
}
/*
* If we just can't do it...
*/
#define NOT_AVAIL(name,type) \
type \
name (register type n) \
{ \
Perl_croak_nocontext(#name "() not available"); \
return n; /* not reached */ \
}
#if defined(HAS_HTOVS) && !defined(htovs)
HTOLE(htovs,short)
#endif
#if defined(HAS_HTOVL) && !defined(htovl)
HTOLE(htovl,long)
#endif
#if defined(HAS_VTOHS) && !defined(vtohs)
LETOH(vtohs,short)
#endif
#if defined(HAS_VTOHL) && !defined(vtohl)
LETOH(vtohl,long)
#endif
#ifdef PERL_NEED_MY_HTOLE16
# if U16SIZE == 2
HTOLE(Perl_my_htole16,U16)
# else
NOT_AVAIL(Perl_my_htole16,U16)
# endif
#endif
#ifdef PERL_NEED_MY_LETOH16
# if U16SIZE == 2
LETOH(Perl_my_letoh16,U16)
# else
NOT_AVAIL(Perl_my_letoh16,U16)
# endif
#endif
#ifdef PERL_NEED_MY_HTOBE16
# if U16SIZE == 2
HTOBE(Perl_my_htobe16,U16)
# else
NOT_AVAIL(Perl_my_htobe16,U16)
# endif
#endif
#ifdef PERL_NEED_MY_BETOH16
# if U16SIZE == 2
BETOH(Perl_my_betoh16,U16)
# else
NOT_AVAIL(Perl_my_betoh16,U16)
# endif
#endif
#ifdef PERL_NEED_MY_HTOLE32
# if U32SIZE == 4
HTOLE(Perl_my_htole32,U32)
# else
NOT_AVAIL(Perl_my_htole32,U32)
# endif
#endif
#ifdef PERL_NEED_MY_LETOH32
# if U32SIZE == 4
LETOH(Perl_my_letoh32,U32)
# else
NOT_AVAIL(Perl_my_letoh32,U32)
# endif
#endif
#ifdef PERL_NEED_MY_HTOBE32
# if U32SIZE == 4
HTOBE(Perl_my_htobe32,U32)
# else
NOT_AVAIL(Perl_my_htobe32,U32)
# endif
#endif
#ifdef PERL_NEED_MY_BETOH32
# if U32SIZE == 4
BETOH(Perl_my_betoh32,U32)
# else
NOT_AVAIL(Perl_my_betoh32,U32)
# endif
#endif
#ifdef PERL_NEED_MY_HTOLE64
# if U64SIZE == 8
HTOLE(Perl_my_htole64,U64)
# else
NOT_AVAIL(Perl_my_htole64,U64)
# endif
#endif
#ifdef PERL_NEED_MY_LETOH64
# if U64SIZE == 8
LETOH(Perl_my_letoh64,U64)
# else
NOT_AVAIL(Perl_my_letoh64,U64)
# endif
#endif
#ifdef PERL_NEED_MY_HTOBE64
# if U64SIZE == 8
HTOBE(Perl_my_htobe64,U64)
# else
NOT_AVAIL(Perl_my_htobe64,U64)
# endif
#endif
#ifdef PERL_NEED_MY_BETOH64
# if U64SIZE == 8
BETOH(Perl_my_betoh64,U64)
# else
NOT_AVAIL(Perl_my_betoh64,U64)
# endif
#endif
#ifdef PERL_NEED_MY_HTOLES
HTOLE(Perl_my_htoles,short)
#endif
#ifdef PERL_NEED_MY_LETOHS
LETOH(Perl_my_letohs,short)
#endif
#ifdef PERL_NEED_MY_HTOBES
HTOBE(Perl_my_htobes,short)
#endif
#ifdef PERL_NEED_MY_BETOHS
BETOH(Perl_my_betohs,short)
#endif
#ifdef PERL_NEED_MY_HTOLEI
HTOLE(Perl_my_htolei,int)
#endif
#ifdef PERL_NEED_MY_LETOHI
LETOH(Perl_my_letohi,int)
#endif
#ifdef PERL_NEED_MY_HTOBEI
HTOBE(Perl_my_htobei,int)
#endif
#ifdef PERL_NEED_MY_BETOHI
BETOH(Perl_my_betohi,int)
#endif
#ifdef PERL_NEED_MY_HTOLEL
HTOLE(Perl_my_htolel,long)
#endif
#ifdef PERL_NEED_MY_LETOHL
LETOH(Perl_my_letohl,long)
#endif
#ifdef PERL_NEED_MY_HTOBEL
HTOBE(Perl_my_htobel,long)
#endif
#ifdef PERL_NEED_MY_BETOHL
BETOH(Perl_my_betohl,long)
#endif
void
Perl_my_swabn(void *ptr, int n)
{
register char *s = (char *)ptr;
register char *e = s + (n-1);
register char tc;
PERL_ARGS_ASSERT_MY_SWABN;
for (n /= 2; n > 0; s++, e--, n--) {
tc = *s;
*s = *e;
*e = tc;
}
}
PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
dVAR;
int p[2];
register I32 This, that;
register 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 (PL_tainting) {
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)
/* Close error pipe automatically if exec works */
fcntl(pp[1], F_SETFD, FD_CLOEXEC);
#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");
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
# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
return my_syspopen4(aTHX_ NULL, 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. */
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
dVAR;
int p[2];
register I32 This, that;
register 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 && PL_tainting) {
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) {
GV* tmpgv;
#undef THIS
#undef THAT
#define THIS that
#define THAT This
if (did_pipes) {
PerlLIO_close(pp[0]);
#if defined(HAS_FCNTL) && defined(F_SETFD)
fcntl(pp[1], F_SETFD, FD_CLOEXEC);
#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
if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
}
#ifdef THREADS_HAVE_PIDS
PL_ppid = (IV)getppid();
#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");
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(atarist) || defined(EPOC)
FILE *popen();
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
PERL_ARGS_ASSERT_MY_POPEN;
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(popen(cmd, mode), 0);
}
#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
#endif /* !DOSISH */
/* this is called in parent before the fork() */
void
Perl_atfork_lock(void)
{
dVAR;
#if defined(USE_ITHREADS)
/* locks must be held in locking order (if any) */
# 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)
{
dVAR;
#if defined(USE_ITHREADS)
/* locks must be released in same order as in atfork_lock() */
# 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;
#else
/* this "canna happen" since nothing should be calling here if !HAS_FORK */
Perl_croak_nocontext("fork() not available");
return 0;
#endif /* HAS_FORK */
}
#ifdef DUMP_FDS
void
Perl_dump_fds(pTHX_ const char *const s)
{
int fd;
Stat_t tmpstatbuf;
PERL_ARGS_ASSERT_DUMP_FDS;
PerlIO_printf(Perl_debug_log,"%s", s);
for (fd = 0; fd < 32; fd++) {
if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
PerlIO_printf(Perl_debug_log," %d",fd);
}
PerlIO_printf(Perl_debug_log,"\n");
return;
}
#endif /* DUMP_FDS */
#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)
{
dVAR;
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 = (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)
{
dVAR;
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)
{
dVAR;
#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(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
dVAR;
Sigsave_t hstat, istat, qstat;
int status;
SV **svp;
Pid_t pid;
Pid_t pid2;
bool close_failed;
dSAVEDERRNO;
svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
SvREFCNT_dec(*svp);
*svp = &PL_sv_undef;
#ifdef OS2
if (pid == -1) { /* Opened by popen. */
return my_syspclose(ptr);
}
#endif
close_failed = (PerlIO_close(ptr) == EOF);
SAVE_ERRNO;
#ifdef UTS
if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
#ifndef PERL_MICRO
rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
#endif
do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
#ifndef PERL_MICRO
rsignal_restore(SIGHUP, &hstat);
rsignal_restore(SIGINT, &istat);
rsignal_restore(SIGQUIT, &qstat);
#endif
if (close_failed) {
RESTORE_ERRNO;
return -1;
}
return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
}
#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)
{
dVAR;
I32 result = 0;
PERL_ARGS_ASSERT_WAIT4PID;
if (!pid)
return -1;
#ifdef PERL_USES_PL_PIDSTATUS
{
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, beacuse 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==-1)?0: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)
{
register 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(atarist) || defined(OS2) || defined(EPOC)
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(register char *to, register const char *from, I32 len, register I32 count)
{
PERL_ARGS_ASSERT_REPEATCPY;
if (len == 1)
memset(to, *from, count);
else if (count) {
register char *p = to;
I32 items, linear, half;
linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
for (items = 0; items < linear; ++items) {
register const char *q = from;
I32 todo;
for (todo = len; todo > 0; todo--)
*p++ = *q++;
}
half = count / 2;
while (items <= half) {
I32 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)
{
dVAR;
const char *xfound = NULL;
char *xfailed = NULL;
char tmpbuf[MAXPATHLEN];
register char *s;
I32 len = 0;
int retval;
char *bufend;
#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
# 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++)) )
{
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));
if (PerlLIO_stat(cur,&PL_statbuf) >= 0
&& !S_ISDIR(PL_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) {
#if defined(atarist) || defined(DOSISH)
for (len = 0; *s
# ifdef atarist
&& *s != ','
# endif
&& *s != ';'; len++, s++) {
if (len < sizeof tmpbuf)
tmpbuf[len] = *s;
}
if (len < sizeof tmpbuf)
tmpbuf[len] = '\0';
#else /* ! (atarist || DOSISH) */
s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
':',
&len);
#endif /* ! (atarist || DOSISH) */
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
# if defined(atarist) || defined(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,&PL_statbuf);
if (S_ISDIR(PL_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(PL_statbuf.st_mode)
&& cando(S_IRUSR,TRUE,&PL_statbuf)
#if !defined(DOSISH)
&& cando(S_IXUSR,TRUE,&PL_statbuf)
#endif
)
{
xfound = tmpbuf; /* bingo! */
break;
}
if (!xfailed)
xfailed = savepv(tmpbuf);
}
#ifndef DOSISH
if (!xfound && !seen_dot && !xfailed &&
(PerlLIO_stat(scriptname,&PL_statbuf) < 0
|| S_ISDIR(PL_statbuf.st_mode)))
#endif
seen_dot = 1; /* Disable message. */
if (!xfound) {
if (flags & 1) { /* do or die? */
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)
{
dVAR;
#if defined(USE_ITHREADS)
# ifdef OLD_PTHREADS_API
pthread_addr_t t;
if (pthread_getspecific(PL_thr_key, &t))
Perl_croak_nocontext("panic: pthread_getspecific");
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)
{
dVAR;
PERL_ARGS_ASSERT_SET_CONTEXT;
#if defined(USE_ITHREADS)
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
# else
if (pthread_setspecific(PL_thr_key, t))
Perl_croak_nocontext("panic: pthread_setspecific");
# 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)
{
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;
}
const char *
Perl_get_no_modify(pTHX)
{
PERL_UNUSED_CONTEXT;
return PL_no_modify;
}
U32 *
Perl_get_opargs(pTHX)
{
PERL_UNUSED_CONTEXT;
return (U32 *)PL_opargs;
}
PPADDR_t*
Perl_get_ppaddr(pTHX)
{
dVAR;
PERL_UNUSED_CONTEXT;
return (PPADDR_t*)PL_ppaddr;
}
#ifndef HAS_GETENV_LEN
char *
Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
{
char * const env_trans = PerlEnv_getenv(env_elem);
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_GETENV_LEN;
if (env_trans)
*len = strlen(env_trans);
return env_trans;
}
#endif
MGVTBL*
Perl_get_vtbl(pTHX_ int vtbl_id)
{
const MGVTBL* result;
PERL_UNUSED_CONTEXT;
switch(vtbl_id) {
case want_vtbl_sv:
result = &PL_vtbl_sv;
break;
case want_vtbl_env:
result = &PL_vtbl_env;
break;
case want_vtbl_envelem:
result = &PL_vtbl_envelem;
break;
case want_vtbl_sig:
result = &PL_vtbl_sig;
break;
case want_vtbl_sigelem:
result = &PL_vtbl_sigelem;
break;
case want_vtbl_pack:
result = &PL_vtbl_pack;
break;
case want_vtbl_packelem:
result = &PL_vtbl_packelem;
break;
case want_vtbl_dbline:
result = &PL_vtbl_dbline;
break;
case want_vtbl_isa:
result = &PL_vtbl_isa;
break;
case want_vtbl_isaelem:
result = &PL_vtbl_isaelem;
break;
case want_vtbl_arylen:
result = &PL_vtbl_arylen;
break;
case want_vtbl_mglob:
result = &PL_vtbl_mglob;
break;
case want_vtbl_nkeys:
result = &PL_vtbl_nkeys;
break;
case want_vtbl_taint:
result = &PL_vtbl_taint;
break;
case want_vtbl_substr:
result = &PL_vtbl_substr;
break;
case want_vtbl_vec:
result = &PL_vtbl_vec;
break;
case want_vtbl_pos:
result = &PL_vtbl_pos;
break;
case want_vtbl_bm:
result = &PL_vtbl_bm;
break;
case want_vtbl_fm:
result = &PL_vtbl_fm;
break;
case want_vtbl_uvar:
result = &PL_vtbl_uvar;
break;
case want_vtbl_defelem:
result = &PL_vtbl_defelem;
break;
case want_vtbl_regexp:
result = &PL_vtbl_regexp;
break;
case want_vtbl_regdata:
result = &PL_vtbl_regdata;
break;
case want_vtbl_regdatum:
result = &PL_vtbl_regdatum;
break;
#ifdef USE_LOCALE_COLLATE
case want_vtbl_collxfrm:
result = &PL_vtbl_collxfrm;
break;
#endif
case want_vtbl_amagic:
result = &PL_vtbl_amagic;
break;
case want_vtbl_amagicelem:
result = &PL_vtbl_amagicelem;
break;
case want_vtbl_backref:
result = &PL_vtbl_backref;
break;
case want_vtbl_utf8:
result = &PL_vtbl_utf8;
break;
default:
result = NULL;
break;
}
return (MGVTBL*)result;
}
I32
Perl_my_fflush_all(pTHX)
{
#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
return PerlIO_flush(NULL);
#else
# if defined(HAS__FWALK)
extern int fflush(FILE *);
/* undocumented, unprototyped, but very useful BSDism */
extern void _fwalk(int (*)(FILE *));
_fwalk(&fflush);
return 0;
# else
# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
long open_max = -1;
# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
# else
# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
open_max = sysconf(_SC_OPEN_MAX);
# else
# ifdef FOPEN_MAX
open_max = FOPEN_MAX;
# else
# ifdef OPEN_MAX
open_max = OPEN_MAX;
# else
# ifdef _NFILE
open_max = _NFILE;
# endif
# endif
# endif
# endif
# endif
if (open_max > 0) {
long i;
for (i = 0; i < open_max; i++)
if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
STDIO_STREAM_ARRAY[i]._file < open_max &&
STDIO_STREAM_ARRAY[i]._flag)
PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
return 0;
}
# endif
SETERRNO(EBADF,RMS_IFI);
return EOF;
# endif
#endif
}
void
Perl_report_wrongway_fh(pTHX_ const GV *gv, char have)
{
if (ckWARN(WARN_IO)) {
const char * const name
= gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
const char * const direction = have == '>' ? "out" : "in";
if (name && *name)
Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for %sput",
name, direction);
else
Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle opened only for %sput", direction);
}
}
void
Perl_report_evil_fh(pTHX_ const GV *gv)
{
const IO *io = gv ? GvIO(gv) : NULL;
const PERL_BITFIELD16 op = PL_op->op_type;
const char *vile;
I32 warn_type;
if (io && IoTYPE(io) == IoTYPE_CLOSED) {
vile = "closed";
warn_type = WARN_CLOSED;
}
else {
vile = "unopened";
warn_type = WARN_UNOPENED;
}
if (ckWARN(warn_type)) {
const char * const name
= gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
const char * const pars =
(const char *)(OP_IS_FILETEST(op) ? "" : "()");
const char * const func =
(const char *)
(op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
PL_op_desc[op]);
const char * const type =
(const char *)
(OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
? "socket" : "filehandle");
if (name && *name) {
Perl_warner(aTHX_ packWARN(warn_type),
"%s%s on %s %s %s", func, pars, vile, type, name);
if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
Perl_warner(
aTHX_ packWARN(warn_type),
"\t(Are you trying to call %s%s on dirhandle %s?)\n",
func, pars, name
);
}
else {
Perl_warner(aTHX_ packWARN(warn_type),
"%s%s on %s %s", func, pars, vile, type);
if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
Perl_warner(
aTHX_ packWARN(warn_type),
"\t(Are you trying to call %s%s on dirhandle?)\n",
func, pars
);
}
}
}
/* XXX Add documentation after final interface and behavior is decided */
/* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
U8 source = *current;
May want to add eg, WARN_REGEX
*/
char
Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
{
U8 result;
if (! isASCII(source)) {
Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
}
result = toCTRL(source);
if (! isCNTRL(result)) {
if (source == '{') {
Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\". If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
}
else if (output_warning) {
U8 clearer[3];
U8 i = 0;
if (! isALNUM(result)) {
clearer[i++] = '\\';
}
clearer[i++] = result;
clearer[i++] = '\0';
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"\"\\c%c\" more clearly written simply as \"%s\"",
source,
clearer);
}
}
return result;
}
bool
Perl_grok_bslash_o(pTHX_ const char *s,
UV *uv,
STRLEN *len,
const char** error_msg,
const bool output_warning)
{
/* Documentation to be supplied when interface nailed down finally
* This returns FALSE if there is an error which the caller need not recover
* from; , otherwise TRUE. In either case the caller should look at *len
* On input:
* s points to a string that begins with 'o', and the previous character
* was a backslash.
* uv points to a UV that will hold the output value, valid only if the
* return from the function is TRUE
* len on success will point to the next character in the string past the
* end of this construct.
* on failure, it will point to the failure
* error_msg is a pointer that will be set to an internal buffer giving an
* error message upon failure (the return is FALSE). Untouched if
* function succeeds
* output_warning says whether to output any warning messages, or suppress
* them
*/
const char* e;
STRLEN numbers_len;
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
| PERL_SCAN_DISALLOW_PREFIX
/* XXX Until the message is improved in grok_oct, handle errors
* ourselves */
| PERL_SCAN_SILENT_ILLDIGIT;
PERL_ARGS_ASSERT_GROK_BSLASH_O;
assert(*s == 'o');
s++;
if (*s != '{') {
*len = 1; /* Move past the o */
*error_msg = "Missing braces on \\o{}";
return FALSE;
}
e = strchr(s, '}');
if (!e) {
*len = 2; /* Move past the o{ */
*error_msg = "Missing right brace on \\o{";
return FALSE;
}
/* Return past the '}' no matter what is inside the braces */
*len = e - s + 2; /* 2 = 1 for the o + 1 for the '}' */
s++; /* Point to first digit */
numbers_len = e - s;
if (numbers_len == 0) {
*error_msg = "Number with no digits";
return FALSE;
}
*uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags,