int putenv(char *);
#endif
+#ifdef __amigaos__
+# include "amigaos4/amigaio.h"
+#endif
+
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
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);
#ifdef MDH_HAS_SIZE
header->size = size;
#endif
- ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
+ 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));
- return ptr;
-}
+
+ }
else {
+#ifdef USE_MDH
+ out_of_memory:
+#endif
+ {
#ifndef ALWAYS_NEED_THX
- dTHX;
+ dTHX;
#endif
- if (PL_nomemok)
- return NULL;
- else {
- croak_no_mem();
- }
+ if (PL_nomemok)
+ ptr = NULL;
+ else
+ croak_no_mem();
+ }
}
- /*NOTREACHED*/
+ return ptr;
}
/* paranoid version of system's realloc() */
if (!size) {
safesysfree(where);
- return NULL;
+ ptr = NULL;
}
-
- if (!where)
- return safesysmalloc(size);
+ else if (!where) {
+ ptr = safesysmalloc(size);
+ }
+ else {
#ifdef USE_MDH
- where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
- size += PERL_MEMORY_DEBUG_HEADER_SIZE;
- {
- struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)where;
+ 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);
+ 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);
- }
+ 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;
+ header->size = size;
# endif
- }
+ }
#endif
#ifdef DEBUGGING
- if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
+ 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();
- }
+ 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);
+ ptr = (Malloc_t)PerlMem_realloc(where,size);
#endif
- PERL_ALLOC_CHECK(ptr);
+ 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) {
+ if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
- struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)ptr;
+ 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);
- }
+ 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);
+ 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);
- }
+ 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));
-
+ 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 {
+ if (ptr == NULL) {
+#ifdef USE_MDH
+ out_of_memory:
+#endif
+ {
#ifndef ALWAYS_NEED_THX
- dTHX;
+ dTHX;
#endif
- if (PL_nomemok)
- return NULL;
- else {
- croak_no_mem();
+ if (PL_nomemok)
+ ptr = NULL;
+ else
+ croak_no_mem();
+ }
}
}
- /*NOTREACHED*/
+ return ptr;
}
/* safe version of system's free() */
PERL_ARGS_ASSERT_INSTR;
- /* libc prior to 4.6.27 (late 1994) did not work properly on a NULL
- * 'little' */
- if (!little)
- return (char*)big;
return strstr((char*)big, (char*)little);
}
=for apidoc fbm_compile
-Analyses the string in order to make fast searches on it using fbm_instr()
+Analyses the string in order to make fast searches on it using C<fbm_instr()>
-- the Boyer-Moore algorithm.
=cut
Returns the location of the SV in the string delimited by C<big> and
C<bigend>. 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
+does not have to be C<fbm_compiled>, but the search will not be as fast
then.
=cut
/*
=for apidoc foldEQ
-Returns true if the leading len bytes of the strings s1 and s2 are the same
+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.
/*
=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.
+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
*/
=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
+which is shared between threads. (With the specific difference that a C<NULL>
pointer is not acceptable)
=cut
if (o->op_flags & OPf_KIDS) {
const OP *kid;
- for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(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
#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
{
char *ws;
- int wi;
+ 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")) &&
- (wi = grok_atou(ws, NULL)) > 0) {
- Perl_dump_c_backtrace(aTHX_ Perl_debug_log, wi, 1);
+ 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
*/
const COP *cop =
- closest_cop(PL_curcop, OP_SIBLING(PL_curcop), PL_op, FALSE);
+ closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
if (!cop)
cop = PL_curcop;
=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
+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>.
SV *exarg;
ENTER;
+ save_re_context();
if (warn) {
SAVESPTR(*hook);
*hook = NULL;
{
PERL_ARGS_ASSERT_DIE_SV;
croak_sv(baseex);
- assert(0); /* NOTREACHED */
+ /* NOTREACHED */
NORETURN_FUNCTION_END;
}
#ifdef _MSC_VER
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
NORETURN_FUNCTION_END;
}
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
NORETURN_FUNCTION_END;
}
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
}
{
dVAR;
PERL_ARGS_ASSERT_VWARNER;
- if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
+ 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) {
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
dVAR;
+#if defined(__amigaos4__)
+ amigaos4_obtain_environ(__FUNCTION__);
+#endif
#ifdef USE_ITHREADS
/* only parent thread can modify process environment */
if (PL_curinterp == aTHX)
environ[i] = environ[i+1];
i++;
}
+#if defined(__amigaos4__)
+ goto my_setenv_out;
+#else
return;
+#endif
}
if (!environ[i]) { /* does not exist yet */
environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
}
#endif
}
+#if defined(__amigaos4__)
+my_setenv_out:
+ amigaos4_release_environ(__FUNCTION__);
+#endif
}
#else /* WIN32 || NETWARE */
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(NETWARE) && !defined(__LIBCATAMOUNT__)
+#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;
/* Close parent's end of error status pipe (if any) */
if (did_pipes) {
PerlLIO_close(pp[0]);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
+#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
}
- /* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
+ /* 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)
{
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");
#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(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
*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()
+ 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. */
}
#endif
-#if defined(OS2)
+#if defined(OS2) || defined(__amigaos4__)
+# if defined(__amigaos4__) && defined(pclose)
+# undef pclose
+# endif
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
=for apidoc getcwd_sv
-Fill the sv with current working directory
+Fill C<sv> with current working directory
=cut
*/
/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
* rewritten again by dougm, optimized for use with xs TARG, and to prefer
* getcwd(3) if available
- * Comments from the orignal:
+ * Comments from the original:
* This is a faster version of getcwd. It's also more dangerous
* because you might chdir out of a directory that you can't chdir
* back into. */
Dummy routine which "shares" an SV when there is no sharing module present.
Or "locks" it. Or "unlocks" it. In other
words, ignores its single SV argument.
-Exists to avoid test for a NULL function pointer and because it could
+Exists to avoid test for a C<NULL> function pointer and because it could
potentially warn under some level of strict-ness.
=cut
Dummy routine which reports that object can be destroyed when there is no
sharing module present. It ignores its single SV argument, and returns
-'true'. Exists to avoid test for a NULL function pointer and because it
+'true'. Exists to avoid test for a C<NULL> function pointer and because it
could potentially warn under some level of strict-ness.
=cut
if (*p) {
if (isDIGIT(*p)) {
const char* endptr;
- opt = (U32) grok_atou(p, &endptr);
- p = endptr;
- if (*p && *p != '\n' && *p != '\r') {
- if(isSPACE(*p)) goto the_end_of_the_opts_parser;
- else
- Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
- }
- }
- else {
+ UV uv;
+ if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
+ opt = (U32)uv;
+ p = endptr;
+ if (p && *p && *p != '\n' && *p != '\r') {
+ if (isSPACE(*p))
+ goto the_end_of_the_opts_parser;
+ else
+ Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+ }
+ }
+ }
+ else {
for (; *p; p++) {
switch (*p) {
case PERL_UNICODE_STDIN:
int fd;
#endif
U32 u;
-#ifdef VMS
- /* when[] = (low 32 bits, high 32 bits) of time since epoch
- * in 100-ns units, typically incremented ever 10 ms. */
- unsigned int when[2];
-#else
-# ifdef HAS_GETTIMEOFDAY
+#ifdef HAS_GETTIMEOFDAY
struct timeval when;
-# else
+#else
Time_t when;
-# endif
#endif
/* This test is an escape hatch, this symbol isn't set by Configure. */
* if there isn't enough entropy available. You can compile with
* PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
* is enough real entropy to fill the seed. */
-# define PERL_RANDOM_DEVICE "/dev/urandom"
+# ifdef __amigaos4__
+# define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
+# else
+# define PERL_RANDOM_DEVICE "/dev/urandom"
+# endif
#endif
fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
if (fd != -1) {
}
#endif
-#ifdef VMS
- _ckvmssts(sys$gettim(when));
- u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
-#else
-# ifdef HAS_GETTIMEOFDAY
+#ifdef HAS_GETTIMEOFDAY
PerlProc_gettimeofday(&when,NULL);
u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
-# else
+#else
(void)time(&when);
u = (U32)SEED_C1 * when;
-# endif
#endif
u += SEED_C3 * (U32)PerlProc_getpid();
u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
#ifdef PERL_MEM_LOG
-/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
+/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
* the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
* given, and you supply your own implementation.
*
* The default implementation reads a single env var, PERL_MEM_LOG,
* expecting one or more of the following:
*
- * \d+ - fd fd to write to : must be 1st (grok_atou)
+ * \d+ - fd fd to write to : must be 1st (grok_atoUV)
* 'm' - memlog was PERL_MEM_LOG=1
* 's' - svlog was PERL_SV_LOG=1
* 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
{
STRLEN len;
const char* endptr;
- int fd = grok_atou(pmlenv, &endptr); /* Ignore endptr. */
- if (!fd)
+ int fd;
+ UV uv;
+ if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
+ && uv && uv <= PERL_INT_MAX
+ ) {
+ fd = (int)uv;
+ } else {
fd = PERL_MEM_LOG_FD;
+ }
if (strchr(pmlenv, 't')) {
len = my_snprintf(buf, sizeof(buf),
/*
=for apidoc quadmath_format_single
-quadmath_snprintf() is very strict about its format string and will
-fail, returning -1, if the format is invalid. It acccepts exactly
+C<quadmath_snprintf()> is very strict about its C<format> string and will
+fail, returning -1, if the format is invalid. It accepts exactly
one format spec.
-quadmath_format_single() checks that the intended single spec looks
+C<quadmath_format_single()> checks that the intended single spec looks
sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
and has C<Q> before it. This is not a full "printf syntax check",
just the basics.
Returns the format if it is valid, NULL if not.
-quadmath_format_single() can and will actually patch in the missing
+C<quadmath_format_single()> can and will actually patch in the missing
C<Q>, if necessary. In this case it will return the modified copy of
the format, B<which the caller will need to free.>
/*
=for apidoc quadmath_format_needed
-quadmath_format_needed() returns true if the format string seems to
-contain at least one non-Q-prefixed %[efgaEFGA] format specifier,
+C<quadmath_format_needed()> returns true if the C<format> string seems to
+contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
or returns false otherwise.
The format specifier detection is not complete printf-syntax detection,
but it should catch most common cases.
If true is returned, those arguments B<should> in theory be processed
-with quadmath_snprintf(), but in case there is more than one such
+with C<quadmath_snprintf()>, but in case there is more than one such
format specifier (see L</quadmath_format_single>), and if there is
anything else beyond that one (even just a single byte), they
-B<cannot> be processed because quadmath_snprintf() is very strict,
+B<cannot> be processed because C<quadmath_snprintf()> is very strict,
accepting only one format spec, and nothing else.
In this case, the code should probably fail.
#endif /* PERL_IMPLICIT_CONTEXT */
-/* The meaning of the varargs is determined U32 key arg. This is not a format
- string. The U32 key is assembled with HS_KEY.
-
- v_my_perl arg is "PerlInterpreter * my_perl" if PERL_IMPLICIT_CONTEXT and
- otherwise "CV * cv" (boot xsub's CV *). v_my_perl will catch where a threaded
- future perl526.dll calling IO.dll for example, and IO.dll was linked with
- threaded perl524.dll, and both perl526.dll and perl524.dll are in %PATH and
- the Win32 DLL loader sucessfully can load IO.dll into the process but
- simultaniously it loaded a interp of a different version into the process,
- and XS code will naturally pass SV*s created by perl524.dll for perl526.dll
- to use through perl526.dll's my_perl->Istack_base.
-
- v_my_perl (v=void) can not be the first arg since then key will be out of
- place in a threaded vs non-threaded mixup and analyzing the key number's
- bitfields won't reveal the problem since it will be a valid key
- (unthreaded perl) on interp side, but croak reports the XS mod's key as
- gibberish (it is really my_perl ptr) (threaded XS mod), or if threaded perl
- and unthreaded XS module, threaded perl will look at uninit C stack or uninit
- register to get var key (remember it assumes 1st arg is interp cxt).
-
-Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
-[U32 items, U32 ax], [char * api_version], [char * xs_version]) */
+/* Perl_xs_handshake():
+ implement the various XS_*_BOOTCHECK macros, which are added to .c
+ files by ExtUtils::ParseXS, to check that the perl the module was built
+ with is binary compatible with the running perl.
+
+ usage:
+ Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
+ [U32 items, U32 ax], [char * api_version], [char * xs_version])
+
+ The meaning of the varargs is determined the U32 key arg (which is not
+ a format string). The fields of key are assembled by using HS_KEY().
+
+ Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
+ "PerlInterpreter *" and represents the callers context; otherwise it is
+ of type "CV *", and is the boot xsub's CV.
+
+ v_my_perl will catch where a threaded future perl526.dll calling IO.dll
+ for example, and IO.dll was linked with threaded perl524.dll, and both
+ perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
+ successfully can load IO.dll into the process but simultaneously it
+ loaded an interpreter of a different version into the process, and XS
+ code will naturally pass SV*s created by perl524.dll for perl526.dll to
+ use through perl526.dll's my_perl->Istack_base.
+
+ v_my_perl cannot be the first arg, since then 'key' will be out of
+ place in a threaded vs non-threaded mixup; and analyzing the key
+ number's bitfields won't reveal the problem, since it will be a valid
+ key (unthreaded perl) on interp side, but croak will report the XS mod's
+ key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
+ it's a threaded perl and an unthreaded XS module, threaded perl will
+ look at an uninit C stack or an uninit register to get 'key'
+ (remember that it assumes that the 1st arg is the interp cxt).
+
+ 'file' is the source filename of the caller.
+*/
+
I32
Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
{
if(UNLIKELY(got != need)) {
bad_handshake:/* recycle branch and string from above */
if(got != (void *)HSf_NOCHK)
- noperl_die("%s: Invalid handshake key got %p"
- " needed %p, binaries are mismatched",
+ noperl_die("%s: loadable library and perl binaries are mismatched"
+ " (got handshake key %p, needed %p)\n",
file, got, need);
}
SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
PL_xsubfilename = file; /* so the old name must be restored for
additional XSUBs to register themselves */
- (void)gv_fetchfile(file);
+ /* XSUBs can't be perl lang/perl5db.pl debugged
+ if (PERLDB_LINE_OR_SAVESRC)
+ (void)gv_fetchfile(file); */
}
if(key & HSf_POPMARK) {
U32 xsverlen;
assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
if((xsverlen = HS_GETXSVERLEN(key)))
- Perl_xs_version_bootcheck(aTHX_
+ S_xs_version_bootcheck(aTHX_
items, ax, va_arg(args, char*), xsverlen);
}
va_end(args);
return ax;
}
-void
-Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+
+STATIC void
+S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
STRLEN xs_len)
{
SV *sv;
return dir->dd_fd;
#else
Perl_croak_nocontext(PL_no_func, "dirfd");
- assert(0); /* NOT REACHED */
+ NOT_REACHED; /* NOTREACHED */
return 0;
#endif
}
PERL_ARGS_ASSERT_DRAND48_INIT_R;
#ifdef PERL_DRAND48_QUAD
- *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
+ *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16);
#else
random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
random_state->seed[1] = (U16) seed;
/* BFD open and scan only if the filename changed. */
if (ctx->fname_prev == NULL ||
strNE(dl_info->dli_fname, ctx->fname_prev)) {
+ if (ctx->abfd) {
+ bfd_close(ctx->abfd);
+ }
ctx->abfd = bfd_openr(dl_info->dli_fname, 0);
if (ctx->abfd) {
if (bfd_check_format(ctx->abfd, bfd_object)) {
const char* source_name_end;
const char* source_line_end;
const char* close_paren;
+ UV uv;
+
/* Skip trailing whitespace. */
while (p > start && isspace(*p)) p--;
/* Now we should be at the close paren. */
return NULL;
p++;
*source_name_size = source_name_end - p;
- *source_line = grok_atou(source_number_start, &source_line_end);
- if (source_line_end != close_paren)
- return NULL;
- return p;
+ if (grok_atoUV(source_number_start, &uv, &source_line_end)
+ && source_line_end == close_paren
+ && uv <= MAX_STRLEN
+ ) {
+ *source_line = (STRLEN)uv;
+ return p;
+ }
+ return NULL;
}
/* Given a raw frame, read a pipe from the symbolicator (that's the
=for apidoc get_c_backtrace
Collects the backtrace (aka "stacktrace") into a single linear
-malloced buffer, which the caller B<must> Perl_free_c_backtrace().
+malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>.
-Scans the frames back by depth + skip, then drops the skip innermost,
-returning at most depth frames.
+Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost,
+returning at most C<depth> frames.
=cut
*/
}
#ifdef USE_BFD
Safefree(symbol_names);
+ if (bfd_ctx.abfd) {
+ bfd_close(bfd_ctx.abfd);
+ }
#endif
Safefree(source_lines);
Safefree(source_name_sizes);
/*
=for apidoc get_c_backtrace_dump
-Returns a SV a dump of |depth| frames of the call stack, skipping
-the |skip| innermost ones. depth of 20 is usually enough.
+Returns a SV containing a dump of C<depth> frames of the call stack, skipping
+the C<skip> innermost ones. C<depth> of 20 is usually enough.
The appended output looks like:
The fields are tab-separated. The first column is the depth (zero
being the innermost non-skipped frame). In the hex:offset, the hex is
-where the program counter was in S_parse_body, and the :offset (might
-be missing) tells how much inside the S_parse_body the program counter was.
+where the program counter was in C<S_parse_body>, and the :offset (might
+be missing) tells how much inside the C<S_parse_body> the program counter was.
-The util.c:1716 is the source code file and line number.
+The C<util.c:1716> is the source code file and line number.
-The /usr/bin/perl is obvious (hopefully).
+The F</usr/bin/perl> is obvious (hopefully).
Unknowns are C<"-">. Unknowns can happen unfortunately quite easily:
if the platform doesn't support retrieving the information;
/*
=for apidoc dump_c_backtrace
-Dumps the C backtrace to the given fp.
+Dumps the C backtrace to the given C<fp>.
Returns true if a backtrace could be retrieved, false if not.
#endif /* #ifdef USE_C_BACKTRACE */
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/