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