external/cffi.darcs/src/libraries.lisp

   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 *query-io* "~&Enter a new value (unevaluated): ")
 161   (force-output *query-io*)
 162   (read *query-io*))
 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 report-simple-error (name error)
 181   (fl-error "Unable to load foreign library (~A).~%  ~A"
 182             name
 183             (format nil "~?" (simple-condition-format-control error)
 184                     (simple-condition-format-arguments error))))
 185
 186 ;;; FIXME: haven't double checked whether all Lisps signal a
 187 ;;; SIMPLE-ERROR on %load-foreign-library failure.  In any case they
 188 ;;; should be throwing a more specific error.
 189 (defun load-foreign-library-path (name path)
 190   "Tries to load PATH using %LOAD-FOREIGN-LIBRARY which should try and
 191 find it using the OS's usual methods. If that fails we try to find it
 192 ourselves."
 193   (handler-case
 194       (%load-foreign-library name path)
 195     (error (error)
 196       (bif (file (find-file path *foreign-library-directories*))
 197            (handler-case
 198                (%load-foreign-library name (native-namestring file))
 199              (simple-error (error)
 200                (report-simple-error name error)))
 201            (report-simple-error name error)))))
 202
 203 (defun try-foreign-library-alternatives (name library-list)
 204   "Goes through a list of alternatives and only signals an error when
 205 none of alternatives were successfully loaded."
 206   (dolist (lib library-list)
 207     (let-when (handle (ignore-errors (load-foreign-library-helper name lib)))
 208       (return-from try-foreign-library-alternatives handle)))
 209   ;; Perhaps we should show the error messages we got for each
 210   ;; alternative if we can figure out a nice way to do that.
 211   (fl-error "Unable to load any of the alternatives:~%   ~S" library-list))
 212
 213 (defparameter *cffi-feature-suffix-map*
 214   '((cffi-features:windows . ".dll")
 215     (cffi-features:darwin . ".dylib")
 216     (cffi-features:unix . ".so"))
 217   "Mapping of OS feature keywords to shared library suffixes.")
 218
 219 (defun default-library-suffix ()
 220   "Return a string to use as default library suffix based on the
 221 operating system.  This is used to implement the :DEFAULT option.
 222 This will need to be extended as we test on more OSes."
 223   (or (cdr (assoc-if #'cffi-feature-p *cffi-feature-suffix-map*))
 224       (fl-error "Unable to determine the default library suffix on this OS.")))
 225
 226 (defun load-foreign-library-helper (name thing)
 227   (etypecase thing
 228     (string
 229      (load-foreign-library-path name thing))
 230     (pathname
 231      (load-foreign-library-path name (namestring thing)))
 232     (cons
 233      (ecase (first thing)
 234        (:framework (load-darwin-framework name (second thing)))
 235        (:default
 236         (unless (stringp (second thing))
 237           (fl-error "Argument to :DEFAULT must be a string."))
 238         (load-foreign-library-path
 239          name (concatenate 'string (second thing) (default-library-suffix))))
 240        (:or (try-foreign-library-alternatives name (rest thing)))))))
 241
 242 (defun load-foreign-library (library)
 243   "Loads a foreign LIBRARY which can be a symbol denoting a library defined
 244 through DEFINE-FOREIGN-LIBRARY; a pathname or string in which case we try to
 245 load it directly first then search for it in *FOREIGN-LIBRARY-DIRECTORIES*;
 246 or finally list: either (:or lib1 lib2) or (:framework <framework-name>)."
 247   (restart-case
 248       (typecase library
 249         (symbol
 250          (let* ((lib (get-foreign-library library))
 251                 (spec (foreign-library-spec lib)))
 252            (when spec
 253              (setf (foreign-library-handle lib)
 254                    (load-foreign-library-helper library spec))
 255              lib)))
 256         (t
 257          (make-instance 'foreign-library :spec (list (list library))
 258                         :handle (load-foreign-library-helper nil library))))
 259     ;; Offer these restarts that will retry the call to
 260     ;; LOAD-FOREIGN-LIBRARY.
 261     (retry ()
 262       :report "Try loading the foreign library again."
 263       (load-foreign-library library))
 264     (use-value (new-library)
 265       :report "Use another library instead."
 266       :interactive read-new-value
 267       (load-foreign-library new-library))))
 268
 269 (defmacro use-foreign-library (name)
 270   `(load-foreign-library ',name))
 271
 272 ;;;# Closing Foreign Libraries
 273
 274 (defun close-foreign-library (library)
 275   "Closes a foreign library."
 276   (let ((lib (get-foreign-library library)))
 277     (when (foreign-library-handle lib)
 278       (%close-foreign-library (foreign-library-handle lib))
 279       (setf (foreign-library-handle lib) nil)
 280       t)))