#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 {
#ifndef ALWAYS_NEED_THX
dTHX;
#endif
if (PL_nomemok)
- return NULL;
- else {
+ 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);
+ 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) {
#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() */
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
#ifdef USE_MDH
- where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
+ Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
{
struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)where;
+ = (struct perl_memory_debug_header *)where_intrn;
# ifdef MDH_HAS_SIZE
const MEM_SIZE size = header->size;
maybe_protect_ro(header->prev);
maybe_protect_rw(header);
# ifdef PERL_POISON
- PoisonNew(where, size, char);
+ PoisonNew(where_intrn, size, char);
# endif
/* Trigger the duplicate free warning. */
header->next = NULL;
# endif
# ifdef PERL_DEBUG_READONLY_COW
- if (munmap(where, size)) {
+ if (munmap(where_intrn, size)) {
perror("munmap failed");
abort();
}
# endif
}
-#endif
+#else
+ Malloc_t where_intrn = where;
+#endif /* USE_MDH */
#ifndef PERL_DEBUG_READONLY_COW
- PerlMem_free(where);
+ PerlMem_free(where_intrn);
#endif
}
}
}
}
-char *
-Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
-{
- PERL_ARGS_ASSERT_SCREAMINSTR;
- PERL_UNUSED_ARG(bigstr);
- PERL_UNUSED_ARG(littlestr);
- PERL_UNUSED_ARG(start_shift);
- PERL_UNUSED_ARG(end_shift);
- PERL_UNUSED_ARG(old_posp);
- PERL_UNUSED_ARG(last);
-
- /* This function must only ever be called on a scalar with study magic,
- but those do not happen any more. */
- Perl_croak(aTHX_ "panic: screaminstr");
- NORETURN_FUNCTION_END;
-}
-
/*
=for apidoc foldEQ
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
*/
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;
=cut
*/
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die_sv(pTHX_ SV *baseex)
{
PERL_ARGS_ASSERT_DIE_SV;
croak_sv(baseex);
- assert(0); /* NOTREACHED */
+ /* NOTREACHED */
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
/*
=for apidoc Am|OP *|die|const char *pat|...
*/
#if defined(PERL_IMPLICIT_CONTEXT)
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die_nocontext(const char* pat, ...)
{
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
#endif /* PERL_IMPLICIT_CONTEXT */
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die(pTHX_ const char* pat, ...)
{
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
/*
=for apidoc Am|void|croak_sv|SV *baseex
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);
}
Perl_ckwarn(pTHX_ U32 w)
{
/* If lexical warnings have not been set, use $^W. */
- if (isLEXWARN_off)
- return PL_dowarn & G_WARN_ON;
+ if (isLEXWARN_off) {
+ /* TODO: Hardcoding this here sucks, see the commit that added this */
+ if (w == WARN_VOID_UNUSUAL)
+ return FALSE;
+ else
+ return PL_dowarn & G_WARN_ON;
+ }
return ckwarn_common(w);
}
Perl_ckwarn_d(pTHX_ U32 w)
{
/* If lexical warnings have not been set then default classes warn. */
- if (isLEXWARN_off)
- return TRUE;
+ if (isLEXWARN_off) {
+ /* TODO: Hardcoding this here sucks, see the commit that added this */
+ if (w == WARN_VOID_UNUSUAL)
+ return FALSE;
+ else
+ 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_ALL) {
+ /* TODO: Hardcoding this here sucks, see the commit that added this */
+ if (w == WARN_VOID_UNUSUAL)
+ return FALSE;
+ else
+ return TRUE;
+ }
if (PL_curcop->cop_warnings == pWARN_NONE)
return FALSE;
PerlLIO_close(pp[0]);
return PerlIO_fdopen(p[This], mode);
#else
-# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
+# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
return my_syspopen4(aTHX_ NULL, mode, n, args);
+# elif defined(WIN32)
+ return win32_popenlist(mode, n, args);
# else
Perl_croak(aTHX_ "List form of piped open not implemented");
return (PerlIO *) NULL;
#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
#endif /* PERL_IMPLICIT_CONTEXT */
-void
-Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+
+/* 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, ...)
+{
+ va_list args;
+ U32 items, ax;
+ void * got;
+ void * need;
+#ifdef PERL_IMPLICIT_CONTEXT
+ dTHX;
+ tTHX xs_interp;
+#else
+ CV* cv;
+ SV *** xs_spp;
+#endif
+ PERL_ARGS_ASSERT_XS_HANDSHAKE;
+ va_start(args, file);
+
+ got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
+ need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
+ if (UNLIKELY(got != need))
+ goto bad_handshake;
+/* try to catch where a 2nd threaded perl interp DLL is loaded into a process
+ by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
+ 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
+ dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
+ passed to the XS DLL */
+#ifdef PERL_IMPLICIT_CONTEXT
+ xs_interp = (tTHX)v_my_perl;
+ got = xs_interp;
+ need = my_perl;
+#else
+/* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
+ loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
+ but the DynaLoder/Perl that started the process and loaded the XS DLL is
+ unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
+ through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
+ location in the unthreaded perl binary) stored in CV * to figure out if this
+ Perl_xs_handshake was called by the same pp_entersub */
+ cv = (CV*)v_my_perl;
+ xs_spp = (SV***)CvHSCXT(cv);
+ got = xs_spp;
+ need = &PL_stack_sp;
+#endif
+ if(UNLIKELY(got != need)) {
+ bad_handshake:/* recycle branch and string from above */
+ if(got != (void *)HSf_NOCHK)
+ noperl_die("%s: loadable library and perl binaries are mismatched"
+ " (got handshake key %p, needed %p)\n",
+ file, got, need);
+ }
+
+ if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
+ 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);
+ }
+
+ if(key & HSf_POPMARK) {
+ ax = POPMARK;
+ { SV **mark = PL_stack_base + ax++;
+ { dSP;
+ items = (I32)(SP - MARK);
+ }
+ }
+ } else {
+ items = va_arg(args, U32);
+ ax = va_arg(args, U32);
+ }
+ {
+ U32 apiverlen;
+ assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
+ if((apiverlen = HS_GETAPIVERLEN(key))) {
+ char * api_p = va_arg(args, char*);
+ if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
+ || memNE(api_p, "v" PERL_API_VERSION_STRING,
+ sizeof("v" PERL_API_VERSION_STRING)-1))
+ Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s",
+ api_p, SVfARG(PL_stack_base[ax + 0]),
+ "v" PERL_API_VERSION_STRING);
+ }
+ }
+ {
+ U32 xsverlen;
+ assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
+ if((xsverlen = HS_GETXSVERLEN(key)))
+ S_xs_version_bootcheck(aTHX_
+ items, ax, va_arg(args, char*), xsverlen);
+ }
+ va_end(args);
+ return ax;
+}
+
+
+STATIC void
+S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
STRLEN xs_len)
{
SV *sv;
}
}
-void
-Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
- STRLEN api_len)
-{
- SV *xpt = NULL;
- SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
- SV *runver;
-
- PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
-
- /* This might croak */
- compver = upg_version(compver, 0);
- /* This should never croak */
- runver = new_version(PL_apiversion);
- if (vcmp(compver, runver)) {
- SV *compver_string = vstringify(compver);
- SV *runver_string = vstringify(runver);
- xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
- " of %"SVf" does not match %"SVf,
- SVfARG(compver_string), SVfARG(module),
- SVfARG(runver_string));
- Perl_sv_2mortal(aTHX_ xpt);
-
- SvREFCNT_dec(compver_string);
- SvREFCNT_dec(runver_string);
- }
- SvREFCNT_dec(runver);
- if (xpt)
- Perl_croak_sv(aTHX_ xpt);
-}
-
/*
=for apidoc my_strlcat
return dir->dd_fd;
#else
Perl_croak_nocontext(PL_no_func, "dirfd");
- assert(0); /* NOT REACHED */
+ NOT_REACHED; /* NOT REACHED */
return 0;
#endif
}
/* 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)) {
}
#ifdef USE_BFD
Safefree(symbol_names);
+ if (bfd_ctx.abfd) {
+ bfd_close(bfd_ctx.abfd);
+ }
#endif
Safefree(source_lines);
Safefree(source_name_sizes);
https://perl5.git.perl.org / perl5.git / blobdiff