[plt-scheme] libusb FFI binding
Jakub Piotr Cłapa
jpc at pld-linux.org
Sun Mar 4 22:08:31 EST 2007
Ray wrote:
> Have made some minimal headway in binding to libusb.
How far have you gotten? It's that I have a quite finished one which I
haven't published because I wanted to polish it a little. Considering
that there seems to be some interest maybe we could use my work? I'm
attaching a file which I'm currently using in my project. Works on Win32
and OS X (untested on Linux yet) with a custom USB device based on
AVRUSB (the software USB implementation).
I would be thankful if anybody could look into it (it's my first
nontrivial Scheme app) and comment on anything (style, good habits, errors).
Known issues:
1. Some less important structs are not yet added.
2. Almost no struct accessors are provided (but some quite cool
functions for finding devices on the bus are so it's usable).
Btw. apropos FFI:
1. PATH_MAX (and maybe some other C constants) could be exported in
%foreign. It would make the bindings more bullet proof.
2. _enum could be more flexible. Currently there is no way to get a
number corresponding to a symbol... Maybe allow for expressions
evaluated with unhygienically added _enum symbols binded to
corresponding numbers. I wanted to pass numbers instead of symbols (for
custom request codes) and had to make a new ctype. Expressions evaled on
function call with enum symbols bound would solve this problem (and some
other too).
--
regards,
Jakub Piotr Cłapa
-------------- next part --------------
(module usb mzscheme
(require (lib "foreign.ss")
(lib "etc.ss"))
(unsafe!)
(define libusb #f)
(case (system-type)
[(macosx)
(ffi-lib "/System/Libraries/IOKit.framework/IOKit")
(set! libusb (ffi-lib "/opt/local/lib/libusb"))]
[(windows)
(set! libusb (ffi-lib "libusb0"))])
(define-syntax defusb
(syntax-rules ()
[(_ name type ...)
(define name
(get-ffi-obj (regexp-replaces 'name '((#rx"-" "_")))
libusb (_fun type ...)))]))
(define _usb-class
(_enum '(per-interface audio comm hid printer mass-storage hub data
vendor-spec = #xff)))
(define _usb-descriptor-type
(_enum '(device = #x01 config string interface endpoint
hid = #x21 report physical hub = #x29)))
(define standard-usb-requests
(let loop ([symbols '(get-status
clear-feature
set-feature = #x03
set-address = #x05
get-descriptor
set-descriptor
get-configuration
set-configuration
get-interface
set-interface
synch-frame)]
[index 0])
(unless (null? symbols)
(when (and (pair? (cdr symbols))
(eq? '= (cadr symbols))
(pair? (cddr symbols)))
(set! index (caddr symbols))
(set-cdr! symbols (cdddr symbols)))
(set-car! symbols (cons (car symbols) index))
(loop (cdr symbols) (add1 index)))
symbols))
(define _usb-request-type
(_bitmask '(endpoint-out = #x00
endpoint-in = #x80
standard = #x00
class = #x20
vendor = #x40
reserved = #x60)))
(define _usb-request
(make-ctype _uint
(lambda (value)
(cond
[(and (symbol? value)
(assq value standard-usb-requests)) => cdr]
[(number? value) value]
[else #f]))
#f))
(define-cstruct _usb-descriptor
([length _uint8]
[type _uint8]))
(define-cstruct (_usb-hid-descriptor _usb-descriptor)
())
(define-cstruct (_usb-endpoint-descriptor _usb-descriptor)
())
(define-cstruct (_usb-interface-descriptor _usb-descriptor)
())
(define-cstruct (_usb-config-descriptor _usb-descriptor)
())
(define-cstruct (_usb-device-descriptor _usb-descriptor)
([usbMajor _uint8]
[usbMinor _uint8]
[device-class _uint8]
[device-subclass _uint8]
[device-protocol _uint8]
[max-packet-size-0 _uint8]
[vendor-id _uint16]
[product-id _uint16]
[deviceMajor _uint8]
[deviceMinor _uint8]
[manufacturer _uint8]
[product _uint8]
[serial-number _uint8]
[num-configurations _uint8]))
(define (bytes->string/utf-16le buffer)
(let*-values ([(converter) (bytes-open-converter "UTF-16LE" "UTF-8")]
[(result length status) (bytes-convert converter buffer)])
(bytes-close-converter converter)
(bytes->string/utf-8 result)))
(define (string-descriptor->string buffer)
(let ([length (- (bytes-ref buffer 0) 2)]
[type (bytes-ref buffer 1)])
(unless (eq? type 3)
(error 'string-descriptor "not a string descriptor"))
(unless (>= (bytes-length buffer) length)
(error 'string-descriptor "string longer than the buffer"))
(bytes->string/utf-16le (subbytes buffer 2 (+ length 2)))))
(define-cpointer-type _usb-string-descriptor _usb-descriptor
#f
(lambda (ptr)
(let ([length (- (ptr-ref ptr _uint8) 2)]
[type (ptr-ref ptr _usb-descriptor-type 1)])
(unless (eq? type 'string)
(error 'string-descriptor "not a string descriptor"))
(let ([v (make-bytes length)])
(let loop ([i 0])
(unless (= i length)
(bytes-set! v i (ptr-ref ptr _uint8 'abs i))
(loop (add1 i))))
(string-descriptor->string v)))))
(define usb-max-path-len
(case (system-type)
[(macosx) 1024]
[(windows) 512]))
(provide usb-device-descriptor usb-device-descriptor-product-id)
(define _path-type
(make-ctype (make-cstruct-type (build-list (/ usb-max-path-len 8)
(lambda (i) _uint64)))
#f
(lambda (ptr)
(let ([v (make-bytes usb-max-path-len)]
[length #f])
(let loop ([i 0])
(let ([value (ptr-ref ptr _uint8 'abs i)])
(if (or (= i usb-max-path-len) (= value 0)) (set! length i)
(begin
(bytes-set! v i value)
(loop (add1 i))))))
(subbytes v 0 length)))))
(define _usb-bus-pointer-dummy _pointer)
(define-cstruct _usb-device
([next _usb-device-pointer/null]
[prev _usb-device-pointer/null]
[filename _path-type]
[bus _usb-bus-pointer-dummy]
[descriptor _usb-device-descriptor]
[config (_cpointer _usb-config-descriptor)]
[dev _pointer]
[devnum _uint8]
[num_children _uint8]
[children (_cpointer _usb-device-pointer)]))
(define-cstruct _usb-bus
([next _usb-bus-pointer/null]
[prev _usb-bus-pointer/null]
[dirname _path-type]
[devices _usb-device-pointer/null]
[location _uint32]
[root-dev _usb-device-pointer/null]))
(set! _usb-bus-pointer-dummy _usb-bus-pointer)
(define-cpointer-type _usb-dev-handle)
(provide usb-strerror)
(defusb usb-strerror -> (message : _bytes)
-> (bytes->string/latin-1 message))
(provide usb-init usb-find-busses usb-find-devices usb-get-busses)
(defusb usb-init -> _void)
(defusb usb-find-busses -> _int)
(defusb usb-find-devices -> _int)
(defusb usb-get-busses -> _usb-bus-pointer)
(provide usb-open usb-device usb-close)
(defusb usb-open
_usb-device-pointer -> _usb-dev-handle)
(defusb usb-device
_usb-dev-handle -> _usb-device)
(defusb usb-close
_usb-dev-handle -> _int)
(provide usb-control-msg)
(defusb usb-control-msg
(dev requesttype request value index buflen timeout) ::
(dev : _usb-dev-handle)
(requesttype : _usb-request-type)
(request : _usb-request)
(value : _int)
(index : _int)
(buffer : (_bytes o buflen))
(buflen : _int)
(timeout : _int)
-> (recvlen : _int)
-> (if (>= recvlen 0) (subbytes buffer 0 recvlen)
(error (usb-strerror))))
(provide usb-get-string)
(define (usb-get-string device index langid)
(string-descriptor->string
(usb-control-msg device
'endpoint-in
'get-descriptor
(+ (arithmetic-shift 3 8) index)
langid
255
5000)))
(define (usb-map-list first-elem next-fun map-fun)
(let loop ([elem first-elem]
[results '()])
(if (not elem) (reverse! results)
(let ([result (map-fun elem)])
(loop (next-fun elem)
(if result
(cons result results)
results))))))
(provide usb-map-busses usb-map-devices usb-map-all-devices)
(define (usb-map-busses map-fun)
(usb-map-list (usb-get-busses)
usb-bus-next
map-fun))
(define (usb-map-devices device map-fun)
(usb-map-list device
usb-device-next
map-fun))
(define (usb-map-all-devices map-fun)
(apply append
(usb-map-busses
(lambda (bus)
(usb-map-devices (usb-bus-devices bus)
map-fun)))))
(provide get-vendor-id get-product-id
get-manufacturer-string get-product-string)
(define (get-vendor-id device)
(usb-device-descriptor-vendor-id (usb-device-descriptor device)))
(define (get-product-id device)
(usb-device-descriptor-product-id (usb-device-descriptor device)))
(define (get-manufacturer-string device)
(let* ([handle (usb-open device)]
[result (usb-get-string handle
(usb-device-descriptor-manufacturer
(usb-device-descriptor device))
0)])
(usb-close handle)
result))
(define (get-product-string device)
(let* ([handle (usb-open device)]
[result (usb-get-string handle
(usb-device-descriptor-product
(usb-device-descriptor device))
0)])
(usb-close handle)
result))
(provide ids-filter string-ids-filter)
(define (ids-filter vendor-id product-id)
(lambda (device)
(if (and
(eq? (get-vendor-id device) vendor-id)
(eq? (get-product-id device) product-id))
device
#f)))
(define (string-ids-filter manufacturer product)
(lambda (device)
(if (and
(equal? (get-manufacturer-string device) manufacturer)
(equal? (get-product-string device) product))
device
#f)))
)
More information about the plt-scheme
mailing list