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 ;;; 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))