suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

made it possible to try several versions, use it in readline and openssl

Browse Source 
svn: r6138
This commit is contained in:
Eli Barzilay 2007-05-04 06:08:48 +00:00
parent 943967a4ce
commit 26ab4af5f7
3 changed files with 79 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

132
collects/mzlib/foreign.ss
View File

@ -2,8 +2,7 @@
(module foreign mzscheme (module foreign mzscheme
(require #%foreign (require #%foreign (lib "dirs.ss" "setup"))
(lib "dirs.ss" "setup"))
(require-for-syntax (lib "stx.ss" "syntax")) (require-for-syntax (lib "stx.ss" "syntax"))
;; This module is full of unsafe bindings that are not provided to requiring ;; This module is full of unsafe bindings that are not provided to requiring
@ -141,44 +140,53 @@
(define get-ffi-lib (define get-ffi-lib
(case-lambda (case-lambda
[(name) (get-ffi-lib name "")] [(name) (get-ffi-lib name "")]
[(name version) [(name version/s)
(cond (cond
[(not name) (ffi-lib name)] ; #f => NULL => open this executable [(not name) (ffi-lib name)] ; #f => NULL => open this executable
[(not (or (string? name) (path? name))) [(not (or (string? name) (path? name)))
(raise-type-error 'ffi-lib "library-name" name)] (raise-type-error 'ffi-lib "library-name" name)]
[else [else
;; A possible way that this might be misleading: say that there is a ;; A possible way that this might be misleading: say that there is a
;; "foo.so" file in the current directory, which refers to some undefined ;; "foo.so" file in the current directory, which refers to some
;; symbol, trying to use this function with "foo.so" will try a dlopen ;; undefined symbol, trying to use this function with "foo.so" will try
;; with "foo.so" which isn't found, then it tries a dlopen with ;; a dlopen with "foo.so" which isn't found, then it tries a dlopen with
;; "/<curpath>/foo.so" which fails because of the undefined symbol, and ;; "/<curpath>/foo.so" which fails because of the undefined symbol, and
;; since all fails, it will use (ffi-lib "foo.so") to raise the original ;; since all fails, it will use (ffi-lib "foo.so") to raise the original
;; file-not-found error. This is because the dlopen doesn't provide a ;; file-not-found error. This is because the dlopen doesn't provide a
;; way to distinguish different errors (only dlerror, but that's ;; way to distinguish different errors (only dlerror, but that's
;; unreliable). ;; unreliable).
(let* ([version (if (zero? (string-length version)) (let* ([versions (if (list? version/s) version/s (list version/s))]
"" (string-append "." version))] [versions (map (lambda (v)
[fullpath (lambda (p) (path->complete-path (expand-path p)))] (if (or (not v) (zero? (string-length v)))
[absolute? (absolute-path? name)] "" (string-append "." v)))
[name0 (path->string (expand-path name))] ; orig name versions)]
[name (if (regexp-match lib-suffix-re name0) ; name + suffix [fullpath (lambda (p) (path->complete-path (expand-path p)))]
(string-append name0 version) [absolute? (absolute-path? name)]
(string-append name0 "." lib-suffix version))]) [name0 (path->string (expand-path name))] ; orig name
(or (and (not absolute?) [names (map (if (regexp-match lib-suffix-re name0) ; name+suffix
(ormap (lambda (dir) (lambda (v) (string-append name0 v))
;; try good name first, then original (lambda (v) (string-append name0 "." lib-suffix v)))
(or (ffi-lib (build-path dir name) #t) versions)]
(ffi-lib (build-path dir name0) #t))) [ffi-lib* (lambda (name) (ffi-lib name #t))])
(get-lib-search-dirs))) (or ;; try to look in our library paths first
;; Try without DLL path: (and (not absolute?)
(ffi-lib name #t) ; try good name first (ormap (lambda (dir)
(ffi-lib name0 #t) ; try original ;; try good names first, then original
(and (file-exists? name) ; try a relative path (or (ormap (lambda (name)
(ffi-lib (fullpath name) #t)) (ffi-lib* (build-path dir name)))
(and (file-exists? name0) ; relative with original names)
(ffi-lib (fullpath name0) #t)) (ffi-lib* (build-path dir name0))))
;; give up: call ffi-lib so it will raise an error (get-lib-search-dirs)))
(ffi-lib name)))])])) ;; try a system search
(ormap ffi-lib* names) ; try good names first
(ffi-lib* name0) ; try original
(ormap (lambda (name) ; try relative paths
(and (file-exists? name) (ffi-lib* (fullpath name))))
names)
(and (file-exists? name0) ; relative with original
(ffi-lib* (fullpath name0)))
;; give up: call ffi-lib so it will raise an error
(ffi-lib (car names))))])]))
(define (get-ffi-lib-internal x) (define (get-ffi-lib-internal x)
(if (ffi-lib? x) x (get-ffi-lib x))) (if (ffi-lib? x) x (get-ffi-lib x)))
@ -377,12 +385,12 @@
(let ([keys '()]) (let ([keys '()])
(define (setkey! key val . id?) (define (setkey! key val . id?)
(cond (cond
[(assq key keys) [(assq key keys)
(err "bad expansion of custom type (two `~a:'s)" key type)] (err "bad expansion of custom type (two `~a:'s)" key type)]
[(and (pair? id?) (car id?) (not (identifier? val))) [(and (pair? id?) (car id?) (not (identifier? val)))
(err "bad expansion of custom type (`~a:' expects an identifier)" (err "bad expansion of custom type (`~a:' expects an identifier)"
key type)] key type)]
[else (set! keys (cons (cons key val) keys))])) [else (set! keys (cons (cons key val) keys))]))
(let loop ([t orig]) (let loop ([t orig])
(define (next rest . args) (apply setkey! args) (loop rest)) (define (next rest . args) (apply setkey! args) (loop rest))
(syntax-case* t (type: expr: bind: 1st-arg: prev-arg: pre: post:) id=? (syntax-case* t (type: expr: bind: 1st-arg: prev-arg: pre: post:) id=?
@ -1400,23 +1408,23 @@
(define (list->TYPE vals) (apply make-TYPE vals)) (define (list->TYPE vals) (apply make-TYPE vals))
(define (list*->TYPE vals) (define (list*->TYPE vals)
(cond (cond
[(TYPE? vals) vals] [(TYPE? vals) vals]
[(= (length vals) (length all-types)) [(= (length vals) (length all-types))
(let ([block (malloc _TYPE*)]) (let ([block (malloc _TYPE*)])
(set-cpointer-tag! block all-tags) (set-cpointer-tag! block all-tags)
(for-each (for-each
(lambda (type ofs value) (lambda (type ofs value)
(let-values (let-values
([(ptr tags types offsets T->list* list*->T) ([(ptr tags types offsets T->list* list*->T)
(cstruct-info (cstruct-info
type type
(lambda () (values #f '() #f #f #f #f)))]) (lambda () (values #f '() #f #f #f #f)))])
(ptr-set! block type 'abs ofs (ptr-set! block type 'abs ofs
(if list*->T (list*->T value) value)))) (if list*->T (list*->T value) value))))
all-types all-offsets vals) all-types all-offsets vals)
block)] block)]
[else (error '_TYPE "expecting ~s values, got ~s: ~e" [else (error '_TYPE "expecting ~s values, got ~s: ~e"
(length all-types) (length vals) vals)])) (length all-types) (length vals) vals)]))
(define (TYPE->list x) (define (TYPE->list x)
(unless (TYPE? x) (unless (TYPE? x)
(raise-type-error 'TYPE-list struct-string x)) (raise-type-error 'TYPE-list struct-string x))

15
collects/openssl/mzssl.ss
View File

@ -66,16 +66,17 @@
(define libcrypto (define libcrypto
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(set! ssl-load-fail-reason (exn-message x)) (set! ssl-load-fail-reason (exn-message x))
#f)]) #f)])
(ffi-lib libcrypto-so))) (ffi-lib libcrypto-so '("" "0.9.8b" "0.9.8" "0.9.7"))))
(define libssl (define libssl
(and libcrypto (and libcrypto
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail?
(set! ssl-load-fail-reason (exn-message x)) (lambda (x)
#f)]) (set! ssl-load-fail-reason (exn-message x))
(ffi-lib libssl-so)))) #f)])
(ffi-lib libssl-so '("" "0.9.8b" "0.9.8" "0.9.7")))))
(define libmz (ffi-lib #f)) (define libmz (ffi-lib #f))

2
collects/readline/mzrl.ss
View File

@ -7,7 +7,7 @@
;; libtermcap needed on some platforms ;; libtermcap needed on some platforms
(define libtermcap (with-handlers ([exn:fail? void]) (ffi-lib "libtermcap"))) (define libtermcap (with-handlers ([exn:fail? void]) (ffi-lib "libtermcap")))
(define libreadline (ffi-lib "libreadline")) (define libreadline (ffi-lib "libreadline" '("" "5" "4")))
(define make-byte-string ; helper for the two types below (define make-byte-string ; helper for the two types below
(get-ffi-obj "scheme_make_byte_string" #f (_fun _pointer -> _scheme))) (get-ffi-obj "scheme_make_byte_string" #f (_fun _pointer -> _scheme)))