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