"

 COPYRIGHT (c) 2004 by eXept Software AG

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

"{ Package: 'stx:libbasic' }"

"{ NameSpace: Smalltalk }"

ExternalFunction subclass:#ExternalLibraryFunction

	instanceVariableNames:'flags moduleName returnType argumentTypes owningClass'

	classVariableNames:'DLLPATH FLAG_VIRTUAL FLAG_NONVIRTUAL FLAG_OBJECTIVEC FLAG_ASYNC

		FLAG_UNLIMITEDSTACK FLAG_RETVAL_IS_CONST CALLTYPE_MASK

		CALLTYPE_API CALLTYPE_C CALLTYPE_OLE CALLTYPE_V8 CALLTYPE_V9

		CALLTYPE_UNIX64 DllMapping Verbose LastModuleHandleHolder

		LastModuleHandleName'

	poolDictionaries:''

	category:'System-Support'

!

!ExternalLibraryFunction primitiveDefinitions!

%{

#define VERBOSE

#ifdef HAVE_FFI

# include <ffi.h>

# define MAX_ARGS    128

# ifdef USE_STANDARD_FFI

#  define __get_ffi_type_sint() &ffi_type_sint

#  define __get_ffi_type_sint8() &ffi_type_sint8

#  define __get_ffi_type_sint16() &ffi_type_sint16

#  define __get_ffi_type_sint32() &ffi_type_sint32

#  define __get_ffi_type_sint64() &ffi_type_sint64

#  define __get_ffi_type_uint() &ffi_type_uint

#  define __get_ffi_type_uint8() &ffi_type_uint8

#  define __get_ffi_type_uint16() &ffi_type_uint16

#  define __get_ffi_type_uint32() &ffi_type_uint32

#  define __get_ffi_type_uint64() &ffi_type_uint64

#  define __get_ffi_type_float() &ffi_type_float

#  define __get_ffi_type_double() &ffi_type_double

#  define __get_ffi_type_void() &ffi_type_void

#  define __get_ffi_type_pointer() &ffi_type_pointer

# else

   extern ffi_type *__get_ffi_type_sint();

   extern ffi_type *__get_ffi_type_sint8();

   extern ffi_type *__get_ffi_type_sint16();

   extern ffi_type *__get_ffi_type_sint32();

   extern ffi_type *__get_ffi_type_sint64();

   extern ffi_type *__get_ffi_type_uint();

   extern ffi_type *__get_ffi_type_uint8();

   extern ffi_type *__get_ffi_type_uint16();

   extern ffi_type *__get_ffi_type_uint32();

   extern ffi_type *__get_ffi_type_uint64();

   extern ffi_type *__get_ffi_type_float();

   extern ffi_type *__get_ffi_type_double();

   extern ffi_type *__get_ffi_type_void();

   extern ffi_type *__get_ffi_type_pointer();

# endif

#endif

%}

! !

!ExternalLibraryFunction class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 2004 by eXept Software AG

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

documentation

"

    instances of me are used to interface to external library functions (as found in a dll/shared object).

    Inside a method, when a special external-call pragma such as:

	<api: bool MessageBeep(uint)>

    is encountered by the parser, the compiler generates a call via

	<correspondingExternalLibraryFunctionObject> invokeWithArguments: argumentArray.

    In the invoke method, the library is checked to be loaded (and loaded if not already),

    the arguments are converted to C and pushed onto the C-stack, the function is called,

    and finally, the return value is converted back from C to a smalltalk object.

    The parser supports the call-syntax of various other smalltalk dialects:

	Squeak / ST-X:

	    <cdecl:   [async] [virtual|nonVirtual][const] returnType functionNameStringOrIndex ( argType1..argTypeN ) module: moduleName >

	    <apicall: [async] [virtual|nonVirtual][const] returnType functionNameStringOrIndex ( argType1..argTypeN ) module: moduleName >

	Dolphin:

	    <stdcall: [virtual|nonVirtual][const] returnType functionNameStringOrIndex argType1..argTypeN>

	    <cdecl:   [virtual|nonVirtual][const] returnType functionNameStringOrIndex argType1..argTypeN>

	ST/V:

	    <api: functionName argType1 .. argTypeN returnType>

	    <ccall: functionName argType1 .. argTypeN returnType>

	    <ole: vFunctionIndex argType1 .. argTypeN returnType>

	VisualWorks:

	    <c: ...>

	    <c: #define NAME value>

"

!

example

"

								[exBegin]

	|f|

	f := ExternalLibraryFunction new.

	f beCallTypeWINAPI.

	f name:'MessageBeep'

	  module:'user32.dll'

	  returnType:#boolean

	  argumentTypes:#(uint).

	f invokeWith:1.

								[exEnd]

  Synchronous vs. Asynchronous calls:

    by default, foreign function calls are synchronous, effectively blocking the whole ST/X system

    (that is by purpose,´because most C-code is not prepared for being interrupted, and also, normal

     code is not prepared for a garbage collector to move objects around, while another C thread might

     access the data...).

    Therefore, the following will block all ST/X activity for 10 seconds

    (try interacting with the launcher while the Sleep is performing):

								[exBegin]

	|f|

	f := ExternalLibraryFunction new.

	f beCallTypeWINAPI.

	f name:'Sleep'

	  module:'kernel32.dll'

	  returnType:#void

	  argumentTypes:#(uint).

	f invokeWith:10000.

								[exEnd]

    if you know what you do and you do not pass any possibly moving objects (such as strings) as argument,

    the call can be made asynchronous. In that case, ONLY the calling thread will be blocked; all other smalltalk

    threads wil continue to execute.

    (try interacting now with the launcher while the Sleep is performing):

								[exBegin]

	|f|

	f := ExternalLibraryFunction new.

	f beCallTypeWINAPI.

	f beAsync.

	f name:'Sleep'

	  module:'kernel32.dll'

	  returnType:#void

	  argumentTypes:#(uint).

	f invokeWith:10000.

								[exEnd]

"

! !

!ExternalLibraryFunction class methodsFor:'instance creation'!

name:functionName module:moduleName returnType:returnType argumentTypes:argTypes

    ^ self new

	name:functionName module:moduleName

	returnType:returnType argumentTypes:argTypes

    "Created: / 01-08-2006 / 15:19:08 / cg"

! !

!ExternalLibraryFunction class methodsFor:'class initialization'!

addToDllPath:aDirectoryPathName

    "can be used during initialization, to add more places for dll-loading"

    |oldPath newPath|

    oldPath := self dllPath.

    (oldPath includes:aDirectoryPathName) ifFalse:[

    ]

!

dllMapping

    "allows for dll's to be replaced,

     for example, if you want to use the mozilla sqlite dll

	C:\Program Files\Mozilla Firefox\mozsqlite3.dll

     for the sqlite3, execute:

	ExternalLibraryFunction

	    dllMapping at:'sqlite3'

	    put: 'C:\Program Files\Mozilla Firefox\mozsqlite3.dll'

    "

    DllMapping isNil ifTrue:[

	DllMapping := Dictionary new.

    ].

    ^ DllMapping

    "Created: / 10-04-2012 / 12:21:45 / cg"

!

dllPath

    ^ DLLPATH

!

dllPath:aCollectionOfDirectoryPathNames

    DLLPATH := aCollectionOfDirectoryPathNames

!

initialize

    "using inline access to corresponding c--defines to avoid duplicate places of knowledge"

    DLLPATH isNil ifTrue:[

	DLLPATH := #('.').

%{

#ifndef __SCHTEAM__

	@global(FLAG_VIRTUAL) = __MKSMALLINT(__EXTL_FLAG_VIRTUAL);                  // a virtual c++ call

	@global(FLAG_NONVIRTUAL) = __MKSMALLINT(__EXTL_FLAG_NONVIRTUAL);            // a non-virtual c++ call

	@global(FLAG_OBJECTIVEC) = __MKSMALLINT(__EXTL_FLAG_OBJECTIVEC);            // an objectiveC message send

	@global(FLAG_UNLIMITEDSTACK) = __MKSMALLINT(__EXTL_FLAG_UNLIMITEDSTACK);    // unlimitedstack under unix

	@global(FLAG_ASYNC) = __MKSMALLINT(__EXTL_FLAG_ASYNC);                      // async under win32

	@global(FLAG_RETVAL_IS_CONST) = __MKSMALLINT(__EXTL_FLAG_RETVAL_IS_CONST);  // return value is not to be registered for finalization

	@global(CALLTYPE_API) = __MKSMALLINT(__EXTL_CALLTYPE_API);                  // WINAPI-call (win32 only)

	@global(CALLTYPE_C) = __MKSMALLINT(__EXTL_CALLTYPE_C);                      // regular C-call (the default)

	@global(CALLTYPE_V8) = __MKSMALLINT(__EXTL_CALLTYPE_V8);                    // v8 call (sparc only)

	@global(CALLTYPE_V9) = __MKSMALLINT(__EXTL_CALLTYPE_V9);                    // v9 call (sparc only)

	@global(CALLTYPE_UNIX64) = __MKSMALLINT(__EXTL_CALLTYPE_UNIX64);            // unix64 call (alpha only)

	@global(CALLTYPE_MASK) = __MKSMALLINT(__EXTL_CALLTYPE_MASK);

#endif

%}

    ].

    "

     self initialize

    "

    "Modified: / 03-10-2006 / 21:27:47 / cg"

!

removeFromDllPath:aDirectoryPathName

    "remove added places from dll-loading"

    |oldPath|

    oldPath := self dllPath.

    self dllPath:(oldPath asOrderedCollection copyWithout:aDirectoryPathName)

    "

     self dllPath.

     self addToDllPath:'C:\aaa\bbb'.

     self dllPath.

     self removeFromDllPath:'C:\aaa\bbb'.

     self dllPath.

    "

! !

!ExternalLibraryFunction class methodsFor:'constants'!

callTypeAPI

    ^ CALLTYPE_API

    "Modified: / 01-08-2006 / 13:44:41 / cg"

!

callTypeC

    ^ CALLTYPE_C

    "Modified: / 01-08-2006 / 13:44:49 / cg"

!

callTypeCDecl

    ^ CALLTYPE_C

    "Modified: / 01-08-2006 / 13:44:52 / cg"

!

callTypeMASK

    ^ CALLTYPE_MASK

    "Modified: / 01-08-2006 / 13:44:57 / cg"

!

callTypeOLE

    ^ CALLTYPE_OLE

    "Modified: / 01-08-2006 / 13:44:57 / cg"

! !

!ExternalLibraryFunction class methodsFor:'debugging'!

verbose:aBoolean

    "turn on/off tracing of calls"

    Verbose := aBoolean

    "

     ExternalLibraryFunction verbose:true

    "

    "Created: / 30-03-2016 / 17:28:23 / cg"

! !

!ExternalLibraryFunction class methodsFor:'type name mapping'!

ffiTypeSymbolForType:aType

    "map type to one of the ffi-supported ones:

    "

    aType == #sint8           ifTrue:[^ aType ].

    aType == #sint16          ifTrue:[^ aType ].

    aType == #sint32          ifTrue:[^ aType ].

    aType == #sint64          ifTrue:[^ aType ].

    aType == #uint8           ifTrue:[^ aType ].

    aType == #uint16          ifTrue:[^ aType ].

    aType == #uint32          ifTrue:[^ aType ].

    aType == #uint64          ifTrue:[^ aType ].

    aType == #double          ifTrue:[^ aType ].

    aType == #float           ifTrue:[^ aType ].

    aType == #char            ifTrue:[^ aType ].

    aType == #void            ifTrue:[^ aType ].

    aType == #bool            ifTrue:[^ aType ].

    aType == #pointer         ifTrue:[^ aType ].

    aType == #charPointer     ifTrue:[^ aType ].

    aType == #wcharPointer    ifTrue:[^ aType ].

    aType == #int8            ifTrue:[^ #sint8 ].

    aType == #int16           ifTrue:[^ #sint16 ].

    aType == #int32           ifTrue:[^ #sint32 ].

    aType == #int64           ifTrue:[^ #sint64 ].

    aType == #voidPointer         ifTrue:[^ #pointer ].

    aType == #uint8Pointer        ifTrue:[^ #pointer ].

    aType == #voidPointerPointer  ifTrue:[^ #pointer ].

    aType == #short           ifTrue:[^ #sint16 ].

    aType == #long            ifTrue:[^ #long ].

    aType == #int             ifTrue:[^ #int ].

    aType == #uint            ifTrue:[^ #uint ].

    aType == #ushort          ifTrue:[^ #uint16 ].

    aType == #unsignedShort   ifTrue:[^ #uint16 ].

    aType == #ulong           ifTrue:[^ #ulong ].

    aType == #unsignedLong    ifTrue:[^ #ulong ].

    aType == #uchar           ifTrue:[^ #uint8 ].

    aType == #unsignedChar    ifTrue:[^ #uint8 ].

    aType == #byte            ifTrue:[^ #uint8 ].

    aType == #longlong        ifTrue:[^ #sint64 ].

    aType == #longLong        ifTrue:[^ #sint64 ].

    aType == #ulonglong       ifTrue:[^ #uint64 ].

    aType == #ulongLong       ifTrue:[^ #uint64 ].

    "/ windefs

    aType == #dword           ifTrue:[^ #uint32 ].

    aType == #sdword          ifTrue:[^ #sint32 ].

    aType == #word            ifTrue:[^ #uint16 ].

    aType == #sword           ifTrue:[^ #sint16 ].

    aType == #handle          ifTrue:[^ #pointer ].

    aType == #lpstr           ifTrue:[^ #charPointer ].

    "/ aType == #hresult         ifTrue:[^ #uint32 ].  -- keep this; it is translated later (in invoke)

    aType == #boolean         ifTrue:[^ #bool ].

    "/ care for 64bit machines

    aType == #ulongReturn     ifTrue:[^ ExternalAddress pointerSize == 8 ifTrue:[#uint64] ifFalse:[#uint32]].

    aType == #none            ifTrue:[^ #void ].

    aType == #struct          ifTrue:[^ #pointer ].

    aType == #structIn        ifTrue:[^ #pointer ].

    aType == #structOut       ifTrue:[^ #pointer ].

    aType == #structInOut     ifTrue:[^ #pointer ].

    aType == #unsigned        ifTrue:[^ #uint ].

    aType == #ATOM            ifTrue:[^ #uint16 ].

    aType == #BOOL            ifTrue:[^ #int ].

    aType == #BOOLEAN         ifTrue:[^ #uint8 ].

    aType == #BYTE            ifTrue:[^ #uint8 ].

    aType == #DWORD           ifTrue:[^ #uint32 ].

    aType == #HANDLE          ifTrue:[^ #pointer ].

    "/ care for 64bit machines

    aType == #SIZE_T          ifTrue:[^ ExternalAddress pointerSize == 8 ifTrue:[#uint64] ifFalse:[#uint32]].

    aType == #BSTR            ifTrue:[^ #wcharPointer].

    (aType isString or:[aType isSymbol]) ifFalse:[

    ].

    (aType endsWith:'*') ifTrue:[

    ].

    (aType endsWith:'Pointer') ifTrue:[

    ].

    ^ aType

    "Modified (format): / 30-03-2016 / 13:45:09 / cg"

! !

!ExternalLibraryFunction methodsFor:'accessing'!

argumentTypes

    ^ argumentTypes

!

argumentTypesString

    ^ String

	streamContents:[:s |

	    argumentTypes do:[:eachArgType |

		eachArgType printOn:s.

	    ] separatedBy:[

		s nextPutAll:','.

	    ].

	].

!

beAsync

    "let this execute in a separate thread, in par with the other execution thread(s).

     Ignored under unix/linux (until those support multiple threads too)."

    flags := (flags ? 0) bitOr: FLAG_ASYNC.

    "Created: / 01-08-2006 / 13:42:38 / cg"

!

beCallTypeAPI

    flags := (flags ? 0) bitOr: CALLTYPE_API.

    "Created: / 01-08-2006 / 15:12:40 / cg"

!

beCallTypeC

    flags := (flags ? 0) bitOr: CALLTYPE_C.

    "Created: / 01-08-2006 / 15:12:40 / cg"

!

beCallTypeOLE

    flags := (flags ? 0) bitOr: FLAG_VIRTUAL.

    "Created: / 01-08-2006 / 15:12:40 / cg"

!

beCallTypeUNIX64

    flags := (flags ? 0) bitOr: CALLTYPE_UNIX64.

    "Created: / 01-08-2006 / 15:13:38 / cg"

!

beCallTypeV8

    flags := (flags ? 0) bitOr: CALLTYPE_V8.

    "Created: / 01-08-2006 / 15:13:28 / cg"