GopherProxy

	tlibraries.lisp - clic - Clic is an command line interactive client for gopher …
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tlibraries.lisp (18805B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; libraries.lisp --- Finding and loading foreign libraries.
	4 ;;;
	5 ;;; Copyright (C) 2005-2006, James Bielman <[email protected]>
	6 ;;; Copyright (C) 2006-2007, Luis Oliveira <[email protected]>
	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-pathn…
	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 f…
	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-hand…
	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-conven…
	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 (simple-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 fil…
	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 sea…
	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-lis…
	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 …
	356
	357 (defun load-foreign-library-helper (name thing &optional search-path)
	358 (etypecase thing
	359 ((or pathname string)
	360 (load-foreign-library-path name (filter-pathname 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-p…
	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 defi…
	410 through DEFINE-FOREIGN-LIBRARY; a pathname or string in which case we tr…
	411 load it directly first then search for it in *FOREIGN-LIBRARY-DIRECTORIE…
	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))