Coverage report: /home/luis/src/cffi/src/libraries.lisp
Kind | Covered | All | % |
expression | 82 | 148 | 55.4 |
branch | 3 | 12 | 25.0 |
Key
Not instrumented
Executed
Not executed
Both branches taken
One branch taken
Neither branch taken
1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3
;;; libraries.lisp --- Finding and loading foreign libraries.
5
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
6
;;; Copyright (C) 2006-2007, Luis Oliveira <loliveira@common-lisp.net>
8
;;; Permission is hereby granted, free of charge, to any person
9
;;; obtaining a copy of this software and associated documentation
10
;;; files (the "Software"), to deal in the Software without
11
;;; restriction, including without limitation the rights to use, copy,
12
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
13
;;; of the Software, and to permit persons to whom the Software is
14
;;; furnished to do so, subject to the following conditions:
16
;;; The above copyright notice and this permission notice shall be
17
;;; included in all copies or substantial portions of the Software.
19
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
20
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
21
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
22
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
23
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
24
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
25
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
26
;;; DEALINGS IN THE SOFTWARE.
31
;;;# Finding Foreign Libraries
33
;;; We offer two ways for the user of a CFFI library to define
34
;;; his/her own library directories: *FOREIGN-LIBRARY-DIRECTORIES*
35
;;; for regular libraries and *DARWIN-FRAMEWORK-DIRECTORIES* for
36
;;; Darwin frameworks.
38
;;; These two special variables behave similarly to
39
;;; ASDF:*CENTRAL-REGISTRY* as its arguments are evaluated before
40
;;; being used. We used our MINI-EVAL instead of the full-blown EVAL
43
;;; Only after failing to find a library through the normal ways
44
;;; (eg: on Linux LD_LIBRARY_PATH, /etc/ld.so.cache, /usr/lib/, /lib)
45
;;; do we try to find the library ourselves.
47
(defvar *foreign-library-directories* '()
48
"List onto which user-defined library paths can be pushed.")
50
(defvar *darwin-framework-directories*
51
'((merge-pathnames #p"Library/Frameworks/" (user-homedir-pathname))
52
#p"/Library/Frameworks/"
53
#p"/System/Library/Frameworks/")
54
"List of directories where Frameworks are searched for.")
56
(defun mini-eval (form)
57
"Simple EVAL-like function to evaluate the elements of
58
*FOREIGN-LIBRARY-DIRECTORIES* and *DARWIN-FRAMEWORK-DIRECTORIES*."
60
(cons (apply (car form) (mapcar #'mini-eval (cdr form))))
61
(symbol (symbol-value form))
64
(defun find-file (path directories)
65
"Searches for PATH in a list of DIRECTORIES and returns the first it finds."
66
(some (lambda (directory) (probe-file (merge-pathnames path directory)))
69
(defun find-darwin-framework (framework-name)
70
"Searches for FRAMEWORK-NAME in *DARWIN-FRAMEWORK-DIRECTORIES*."
71
(dolist (framework-directory *darwin-framework-directories*)
72
(let ((path (make-pathname
75
(append (pathname-directory (mini-eval framework-directory))
76
(list (format nil "~A.framework" framework-name))))))
77
(when (probe-file path)
78
(return-from find-darwin-framework path)))))
80
;;;# Defining Foreign Libraries
82
;;; Foreign libraries can be defined using the
83
;;; DEFINE-FOREIGN-LIBRARY macro. Example usage:
85
;;; (define-foreign-library opengl
86
;;; (:darwin (:framework "OpenGL"))
87
;;; (:unix (:or "libGL.so" "libGL.so.1"
88
;;; #p"/myhome/mylibGL.so"))
89
;;; (:windows "opengl32.dll")
90
;;; ;; an hypothetical example of a particular platform
91
;;; ((:and :some-system :some-cpu) "libGL-support.lib")
92
;;; ;; if no other clauses apply, this one will and a type will be
93
;;; ;; automagically appended to the name passed to :default
94
;;; (t (:default "libGL")))
96
;;; This information is stored in the *FOREIGN-LIBRARIES* hashtable
97
;;; and when the library is loaded through LOAD-FOREIGN-LIBRARY (or
98
;;; USE-FOREIGN-LIBRARY) the first clause matched by CFFI-FEATURE-P is
101
(defvar *foreign-libraries* (make-hash-table :test 'eq)
102
"Hashtable of defined libraries.")
104
(defun get-foreign-library (lib)
105
"Look up a library by NAME, signalling an error if not found."
106
(if (typep lib 'foreign-library)
108
(or (gethash lib *foreign-libraries*)
109
(error "Undefined foreign library: ~S" lib))))
111
(defun (setf get-foreign-library) (value name)
112
(setf (gethash name *foreign-libraries*) value))
114
(defclass foreign-library ()
115
((spec :initarg :spec)
116
(options :initform nil :initarg :options)
117
(handle :initarg :handle :accessor foreign-library-handle)))
119
(defun %foreign-library-spec (lib)
120
(assoc-if #'cffi-feature-p (slot-value lib 'spec)))
122
(defun foreign-library-spec (lib)
123
(second (%foreign-library-spec lib)))
125
(defun foreign-library-options (lib)
126
(append (cddr (%foreign-library-spec lib))
127
(slot-value lib 'options)))
129
;;; Warn about unkown options.
130
(defmethod initialize-instance :after ((lib foreign-library) &key)
132
on (append (slot-value lib 'options)
133
(mapcan (lambda (x) (copy-list (cddr x)))
134
(slot-value lib 'spec)))
136
when (not (member opt '(:cconv :calling-convention)))
137
do (warn "Unkown option: ~A" opt)))
139
(defmacro define-foreign-library (name-and-options &body pairs)
140
"Defines a foreign library NAME that can be posteriorly used with
141
the USE-FOREIGN-LIBRARY macro."
142
(destructuring-bind (name . options)
143
(ensure-list name-and-options)
145
(setf (get-foreign-library ',name)
146
(make-instance 'foreign-library
147
:spec ',pairs :options ',options))
150
;;;# LOAD-FOREIGN-LIBRARY-ERROR condition
152
;;; The various helper functions that load foreign libraries can
153
;;; signal this error when something goes wrong. We ignore the host's
154
;;; error. We should probably reuse its error message.
156
(define-condition load-foreign-library-error (simple-error)
159
(defun read-new-value ()
160
(format t "~&Enter a new value (unevaluated): ")
164
(defun fl-error (control &rest arguments)
165
(error 'load-foreign-library-error
166
:format-control control
167
:format-arguments arguments))
169
;;;# Loading Foreign Libraries
171
(defun load-darwin-framework (name framework-name)
172
"Tries to find and load a darwin framework in one of the directories
173
in *DARWIN-FRAMEWORK-DIRECTORIES*. If unable to find FRAMEWORK-NAME,
174
it signals a LOAD-FOREIGN-LIBRARY-ERROR."
175
(let ((framework (find-darwin-framework framework-name)))
177
(load-foreign-library-path name (native-namestring framework))
178
(fl-error "Unable to find framework ~A" framework-name))))
180
(defun load-foreign-library-path (name path)
181
"Tries to load NAME using %LOAD-FOREIGN-LIBRARY which should try and
182
find it using the OS's usual methods. If that fails we try to find it
184
(or (ignore-errors (%load-foreign-library name path))
185
(let ((file (find-file path *foreign-library-directories*)))
187
(%load-foreign-library name (native-namestring file))))
188
;; couldn't load it directly or find it...
189
(fl-error "Unable to load foreign library: ~A" path)))
191
(defun try-foreign-library-alternatives (name library-list)
192
"Goes through a list of alternatives and only signals an error when
193
none of alternatives were successfully loaded."
194
(dolist (lib library-list)
195
(let-when (handle (ignore-errors (load-foreign-library-helper name lib)))
196
(return-from try-foreign-library-alternatives handle)))
197
(fl-error "Unable to load any of the alternatives:~% ~S" library-list))
199
(defparameter *cffi-feature-suffix-map*
200
'((cffi-features:windows . ".dll")
201
(cffi-features:darwin . ".dylib")
202
(cffi-features:unix . ".so"))
203
"Mapping of OS feature keywords to shared library suffixes.")
205
(defun default-library-suffix ()
206
"Return a string to use as default library suffix based on the
207
operating system. This is used to implement the :DEFAULT option.
208
This will need to be extended as we test on more OSes."
209
(or (cdr (assoc-if #'cffi-feature-p *cffi-feature-suffix-map*))
210
(fl-error "Unable to determine the default library suffix on this OS.")))
212
(defun load-foreign-library-helper (name thing)
215
(load-foreign-library-path name thing))
217
(load-foreign-library-path name (namestring thing)))
220
(:framework (load-darwin-framework name (second thing)))
222
(unless (stringp (second thing))
223
(fl-error "Argument to :DEFAULT must be a string."))
224
(load-foreign-library-path
225
name (concatenate 'string (second thing) (default-library-suffix))))
226
(:or (try-foreign-library-alternatives name (rest thing)))))))
228
(defun load-foreign-library (library)
229
"Loads a foreign LIBRARY which can be a symbol denoting a library defined
230
through DEFINE-FOREIGN-LIBRARY; a pathname or string in which case we try to
231
load it directly first then search for it in *FOREIGN-LIBRARY-DIRECTORIES*;
232
or finally list: either (:or lib1 lib2) or (:framework <framework-name>)."
236
(let* ((lib (get-foreign-library library))
237
(spec (foreign-library-spec lib)))
239
(setf (foreign-library-handle lib)
240
(load-foreign-library-helper library spec))
243
(make-instance 'foreign-library :spec (list (list library))
244
:handle (load-foreign-library-helper nil library))))
245
;; Offer these restarts that will retry the call to
246
;; LOAD-FOREIGN-LIBRARY.
248
:report "Try loading the foreign library again."
249
(load-foreign-library library))
250
(use-value (new-library)
251
:report "Use another library instead."
252
:interactive read-new-value
253
(load-foreign-library new-library))))
255
(defmacro use-foreign-library (name)
256
`(load-foreign-library ',name))
258
;;;# Closing Foreign Libraries
260
(defun close-foreign-library (library)
261
"Closes a foreign library."
262
(let ((lib (get-foreign-library library)))
263
(when (foreign-library-handle lib)
264
(%close-foreign-library (foreign-library-handle lib))
265
(setf (foreign-library-handle lib) nil)