You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
333 lines
11 KiB
333 lines
11 KiB
# |
|
# Ffidl interface to Tcl8.2 |
|
# |
|
# Run time support for Ffidl. |
|
# |
|
# NOTE: Remember to update FFIDLRT_VERSION in configure.ac when changing this |
|
# version number. |
|
package provide Ffidlrt 0.4 |
|
package require Ffidl |
|
|
|
namespace eval ::ffidl:: {} |
|
|
|
proc ::ffidl::find-pkg-lib {pkg} { |
|
package require $pkg |
|
foreach i [::info loaded {}] { |
|
foreach {l p} $i {} |
|
if {$p eq "$pkg"} { |
|
return $l |
|
} |
|
} |
|
# ignore errors when running under pkg_mkIndex: |
|
if {![llength [info commands __package_orig]] } { |
|
return -code error "Library for package $pkg not found" |
|
} |
|
} |
|
|
|
namespace eval ::ffidl:: { |
|
set ffidl_lib [find-pkg-lib Ffidl] |
|
array set libs [list ffidl [list $ffidl_lib] ffidl_test [list $ffidl_lib]] |
|
unset ffidl_lib |
|
|
|
# 'libs' array is used by the ::ffidl::find-lib |
|
# abstraction to store the resolved lib paths |
|
# |
|
# 'types' and 'typedefs' arrays are used by the ::ffidl::find-type |
|
# abstraction to store resolved system types |
|
# and whether they have already been defined |
|
# with ::ffidl::typedef |
|
array set typedefs {} |
|
switch -exact $tcl_platform(platform) { |
|
unix { |
|
switch -glob $tcl_platform(os) { |
|
Darwin { |
|
array set libs { |
|
c System.framework/System |
|
m System.framework/System |
|
gdbm {} |
|
gmp {} |
|
mathswig libmathswig0.5.dylib |
|
} |
|
array set types { |
|
size_t {{unsigned long}} |
|
clock_t {{unsigned long}} |
|
time_t long |
|
timeval {uint32 uint32} |
|
} |
|
} |
|
Linux { |
|
if {$tcl_platform(wordSize) == 8} { |
|
if {$tcl_platform(machine) eq "alpha"} { |
|
array set libs { |
|
c /lib/libc.so.6.1 |
|
m /lib/libm.so.6.1 |
|
gdbm /usr/lib/libgdbm.so |
|
gmp {/usr/local/lib/libgmp.so /usr/lib/libgmp.so.2} |
|
mathswig libmathswig0.5.so |
|
} |
|
array set types { |
|
size_t long |
|
clock_t long |
|
time_t long |
|
timeval {time_t time_t} |
|
} |
|
} else { |
|
array set libs { |
|
c { |
|
/lib64/libc.so.6 |
|
/lib/x86_64-linux-gnu/libc.so.6 |
|
} |
|
m { |
|
/lib64/libm.so.6 |
|
/lib/x86_64-linux-gnu/libm.so.6 |
|
} |
|
gdbm { |
|
/usr/lib64/libgdbm.so |
|
/usr/lib/x86_64-linux-gnu/libgdbm.so |
|
} |
|
gmp { |
|
/usr/lib/x86_64-linux-gnu/libgmp.so |
|
/usr/local/lib64/libgmp.so |
|
/usr/lib64/libgmp.so.2 |
|
} |
|
mathswig libmathswig0.5.so |
|
} |
|
array set types { |
|
size_t long |
|
clock_t long |
|
time_t long |
|
timeval {time_t time_t} |
|
} |
|
} |
|
} else { |
|
array set libs { |
|
c { |
|
/lib/libc.so.6 |
|
/lib/i386-linux-gnu/libc.so.6 |
|
} |
|
m { |
|
/lib/libm.so.6 |
|
/lib/i386-linux-gnu/libm.so.6 |
|
} |
|
gdbm { |
|
/usr/lib/libgdbm.so |
|
/usr/lib/i386-linux-gnu/libgdbm.so.3 |
|
} |
|
gmp { |
|
/usr/lib/i386-linux-gnu/libgmp.so.2 |
|
/usr/local/lib/libgmp.so |
|
/usr/lib/libgmp.so.2 |
|
} |
|
mathswig libmathswig0.5.so |
|
} |
|
array set types { |
|
size_t int |
|
clock_t long |
|
time_t long |
|
timeval {time_t time_t} |
|
} |
|
} |
|
} |
|
*BSD { |
|
array set libs { |
|
c {/usr/lib/libc.so /usr/lib/libc.so.30.1} |
|
m {/usr/lib/libm.so /usr/lib/libm.so.1.0} |
|
gdbm libgdbm.so |
|
gmp libgmp.so |
|
mathswig libmathswig0.5.so |
|
} |
|
array set types { |
|
size_t int |
|
clock_t long |
|
time_t long |
|
timeval {time_t time_t} |
|
} |
|
} |
|
default { |
|
array set libs { |
|
c /lib/libc.so |
|
m /lib/libm.so |
|
gdbm libgdbm.so |
|
gmp libgmp.so |
|
mathswig libmathswig0.5.so |
|
} |
|
array set types { |
|
size_t int |
|
clock_t long |
|
time_t long |
|
timeval {time_t time_t} |
|
} |
|
} |
|
} |
|
} |
|
windows { |
|
# |
|
# found libraries |
|
# this array is used by the ::ffidl::find-lib |
|
# abstraction to store the resolved lib paths |
|
# |
|
# CHANGE - put your resolved lib paths here |
|
# |
|
array set libs { |
|
c msvcrt.dll |
|
m msvcrt.dll |
|
gdbm {} |
|
gmp gmp202.dll |
|
mathswig mathswig05.dll |
|
} |
|
# |
|
# found types |
|
# these arrays are used by the ::ffidl::find-type |
|
# abstraction to store resolved system types |
|
# and whether they have already been defined |
|
# with ::ffidl::typedef |
|
# |
|
# CHANGE - put your resolved system types here |
|
# |
|
array set types { |
|
size_t int |
|
clock_t long |
|
time_t long |
|
timeval {time_t time_t} |
|
} |
|
array set typedefs { |
|
} |
|
} |
|
} |
|
} |
|
|
|
# |
|
# find a shared library given a root name |
|
# this is an abstraction in search of a |
|
# solution. |
|
# |
|
# currently wired for my linux box |
|
# |
|
proc ::ffidl::find-lib {root} { |
|
upvar \#0 ::ffidl::libs libs |
|
if { ! [::info exists libs($root)] || [llength libs($root)] == 0} { |
|
error "::ffidl::find-lib $root - no mapping defined for $root" |
|
} |
|
if {[llength $libs($root)] > 1} { |
|
foreach l $libs($root) { |
|
if {[file exists $l]} { |
|
set libs($root) $l |
|
break |
|
} |
|
} |
|
} |
|
lindex $libs($root) 0 |
|
} |
|
|
|
# |
|
# find a typedef for a standard type |
|
# and define it with ::ffidl::typedef |
|
# if not already done |
|
# |
|
# currently wired for my linux box |
|
# |
|
proc ::ffidl::find-type {type} { |
|
upvar \#0 ::ffidl::types types |
|
upvar \#0 ::ffidl::typedefs typedefs |
|
if { ! [::info exists types($type)]} { |
|
error "::ffidl::find-type $type - no mapping defined for $type" |
|
} |
|
if { ! [::info exists typedefs($type)]} { |
|
eval ::ffidl::typedef $type $types($type) |
|
set typedefs($type) 1 |
|
} |
|
} |
|
|
|
# |
|
# get the address of the string rep of a Tcl_Obj |
|
# get the address of the unicode rep of a Tcl_Obj |
|
# get the address of the bytearray rep of a Tcl_Obj |
|
# |
|
# CAUTION - anything which alters the Tcl_Obj may |
|
# invalidate the results of this function. Use |
|
# only in circumstances where the Tcl_Obj will not |
|
# be modified in any way. |
|
# |
|
# CAUTION - the memory pointed to by the addresses |
|
# returned by ::ffidl::get-string and ::ffidl::get-unicode |
|
# is managed by Tcl, the contents should never be |
|
# modified. |
|
# |
|
# The memory pointed to by ::ffidl::get-bytearray may |
|
# be modified if care is taken to respect its size, |
|
# and if shared references to the bytearray object |
|
# are known to be compatible with the modification. |
|
# |
|
|
|
::ffidl::callout ::ffidl::get-string {pointer-obj} pointer [::ffidl::stubsymbol tcl stubs 340]; #Tcl_GetString |
|
::ffidl::callout ::ffidl::get-unicode {pointer-obj} pointer [::ffidl::stubsymbol tcl stubs 382]; #Tcl_GetUnicode |
|
::ffidl::callout ::ffidl::get-bytearray-from-obj {pointer-obj pointer-var} pointer [::ffidl::stubsymbol tcl stubs 33]; #Tcl_GetByteArrayFromObj |
|
|
|
proc ::ffidl::get-bytearray {obj} { |
|
set len [binary format [::ffidl::info format int] 0] |
|
::ffidl::get-bytearray-from-obj $obj len |
|
} |
|
|
|
# |
|
# create a new string Tcl_Obj |
|
# create a new unicode Tcl_Obj |
|
# create a new bytearray Tcl_Obj |
|
# |
|
# I'm not sure if these are actually useful |
|
# |
|
|
|
::ffidl::callout ::ffidl::new-string {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 56]; #Tcl_NewStringObj |
|
::ffidl::callout ::ffidl::new-unicode {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 378]; #Tcl_NewUnicodeObj |
|
::ffidl::callout ::ffidl::new-bytearray {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 50]; #Tcl_NewByteArrayObj |
|
|
|
::ffidl::find-type size_t |
|
if {1} { |
|
# Tcl's allocator: malloc, free, realloc. |
|
::ffidl::callout ::ffidl::malloc {unsigned} pointer [::ffidl::stubsymbol tcl stubs 3]; #Tcl_Alloc |
|
::ffidl::callout ::ffidl::realloc {pointer unsigned} pointer [::ffidl::stubsymbol tcl stubs 5]; #Tcl_Realloc |
|
::ffidl::callout ::ffidl::free {pointer} void [::ffidl::stubsymbol tcl stubs 4]; #Tcl_Free |
|
} else { |
|
# access the standard allocator: malloc, free, realloc. |
|
::ffidl::callout ::ffidl::malloc {size_t} pointer [::ffidl::symbol [::ffidl::find-lib c] malloc] |
|
::ffidl::callout ::ffidl::realloc {pointer size_t} pointer [::ffidl::symbol [::ffidl::find-lib c] realloc] |
|
::ffidl::callout ::ffidl::free {pointer} void [::ffidl::symbol [::ffidl::find-lib c] free] |
|
} |
|
|
|
# |
|
# Copy some memory at some location into a Tcl bytearray. |
|
# |
|
# Needless to say, this can be very hazardous to your |
|
# program's health if things aren't sized correctly. |
|
# |
|
::ffidl::callout ::ffidl::memcpy {pointer-var pointer size_t} pointer [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_copy_bytes]; |
|
|
|
# |
|
# Regular memcpy working on pointers. ::ffidl::memcpy kept as is for compatibilitiy. |
|
# |
|
::ffidl::callout ::ffidl::memcpy2 {pointer pointer size_t} pointer [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_copy_bytes]; |
|
|
|
# |
|
# Create a Tcl bytearray with a copy of the contents some memory location. |
|
# |
|
proc ::ffidl::peek {address nbytes} { |
|
set dst [binary format x$nbytes] |
|
::ffidl::memcpy dst $address $nbytes |
|
set dst |
|
} |
|
|
|
# |
|
# Copy the contents of a Tcl bytearray to some memory location. |
|
# |
|
proc ::ffidl::poke {dst src} { |
|
set n [string length $bytes]; |
|
set src [::ffidl::get-bytearray $bytes]; |
|
::ffidl::memcpy2 $dst $src $n; |
|
} |
|
|
|
# |
|
# convert raw pointers, as integers, into Tcl_Obj's |
|
# |
|
::ffidl::callout ::ffidl::pointer-into-string {pointer} pointer-utf8 [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_pointer_pun] |
|
::ffidl::callout ::ffidl::pointer-into-unicode {pointer} pointer-utf16 [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_pointer_pun] |
|
# ::ffidl::pointer-into-bytearray is deprecated. Use ::ffidl::peek instead. |
|
interp alias {} ::ffidl::pointer-into-bytearray {} ::ffidl::peek;
|
|
|