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