Coverage report: /home/ellis/.stash/quicklisp/dists/quicklisp/software/cffi-20250622-git/src/libraries.lisp

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