tlibraries.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
tlibraries.lisp (18805B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; libraries.lisp --- Finding and loading foreign libraries.
4 ;;;
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
6 ;;; Copyright (C) 2006-2007, Luis Oliveira <loliveira@common-lisp.net>
7 ;;;
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:
15 ;;;
16 ;;; The above copyright notice and this permission notice shall be
17 ;;; included in all copies or substantial portions of the Software.
18 ;;;
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.
27 ;;;
28
29 (in-package #:cffi)
30
31 ;;;# Finding Foreign Libraries
32 ;;;
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.
37 ;;;
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
41 ;;; and the evaluated form should yield a single pathname or a list of
42 ;;; pathnames.
43 ;;;
44 ;;; Only after failing to find a library through the normal ways
45 ;;; (eg: on Linux LD_LIBRARY_PATH, /etc/ld.so.cache, /usr/lib/, /lib)
46 ;;; do we try to find the library ourselves.
47
48 (defun explode-path-environment-variable (name)
49 (mapcar #'uiop:ensure-directory-pathname
50 (split-if (lambda (c) (eql #\: c))
51 (uiop:getenv name)
52 :elide)))
53
54 (defun darwin-fallback-library-path ()
55 (or (explode-path-environment-variable "DYLD_FALLBACK_LIBRARY_PATH")
56 (list (merge-pathnames #p"lib/" (user-homedir-pathname))
57 #p"/usr/local/lib/"
58 #p"/usr/lib/")))
59
60 (defvar *foreign-library-directories*
61 (if (featurep :darwin)
62 '((explode-path-environment-variable "LD_LIBRARY_PATH")
63 (explode-path-environment-variable "DYLD_LIBRARY_PATH")
64 (uiop:getcwd)
65 (darwin-fallback-library-path))
66 '())
67 "List onto which user-defined library paths can be pushed.")
68
69 (defun fallback-darwin-framework-directories ()
70 (or (explode-path-environment-variable "DYLD_FALLBACK_FRAMEWORK_PATH")
71 (list (uiop:getcwd)
72 (merge-pathnames #p"Library/Frameworks/" (user-homedir-pathname))
73 #p"/Library/Frameworks/"
74 #p"/System/Library/Frameworks/")))
75
76 (defvar *darwin-framework-directories*
77 '((explode-path-environment-variable "DYLD_FRAMEWORK_PATH")
78 (fallback-darwin-framework-directories))
79 "List of directories where Frameworks are searched for.")
80
81 (defun mini-eval (form)
82 "Simple EVAL-like function to evaluate the elements of
83 *FOREIGN-LIBRARY-DIRECTORIES* and *DARWIN-FRAMEWORK-DIRECTORIES*."
84 (typecase form
85 (cons (apply (car form) (mapcar #'mini-eval (cdr form))))
86 (symbol (symbol-value form))
87 (t form)))
88
89 (defun parse-directories (list)
90 (mappend (compose #'ensure-list #'mini-eval) list))
91
92 (defun find-file (path directories)
93 "Searches for PATH in a list of DIRECTORIES and returns the first it finds."
94 (some (lambda (directory) (probe-file (merge-pathnames path directory)))
95 directories))
96
97 (defun find-darwin-framework (framework-name)
98 "Searches for FRAMEWORK-NAME in *DARWIN-FRAMEWORK-DIRECTORIES*."
99 (dolist (directory (parse-directories *darwin-framework-directories*))
100 (let ((path (make-pathname
101 :name framework-name
102 :directory
103 (append (pathname-directory directory)
104 (list (format nil "~A.framework" framework-name))))))
105 (when (probe-file path)
106 (return-from find-darwin-framework path)))))
107
108 ;;;# Defining Foreign Libraries
109 ;;;
110 ;;; Foreign libraries can be defined using the
111 ;;; DEFINE-FOREIGN-LIBRARY macro. Example usage:
112 ;;;
113 ;;; (define-foreign-library opengl
114 ;;; (:darwin (:framework "OpenGL"))
115 ;;; (:unix (:or "libGL.so" "libGL.so.1"
116 ;;; #p"/myhome/mylibGL.so"))
117 ;;; (:windows "opengl32.dll")
118 ;;; ;; an hypothetical example of a particular platform
119 ;;; ((:and :some-system :some-cpu) "libGL-support.lib")
120 ;;; ;; if no other clauses apply, this one will and a type will be
121 ;;; ;; automagically appended to the name passed to :default
122 ;;; (t (:default "libGL")))
123 ;;;
124 ;;; This information is stored in the *FOREIGN-LIBRARIES* hashtable
125 ;;; and when the library is loaded through LOAD-FOREIGN-LIBRARY (or
126 ;;; USE-FOREIGN-LIBRARY) the first clause matched by FEATUREP is
127 ;;; processed.
128
129 (defvar *foreign-libraries* (make-hash-table :test 'eq)
130 "Hashtable of defined libraries.")
131
132 (defclass foreign-library ()
133 ((name :initform nil :initarg :name :accessor foreign-library-name)
134 (type :initform :system :initarg :type)
135 (spec :initarg :spec)
136 (options :initform nil :initarg :options)
137 (handle :initform nil :initarg :handle :accessor foreign-library-handle)
138 (pathname :initform nil)))
139
140 (defmethod print-object ((library foreign-library) stream)
141 (with-slots (name pathname) library
142 (print-unreadable-object (library stream :type t)
143 (when name
144 (format stream "~A" name))
145 (when pathname
146 (format stream " ~S" (file-namestring pathname))))))
147
148 (define-condition foreign-library-undefined-error (error)
149 ((name :initarg :name :reader fl-name))
150 (:report (lambda (c s)
151 (format s "Undefined foreign library: ~S"
152 (fl-name c)))))
153
154 (defun get-foreign-library (lib)
155 "Look up a library by NAME, signalling an error if not found."
156 (if (typep lib 'foreign-library)
157 lib
158 (or (gethash lib *foreign-libraries*)
159 (error 'foreign-library-undefined-error :name lib))))
160
161 (defun (setf get-foreign-library) (value name)
162 (setf (gethash name *foreign-libraries*) value))
163
164 (defun foreign-library-type (lib)
165 (slot-value (get-foreign-library lib) 'type))
166
167 (defun foreign-library-pathname (lib)
168 (slot-value (get-foreign-library lib) 'pathname))
169
170 (defun %foreign-library-spec (lib)
171 (assoc-if (lambda (feature)
172 (or (eq feature t)
173 (featurep feature)))
174 (slot-value lib 'spec)))
175
176 (defun foreign-library-spec (lib)
177 (second (%foreign-library-spec lib)))
178
179 (defun foreign-library-options (lib)
180 (append (cddr (%foreign-library-spec lib))
181 (slot-value lib 'options)))
182
183 (defun foreign-library-search-path (lib)
184 (loop for (opt val) on (foreign-library-options lib) by #'cddr
185 when (eql opt :search-path)
186 append (ensure-list val) into search-path
187 finally (return (mapcar #'pathname search-path))))
188
189 (defun foreign-library-loaded-p (lib)
190 (not (null (foreign-library-handle (get-foreign-library lib)))))
191
192 (defun list-foreign-libraries (&key (loaded-only t) type)
193 "Return a list of defined foreign libraries.
194 If LOADED-ONLY is non-null only loaded libraries are returned.
195 TYPE restricts the output to a specific library type: if NIL
196 all libraries are returned."
197 (let ((libs (hash-table-values *foreign-libraries*)))
198 (remove-if (lambda (lib)
199 (or (and type
200 (not (eql type (foreign-library-type lib))))
201 (and loaded-only
202 (not (foreign-library-loaded-p lib)))))
203 libs)))
204
205 ;; :CONVENTION, :CALLING-CONVENTION and :CCONV are coalesced,
206 ;; the former taking priority
207 ;; options with NULL values are removed
208 (defun clean-spec-up (spec)
209 (mapcar (lambda (x)
210 (list* (first x) (second x)
211 (let* ((opts (cddr x))
212 (cconv (getf opts :cconv))
213 (calling-convention (getf opts :calling-convention))
214 (convention (getf opts :convention))
215 (search-path (getf opts :search-path)))
216 (remf opts :cconv) (remf opts :calling-convention)
217 (when cconv
218 (warn-obsolete-argument :cconv :convention))
219 (when calling-convention
220 (warn-obsolete-argument :calling-convention
221 :convention))
222 (setf (getf opts :convention)
223 (or convention calling-convention cconv))
224 (setf (getf opts :search-path)
225 (mapcar #'pathname (ensure-list search-path)))
226 (loop for (opt val) on opts by #'cddr
227 when val append (list opt val) into new-opts
228 finally (return new-opts)))))
229 spec))
230
231 (defmethod initialize-instance :after
232 ((lib foreign-library) &key search-path
233 (cconv :cdecl cconv-p)
234 (calling-convention cconv calling-convention-p)
235 (convention calling-convention))
236 (with-slots (type options spec) lib
237 (check-type type (member :system :test :grovel-wrapper))
238 (setf spec (clean-spec-up spec))
239 (let ((all-options
240 (apply #'append options (mapcar #'cddr spec))))
241 (assert (subsetp (loop for (key . nil) on all-options by #'cddr
242 collect key)
243 '(:convention :search-path)))
244 (when cconv-p
245 (warn-obsolete-argument :cconv :convention))
246 (when calling-convention-p
247 (warn-obsolete-argument :calling-convention :convention))
248 (flet ((set-option (key value)
249 (when value (setf (getf options key) value))))
250 (set-option :convention convention)
251 (set-option :search-path
252 (mapcar #'pathname (ensure-list search-path)))))))
253
254 (defun register-foreign-library (name spec &rest options)
255 (let ((old-handle
256 (when-let ((old-lib (gethash name *foreign-libraries*)))
257 (foreign-library-handle old-lib))))
258 (setf (get-foreign-library name)
259 (apply #'make-instance 'foreign-library
260 :name name
261 :spec spec
262 :handle old-handle
263 options))
264 name))
265
266 (defmacro define-foreign-library (name-and-options &body pairs)
267 "Defines a foreign library NAME that can be posteriorly used with
268 the USE-FOREIGN-LIBRARY macro."
269 (destructuring-bind (name . options)
270 (ensure-list name-and-options)
271 (check-type name symbol)
272 `(register-foreign-library ',name ',pairs ,@options)))
273
274 ;;;# LOAD-FOREIGN-LIBRARY-ERROR condition
275 ;;;
276 ;;; The various helper functions that load foreign libraries can
277 ;;; signal this error when something goes wrong. We ignore the host's
278 ;;; error. We should probably reuse its error message.
279
280 (define-condition load-foreign-library-error (simple-error)
281 ())
282
283 (defun read-new-value ()
284 (format *query-io* "~&Enter a new value (unevaluated): ")
285 (force-output *query-io*)
286 (read *query-io*))
287
288 (defun fl-error (control &rest arguments)
289 (error 'load-foreign-library-error
290 :format-control control
291 :format-arguments arguments))
292
293 ;;;# Loading Foreign Libraries
294
295 (defun load-darwin-framework (name framework-name)
296 "Tries to find and load a darwin framework in one of the directories
297 in *DARWIN-FRAMEWORK-DIRECTORIES*. If unable to find FRAMEWORK-NAME,
298 it signals a LOAD-FOREIGN-LIBRARY-ERROR."
299 (let ((framework (find-darwin-framework framework-name)))
300 (if framework
301 (load-foreign-library-path name (native-namestring framework))
302 (fl-error "Unable to find framework ~A" framework-name))))
303
304 (defun report-simple-error (name error)
305 (fl-error "Unable to load foreign library (~A).~% ~A"
306 name
307 (format nil "~?" (simple-condition-format-control error)
308 (simple-condition-format-arguments error))))
309
310 ;;; FIXME: haven't double checked whether all Lisps signal a
311 ;;; SIMPLE-ERROR on %load-foreign-library failure. In any case they
312 ;;; should be throwing a more specific error.
313 (defun load-foreign-library-path (name path &optional search-path)
314 "Tries to load PATH using %LOAD-FOREIGN-LIBRARY which should try and
315 find it using the OS's usual methods. If that fails we try to find it
316 ourselves."
317 (handler-case
318 (values (%load-foreign-library name path)
319 (pathname path))
320 (simple-error (error)
321 (let ((dirs (parse-directories *foreign-library-directories*)))
322 (if-let (file (find-file path (append search-path dirs)))
323 (handler-case
324 (values (%load-foreign-library name (native-namestring file))
325 file)
326 (simple-error (error)
327 (report-simple-error name error)))
328 (report-simple-error name error))))))
329
330 (defun try-foreign-library-alternatives (name library-list &optional search-path)
331 "Goes through a list of alternatives and only signals an error when
332 none of alternatives were successfully loaded."
333 (dolist (lib library-list)
334 (multiple-value-bind (handle pathname)
335 (ignore-errors (load-foreign-library-helper name lib search-path))
336 (when handle
337 (return-from try-foreign-library-alternatives
338 (values handle pathname)))))
339 ;; Perhaps we should show the error messages we got for each
340 ;; alternative if we can figure out a nice way to do that.
341 (fl-error "Unable to load any of the alternatives:~% ~S" library-list))
342
343 (defparameter *cffi-feature-suffix-map*
344 '((:windows . ".dll")
345 (:darwin . ".dylib")
346 (:unix . ".so")
347 (t . ".so"))
348 "Mapping of OS feature keywords to shared library suffixes.")
349
350 (defun default-library-suffix ()
351 "Return a string to use as default library suffix based on the
352 operating system. This is used to implement the :DEFAULT option.
353 This will need to be extended as we test on more OSes."
354 (or (cdr (assoc-if #'featurep *cffi-feature-suffix-map*))
355 (fl-error "Unable to determine the default library suffix on this OS.")))
356
357 (defun load-foreign-library-helper (name thing &optional search-path)
358 (etypecase thing
359 ((or pathname string)
360 (load-foreign-library-path name (filter-pathname thing) search-path))
361 (cons
362 (ecase (first thing)
363 (:framework (load-darwin-framework name (second thing)))
364 (:default
365 (unless (stringp (second thing))
366 (fl-error "Argument to :DEFAULT must be a string."))
367 (let ((library-path
368 (concatenate 'string
369 (second thing)
370 (default-library-suffix))))
371 (load-foreign-library-path name library-path search-path)))
372 (:or (try-foreign-library-alternatives name (rest thing) search-path))))))
373
374 (defun %do-load-foreign-library (library search-path)
375 (flet ((%do-load (lib name spec)
376 (when (foreign-library-spec lib)
377 (with-slots (handle pathname) lib
378 (setf (values handle pathname)
379 (load-foreign-library-helper
380 name spec (foreign-library-search-path lib)))))
381 lib))
382 (etypecase library
383 (symbol
384 (let* ((lib (get-foreign-library library))
385 (spec (foreign-library-spec lib)))
386 (%do-load lib library spec)))
387 ((or string list)
388 (let* ((lib-name (gensym
389 (format nil "~:@(~A~)-"
390 (if (listp library)
391 (first library)
392 (file-namestring library)))))
393 (lib (make-instance 'foreign-library
394 :type :system
395 :name lib-name
396 :spec `((t ,library))
397 :search-path search-path)))
398 ;; first try to load the anonymous library
399 ;; and register it only if that worked
400 (%do-load lib lib-name library)
401 (setf (get-foreign-library lib-name) lib))))))
402
403 (defun filter-pathname (thing)
404 (typecase thing
405 (pathname (namestring thing))
406 (t thing)))
407
408 (defun load-foreign-library (library &key search-path)
409 "Loads a foreign LIBRARY which can be a symbol denoting a library defined
410 through DEFINE-FOREIGN-LIBRARY; a pathname or string in which case we try to
411 load it directly first then search for it in *FOREIGN-LIBRARY-DIRECTORIES*;
412 or finally list: either (:or lib1 lib2) or (:framework <framework-name>)."
413 (let ((library (filter-pathname library)))
414 (restart-case
415 (progn
416 ;; dlopen/dlclose does reference counting, but the CFFI-SYS
417 ;; API has no infrastructure to track that. Therefore if we
418 ;; want to avoid increasing the internal dlopen reference
419 ;; counter, and thus thwarting dlclose, then we need to try
420 ;; to call CLOSE-FOREIGN-LIBRARY and ignore any signaled
421 ;; errors.
422 (ignore-some-conditions (foreign-library-undefined-error)
423 (close-foreign-library library))
424 (%do-load-foreign-library library search-path))
425 ;; Offer these restarts that will retry the call to
426 ;; %LOAD-FOREIGN-LIBRARY.
427 (retry ()
428 :report "Try loading the foreign library again."
429 (load-foreign-library library :search-path search-path))
430 (use-value (new-library)
431 :report "Use another library instead."
432 :interactive read-new-value
433 (load-foreign-library new-library :search-path search-path)))))
434
435 (defmacro use-foreign-library (name)
436 `(load-foreign-library ',name))
437
438 ;;;# Closing Foreign Libraries
439
440 (defun close-foreign-library (library)
441 "Closes a foreign library."
442 (let* ((library (filter-pathname library))
443 (lib (get-foreign-library library))
444 (handle (foreign-library-handle lib)))
445 (when handle
446 (%close-foreign-library handle)
447 (setf (foreign-library-handle lib) nil)
448 t)))
449
450 (defun reload-foreign-libraries (&key (test #'foreign-library-loaded-p))
451 "(Re)load all currently loaded foreign libraries."
452 (let ((libs (list-foreign-libraries)))
453 (loop for l in libs
454 for name = (foreign-library-name l)
455 when (funcall test name)
456 do (load-foreign-library name))
457 libs))