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