+;;; Shared libraries
+
+(defclass library (component)
+ ((libdir :initarg :libdir :initform nil)
+ (libname :initarg :libname :initform nil)
+ (absolute :initform *absolute-paths-as-default*
+ :initarg :absolute :reader absolute-p)))
+
+
+(defun split-path (path)
+ (when path
+ (labels ((split (path)
+ (unless (zerop (length path))
+ (let ((slash (position #\/ path)))
+ (if slash
+ (cons (subseq path 0 slash) (split (subseq path (1+ slash))))
+ (list path))))))
+ (if (and (not (zerop (length path))) (char= (char path 0) #\/))
+ (cons :absolute (split (subseq path 1)))
+ (cons :relative (split path))))))
+
+
+(defmethod component-pathname ((lib library))
+ (or
+ (when (slot-value lib 'libname)
+ (let ((filename (format nil "~A~A" (namestring (make-pathname :directory (split-path (slot-value lib 'libdir)))) (slot-value lib 'libname))))
+ (when (probe-file filename)
+ (pathname filename))))
+
+ (make-pathname
+ :type *dso-extension*
+ :name (or (slot-value lib 'libname) (component-name lib))
+ :directory (split-path (slot-value lib 'libdir)))))
+
+(defmethod perform ((o load-op) (lib library))
+ (load-shared-object (component-pathname lib) (absolute-p lib)))
+
+(defmethod perform ((operation operation) (lib library))
+ nil)
+
+(defmethod operation-done-p ((o load-op) (lib library))
+ (let* ((namestring (ensure-namestring (component-pathname lib)))
+ (directory (namestring (pathname-sans-name+type namestring)))
+ (name+type (subseq namestring (length directory)))
+ (stored-name (if (absolute-p lib) namestring name+type)))
+
+ #+sbcl(find stored-name sb-alien::*shared-objects* :key #'sb-alien::shared-object-file :test #'equal)
+ #+cmu(rassoc stored-name system::*global-table* :test #'equal)
+ #+clisp(find stored-name *loaded-libraries* :test #'equal)))
+
+(defmethod operation-done-p ((o operation) (lib library))
+ t)
+
+
+;;; Binding of dynamic variables during perform
+
+(defvar *operation* nil)
+(defvar *system* nil)
+(defvar *component* nil)
+
+(defmethod perform :around ((operation operation) (c component))
+ (let ((*operation* operation)
+ (*component* c)
+ (*system* (component-system c)))
+ (call-next-method)))