Coverage report: /home/luis/src/cffi/src/libraries.lisp

KindCoveredAll%
expression82148 55.4
branch312 25.0
Key
Not instrumented
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
 ;;; though.
42
 ;;;
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.
46
 
47
 (defvar *foreign-library-directories* '()
48
   "List onto which user-defined library paths can be pushed.")
49
 
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.")
55
 
56
 (defun mini-eval (form)
57
   "Simple EVAL-like function to evaluate the elements of
58
 *FOREIGN-LIBRARY-DIRECTORIES* and *DARWIN-FRAMEWORK-DIRECTORIES*."
59
   (typecase form
60
     (cons (apply (car form) (mapcar #'mini-eval (cdr form))))
61
     (symbol (symbol-value form))
62
     (t form)))
63
 
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)))
67
         directories))
68
 
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
73
                  :name framework-name
74
                  :directory
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)))))
79
 
80
 ;;;# Defining Foreign Libraries
81
 ;;;
82
 ;;; Foreign libraries can be defined using the
83
 ;;; DEFINE-FOREIGN-LIBRARY macro. Example usage:
84
 ;;;
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")))
95
 ;;;
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
99
 ;;; processed.
100
 
101
 (defvar *foreign-libraries* (make-hash-table :test 'eq)
102
   "Hashtable of defined libraries.")
103
 
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)
107
       lib
108
       (or (gethash lib *foreign-libraries*)
109
           (error "Undefined foreign library: ~S" lib))))
110
 
111
 (defun (setf get-foreign-library) (value name)
112
   (setf (gethash name *foreign-libraries*) value))
113
 
114
 (defclass foreign-library ()
115
   ((spec :initarg :spec)
116
    (options :initform nil :initarg :options)
117
    (handle :initarg :handle :accessor foreign-library-handle)))
118
 
119
 (defun %foreign-library-spec (lib)
120
   (assoc-if #'cffi-feature-p (slot-value lib 'spec)))
121
 
122
 (defun foreign-library-spec (lib)
123
   (second (%foreign-library-spec lib)))
124
 
125
 (defun foreign-library-options (lib)
126
   (append (cddr (%foreign-library-spec lib))
127
           (slot-value lib 'options)))
128
 
129
 ;;; Warn about unkown options.
130
 (defmethod initialize-instance :after ((lib foreign-library) &key)
131
   (loop for (opt nil)
132
         on (append (slot-value lib 'options)
133
                    (mapcan (lambda (x) (copy-list (cddr x)))
134
                            (slot-value lib 'spec)))
135
         by #'cddr
136
         when (not (member opt '(:cconv :calling-convention)))
137
         do (warn "Unkown option: ~A" opt)))
138
 
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)
144
     `(progn
145
        (setf (get-foreign-library ',name)
146
              (make-instance 'foreign-library
147
                             :spec ',pairs :options ',options))
148
        ',name)))
149
 
150
 ;;;# LOAD-FOREIGN-LIBRARY-ERROR condition
151
 ;;;
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.
155
 
156
 (define-condition load-foreign-library-error (simple-error)
157
   ())
158
 
159
 (defun read-new-value ()
160
   (format t "~&Enter a new value (unevaluated): ")
161
   (force-output)
162
   (read))
163
 
164
 (defun fl-error (control &rest arguments)
165
   (error 'load-foreign-library-error
166
          :format-control control
167
          :format-arguments arguments))
168
 
169
 ;;;# Loading Foreign Libraries
170
 
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)))
176
     (if framework
177
         (load-foreign-library-path name (native-namestring framework))
178
         (fl-error "Unable to find framework ~A" framework-name))))
179
 
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
183
 ourselves."
184
   (or (ignore-errors (%load-foreign-library name path))
185
       (let ((file (find-file path *foreign-library-directories*)))
186
         (when file
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)))
190
 
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))
198
 
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.")
204
 
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.")))
211
 
212
 (defun load-foreign-library-helper (name thing)
213
   (etypecase thing
214
     (string
215
      (load-foreign-library-path name thing))
216
     (pathname
217
      (load-foreign-library-path name (namestring thing)))
218
     (cons
219
      (ecase (first thing)
220
        (:framework (load-darwin-framework name (second thing)))
221
        (:default
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)))))))
227
 
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>)."
233
   (restart-case
234
       (typecase library
235
         (symbol
236
          (let* ((lib (get-foreign-library library))
237
                 (spec (foreign-library-spec lib)))
238
            (when spec
239
              (setf (foreign-library-handle lib)
240
                    (load-foreign-library-helper library spec))
241
              lib)))
242
         (t
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.
247
     (retry ()
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))))
254
 
255
 (defmacro use-foreign-library (name)
256
   `(load-foreign-library ',name))
257
 
258
 ;;;# Closing Foreign Libraries
259
 
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)
266
       t)))
267