3rdparties/software/cffi_0.21.0/src/libraries.lisp (18837 bytes)
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))