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