/*
# Win32::API - Perl Win32 API Import Facility
#
# Version: 0.45
# Date: 10 Mar 2003
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
*/
#define NEED_sv_2pv_flags
#define NEED_newSVpvn_share
#include "ppport.h"
/* see https://rt.cpan.org/Ticket/Display.html?id=80217
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=35124
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=41001
undo this if that bug is ever fixed
*/
#ifdef __CYGWIN__
# define _alloca(size) __builtin_alloca(size)
#endif
/* old (5.8 ish) strawberry perls/Mingws somehow dont ever include malloc.h from
perl.h, so this include is needed for alloca */
#include <malloc.h>
/* some Mingw GCCs use Static TLS on all DLLs, DisableThreadLibraryCalls fails
if DLL has Static TLS, todo, figure out how to disable Static TLS on Mingw
Win32::API never uses it, also Win32::API never uses C++ish exception handling
see https://rt.cpan.org/Public/Bug/Display.html?id=80249 and
http://www.cygwin.com/ml/cygwin-apps/2010-03/msg00075.html
*/
#ifdef _MSC_VER
#define DISABLE_T_L_CALLS STMT_START {if(!DisableThreadLibraryCalls(hinstDLL)) return FALSE;} STMT_END
#else
#define DISABLE_T_L_CALLS STMT_START { 0; } STMT_END
#endif
#ifdef __GNUC__
# define PORTALIGN(x) __attribute__((aligned(x)))
#elif defined(_MSC_VER)
# define PORTALIGN(x) __declspec(align(x))
#else
# error unknown compiler
#endif
/*
when using WIN32_API_DEBUG change the iterations count to 1 in benchmark.t
otherwise the test takes eternity
*/
// #define WIN32_API_DEBUG
#ifdef WIN32_API_DEBUG
# define WIN32_API_DEBUGM(x) x
#else
# define WIN32_API_DEBUGM(x)
#endif
/* turns on profiling, use only for benchmark.t, DO NOT ENABLE in CPAN RELEASE
not all return paths in Call() get the current time (incomplete
implementation), VC only
*/
//#define WIN32_API_PROF
#ifdef WIN32_API_PROF
# define WIN32_API_PROFF(x) x
#else
# define WIN32_API_PROFF(x)
#endif
#ifdef WIN32_API_PROF
LARGE_INTEGER my_freq = {0};
LARGE_INTEGER start = {0};
LARGE_INTEGER loopprep = {0};
LARGE_INTEGER loopstart = {0};
LARGE_INTEGER Call_asm_b4 = {0};
LARGE_INTEGER Call_asm_after = {0};
LARGE_INTEGER return_time = {0};
LARGE_INTEGER return_time2 = {0};
LARGE_INTEGER start_loopprep = {0};
LARGE_INTEGER loopprep_loopstart = {0};
LARGE_INTEGER loopstart_Call_asm_b4 = {0};
LARGE_INTEGER Call_asm_b4_Call_asm_after = {0};
LARGE_INTEGER Call_asm_after_return_time = {0};
# ifndef WIN64
__declspec( naked ) unsigned __int64 rdtsc () {
__asm
{
mov eax, 80000000h
push ebx
cpuid
_emit 0xf
_emit 0x31
pop ebx
retn
}
}
/* note: not CPU affinity locked on x86, visually discard high time iternations */
# define W32A_Prof_GT(x) ((x)->QuadPart = rdtsc())
# else
# define W32A_Prof_GT(x) (QueryPerformanceCounter(x))
# endif
#endif
#ifdef _WIN64
typedef unsigned long long long_ptr;
#else
typedef unsigned long long_ptr;
#endif
#define T_VOID 0
#define T_NUMBER 1
#define T_INTEGER 2
#define T_SHORT 3
#define T_CHAR 4
#define T_NUMCHAR 5
//high processing group
#define T_POINTER 6
#define T_STRUCTURE 7
#define T_POINTERPOINTER 8
#define T_CODE 9
//end of high processing group
#define T_FLOAT 10
//on 32 bits everthing below needs 2 pushes b/c 8 bytes
#define T_DOUBLE 11
//T_QUAD means a pointer is not 64 bits
//T_QUAD is also used in ifdefs around the C code implementing T_QUAD
#ifndef _WIN64
# define T_QUAD 12
# if ! (IVSIZE == 8)
//USEMI64 Perl does not have native i64s, use 8 byte strings or Math::Int64s to emulate
# define USEMI64
# endif
#endif
#define T_FLAG_UNSIGNED (0x80)
#define T_FLAG_NUMERIC (0x40)
typedef char *ApiPointer(void);
typedef long ApiNumber(void);
typedef float ApiFloat(void);
typedef double ApiDouble(void);
typedef void ApiVoid(void);
typedef int ApiInteger(void);
typedef short ApiShort(void);
#ifdef T_QUAD
typedef __int64 ApiQuad(void);
#endif
typedef struct {
union {
LPBYTE b;
char c;
short s;
char *p;
long_ptr l; // 4 bytes on 32bit; 8 bytes on 64bbit; not sure if it is correct
float f;
double d;
#ifdef T_QUAD
__int64 q;
#endif
};
unsigned char t; //1 bytes, union is 8 bytes, put last to avoid padding
/* next 2 members exist because the space is free */
unsigned char unused1;
unsigned short unused2;
unsigned short idx0; /* 0 counted position of this APIPARAM struct in array */
unsigned short idx1; /* 1 counted position of this APIPARAM struct in array */
} APIPARAM;
/* a version of APIPARAM without a "t" type member */
typedef struct {
union {
LPBYTE b;
char c;
short s;
char *p;
long_ptr l; // 4 bytes on 32bit; 8 bytes on 64bbit; not sure if it is correct
float f;
double d;
#ifdef T_QUAD
__int64 q;
#endif
};
} APIPARAM_U;
typedef struct {
SV* object;
int size;
} APISTRUCT;
typedef struct {
SV* object;
} APICALLBACK;
/* bitfield is 4 bytes, low to high diagram\|/
char flags, short stackunwind, char outType
note the stackunwind is unaligned
*/
#define CTRL_IS_MORE 0x10
#define CTRL_HAS_PROTO 0x20
typedef struct {
union {
struct {
unsigned int convention: 3;
unsigned int UseMI64: 1;
unsigned int is_more: 1;
unsigned int has_proto: 1;
#ifndef _WIN64
unsigned int reserved: 2;
/* remember to change Call_asm in API::Call() if this is changed */
unsigned int stackunwind: 16;
#else
unsigned int reserved: 18;
#endif
unsigned int out: 8;
};
U32 whole_bf;
};
U32 inparamlen; /*in units of sizeof(SV *) for comparison to items_sv
param count limited to 65K in API.pm so 32 bit lengths
dont overflow*/
FARPROC ApiFunction;
SV * api; /* a non-ref counted weak RV to the blessed SVPV that holds
APICONTROL, used to optimize method calls on the API obj, the
refcount for the RV is stored in the obj's hidden hash*/
/* this AV is here for no func call look up of it, intypes may be NULL,
refcnt owned by obj's hidden hash*/
AV * intypes;
/* a padding hole here of unknown size */
PORTALIGN(16) APIPARAM param;
} APICONTROL;
#define APICONTROL_CC_STD 0
#define APICONTROL_CC_C 1
/* fastcall, thiscall, regcall, will go here */
#define STATIC_ASSERT(expr) ((void)sizeof(char[1 - 2*!!!(expr)]))
/*
because of unknown alignment where the sentinal is placed after the PV
buffer, put 2 wide nulls, some permutation will be 1 aligned wide null char
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=28679 bug on Strawberry Perl
5.8.9 which includes "gcc (GCC) 3.4.5 (mingw-vista special r3)", reported as
In file included from API.c:28:
API.h:122: warning: malformed '#pragma pack(push[, id], <n>)' - ignored
API.h:130: warning: #pragma pack (pop) encountered without matching #pragma pack
(push, <n>)
This causes 4 extra unused padding bytes to be placed after null2, which can
be a performance degradation
*/
#pragma pack(push)
#pragma pack(push, 1)
typedef struct {
wchar_t null1;
wchar_t null2;
LARGE_INTEGER counter;
} SENTINAL_STRUCT;
#pragma pack(pop)
#pragma pack(pop)
#ifndef mPUSHs
# define mPUSHs(s) PUSHs(sv_2mortal(s))
#endif
#ifndef mXPUSHs
# define mXPUSHs(s) XPUSHs(sv_2mortal(s))
#endif
/* a no grow version of PUSHMARK */
#define W32APUSHMARK(p) \
STMT_START { \
++PL_markstack_ptr; \
*PL_markstack_ptr = (I32)((p) - PL_stack_base); \
} STMT_END
//all callbacks in Call() or helpers for Call() must static assert against this
//this is the ONE and only stack extend done in Call() and its helpers
//for callbacks, this eliminates half a dozen EXTENDs and replaced them
//with static asserts
#define CALL_PL_ST_EXTEND 3
#if PERL_BCDVERSION >= 0x5007001
# define PREP_SV_SET(sv) if(SvTHINKFIRST((sv))) sv_force_normal_flags((sv), SV_COW_DROP_PV)
#else
# define PREP_SV_SET(sv) if(SvTHINKFIRST((sv))) sv_force_normal((sv))
#endif
//C=Callback, CIATP=Callback::IATPatch
#define W32AC_T HV
#define W32ACIATP_T HV
/*no idea why this is defined to 0 but we need this as a label*/
#undef ERROR
#ifndef WC_NO_BEST_FIT_CHARS
# define WC_NO_BEST_FIT_CHARS 0x00000400
#endif
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
/* prototype to pass -Wmissing-prototypes */
STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
if (gv) {
const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
else
Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here. */
Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
}
}
#ifdef PERL_IMPLICIT_CONTEXT
#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
#else
#define croak_xs_usage S_croak_xs_usage
#endif
#endif
#define PERL_VERSION_LE(R, V, S) (PERL_REVISION < (R) || \
(PERL_REVISION == (R) && (PERL_VERSION < (V) ||\
(PERL_VERSION == (V) && (PERL_SUBVERSION <= (S))))))
#if PERL_VERSION_LE(5, 13, 8)
STATIC MAGIC * my_find_mg(SV * sv, int type, const MGVTBL *vtbl){
MAGIC *mg;
for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
if (mg->mg_type == type && mg->mg_virtual == vtbl)
return mg;
}
return NULL;
}
#define mg_findext(a,b,c) my_find_mg(a,b,c)
#endif
#if PERL_VERSION_LE(5, 7, 2)
STATIC MAGIC *
my_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
const char* name, I32 namlen)
{
MAGIC* mg;
if (SvTYPE(sv) < SVt_PVMG) {
(void)SvUPGRADE(sv, SVt_PVMG);
}
Newz(702,mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC(sv) = mg;
/* Some magic sontains a reference loop, where the sv and object refer to
each other. To prevent a reference loop that would prevent such
objects being freed, we look for such loops and if we find one we
avoid incrementing the object refcount. */
if (!obj || obj == sv ||
how == PERL_MAGIC_arylen ||
how == PERL_MAGIC_qr ||
(SvTYPE(obj) == SVt_PVGV &&
(GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
GvFORM(obj) == (CV*)sv)))
{
mg->mg_obj = obj;
}
else {
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
mg->mg_type = how;
mg->mg_len = namlen;
if (name) {
if (namlen > 0)
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY)
mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
else
mg->mg_ptr = (char *) name;
}
mg->mg_virtual = vtable;
mg_magical(sv);
if (SvGMAGICAL(sv))
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
return mg;
}
# ifdef PERL_IMPLICIT_CONTEXT
# define sv_magicext(a,b,c,d,e,f) my_sv_magicext(aTHX_ a,b,c,d,e,f)
# else
# define sv_magicext my_sv_magicext
# endif
#endif
#ifndef SVt_MASK
# define SVt_MASK SVTYPEMASK
#endif