1# 2# Ffidl interface to Tcl8.2 3# 4# Run time support for Ffidl. 5# 6package provide Ffidlrt 0.1 7package require Ffidl 8 9namespace eval ::ffidl:: {} 10 11proc ::ffidl::find-pkg-lib {pkg} { 12 package require $pkg 13 foreach i [::info loaded {}] { 14 foreach {l p} $i {} 15 if {$p eq "$pkg"} { 16 return $l 17 } 18 } 19 # ignore errors when running under pkg_mkIndex: 20 if {![llength [info commands __package_orig]] } { 21 return -code error "Library for package $pkg not found" 22 } 23} 24 25namespace eval ::ffidl:: { 26 set ffidl_lib [find-pkg-lib Ffidl] 27 array set libs [list ffidl $ffidl_lib ffidl_test $ffidl_lib] 28 unset ffidl_lib 29 30 # 'libs' array is used by the ::ffidl::find-lib 31 # abstraction to store the resolved lib paths 32 # 33 # 'types' and 'typedefs' arrays are used by the ::ffidl::find-type 34 # abstraction to store resolved system types 35 # and whether they have already been defined 36 # with ::ffidl::typedef 37 array set typedefs {} 38 switch -exact $tcl_platform(platform) { 39 unix { 40 switch -glob $tcl_platform(os) { 41 Darwin { 42 array set libs { 43 c libSystem.dylib 44 m libSystem.dylib 45 gdbm {} 46 gmp {} 47 mathswig libmathswig0.5.dylib 48 } 49 array set types { 50 size_t {{unsigned long}} 51 clock_t {{unsigned long}} 52 time_t long 53 timeval {uint32 uint32} 54 } 55 } 56 } 57 } 58 } 59} 60 61# 62# find a shared library given a root name 63# this is an abstraction in search of a 64# solution. 65# 66proc ::ffidl::find-lib {root} { 67 upvar \#0 ::ffidl::libs libs 68 if { ! [::info exists libs($root)] || [llength libs($root)] == 0} { 69 error "::ffidl::find-lib $root - no mapping defined for $root" 70 } 71 if {[llength $libs($root)] > 1} { 72 foreach l $libs($root) { 73 if {[file exists $l]} { 74 set libs($root) $l 75 break 76 } 77 } 78 } 79 lindex $libs($root) 0 80} 81 82# 83# find a typedef for a standard type 84# and define it with ::ffidl::typedef 85# if not already done 86# 87# currently wired for my linux box 88# 89proc ::ffidl::find-type {type} { 90 upvar \#0 ::ffidl::types types 91 upvar \#0 ::ffidl::typedefs typedefs 92 if { ! [::info exists types($type)]} { 93 error "::ffidl::find-type $type - no mapping defined for $type" 94 } 95 if { ! [::info exists typedefs($type)]} { 96 eval ::ffidl::typedef $type $types($type) 97 set typedefs($type) 1 98 } 99} 100 101# 102# get the address of the string rep of a Tcl_Obj 103# get the address of the unicode rep of a Tcl_Obj 104# get the address of the bytearray rep of a Tcl_Obj 105# 106# CAUTION - anything which alters the Tcl_Obj may 107# invalidate the results of this function. Use 108# only in circumstances where the Tcl_Obj will not 109# be modified in any way. 110# 111# CAUTION - the memory pointed to by the addresses 112# returned by ::ffidl::get-string and ::ffidl::get-unicode 113# is managed by Tcl, the contents should never be 114# modified. 115# 116# The memory pointed to by ::ffidl::get-bytearray may 117# be modified if care is taken to respect its size, 118# and if shared references to the bytearray object 119# are known to be compatible with the modification. 120# 121 122::ffidl::callout ::ffidl::get-string {pointer-obj} pointer [::ffidl::stubsymbol tcl stubs 340]; #Tcl_GetString 123::ffidl::callout ::ffidl::get-unicode {pointer-obj} pointer [::ffidl::stubsymbol tcl stubs 382]; #Tcl_GetUnicode 124::ffidl::callout ::ffidl::get-bytearray-from-obj {pointer-obj pointer-var} pointer [::ffidl::stubsymbol tcl stubs 33]; #Tcl_GetByteArrayFromObj 125 126proc ::ffidl::get-bytearray {obj} { 127 set len [binary format [::ffidl::info format int] 0] 128 ::ffidl::get-bytearray-from-obj $obj len 129} 130 131# 132# create a new string Tcl_Obj 133# create a new unicode Tcl_Obj 134# create a new bytearray Tcl_Obj 135# 136# I'm not sure if these are actually useful 137# 138 139::ffidl::callout ::ffidl::new-string {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 56]; #Tcl_NewStringObj 140::ffidl::callout ::ffidl::new-unicode {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 378]; #Tcl_NewUnicodeObj 141::ffidl::callout ::ffidl::new-bytearray {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 50]; #Tcl_NewByteArrayObj 142 143# 144# access the standard allocator, malloc, free, realloc 145# 146::ffidl::find-type size_t 147::ffidl::callout ::ffidl::malloc {size_t} pointer [::ffidl::symbol [::ffidl::find-lib c] malloc] 148::ffidl::callout ::ffidl::realloc {pointer size_t} pointer [::ffidl::symbol [::ffidl::find-lib c] realloc] 149::ffidl::callout ::ffidl::free {pointer} void [::ffidl::symbol [::ffidl::find-lib c] free] 150 151# 152# Copy some memory at some location into a Tcl bytearray. 153# 154# Needless to say, this can be very hazardous to your 155# program's health if things aren't sized correctly. 156# 157 158::ffidl::callout ::ffidl::memcpy {pointer-var pointer int} pointer [::ffidl::symbol [::ffidl::find-lib c] memcpy] 159 160proc ::ffidl::peek {address nbytes} { 161 set dst [binary format x$nbytes] 162 ::ffidl::memcpy dst $address $nbytes 163 set dst 164} 165 166# 167# convert raw pointers, as integers, into Tcl_Obj's 168# 169::ffidl::callout ::ffidl::pointer-into-string {pointer} pointer-utf8 [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_pointer_pun] 170::ffidl::callout ::ffidl::pointer-into-unicode {pointer} pointer-utf16 [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_pointer_pun] 171proc ::ffidl::pointer-into-bytearray {pointer length} { 172 set bytes [binary format x$length] 173 ::ffidl::memcpy [::ffidl::get-bytearray $bytes] $pointer $length 174 set bytes 175} 176