Add shelf's root systems slot and ASDF operations on a shelf.
Wed May 20 13:05:05 PDT 2009 Maciej Pasternacki <maciej@pasternacki.net>
* Add shelf's root systems slot and ASDF operations on a shelf.
diff -rN -u old-cl-librarian/src/package.lisp new-cl-librarian/src/package.lisp
--- old-cl-librarian/src/package.lisp 2014-08-02 01:37:07.000000000 -0700
+++ new-cl-librarian/src/package.lisp 2014-08-02 01:37:07.000000000 -0700
@@ -11,6 +11,7 @@
#:repo #:darcs-repo #:svn-repo #:cvs-repo #:git-repo #:hg-repo #:tarball-repo
#:system-pathnames
#:use-shelf #:unuse-shelf #:*used-shelves* #:search-system-in-shelves
+ #:asdf-operate-on-shelf #:load-shelf
#:*asdf-install-fallback* #:*shelves-dir* #:*git-command* #:*hg-command*
#:*svn-command* #:*cvs-command* #:*darcs-command*
#:*wget-command* #:*scp-command* #:*tar-command*
diff -rN -u old-cl-librarian/src/shelves.lisp new-cl-librarian/src/shelves.lisp
--- old-cl-librarian/src/shelves.lisp 2014-08-02 01:37:07.000000000 -0700
+++ new-cl-librarian/src/shelves.lisp 2014-08-02 01:37:07.000000000 -0700
@@ -10,7 +10,8 @@
(includes :initarg :includes :accessor shelf-includes)
(included-by :initform nil :accessor shelf-included-by)
(immediate-contents :initarg :immediate-contents :accessor shelf-immediate-contents)
- (contents :accessor shelf-contents)))
+ (contents :accessor shelf-contents)
+ (root-systems :accessor shelf-root-systems :initarg :root-systems :initform nil)))
(defmethod shared-initialize :after ((shelf shelf) slots &key &allow-other-keys)
(declare (ignore slots))
@@ -51,20 +52,20 @@
shelf)
-(defun define-shelf (name &key (includes nil includes-p) (immediate-contents nil immediate-contents-p) directory)
+(defun define-shelf (name &key (includes nil includes-p) (immediate-contents nil immediate-contents-p) directory root-systems)
"DEFSHELF's workhorse."
(setf name (canonicalize-shelf-name name))
(let ((shelf (or (gethash name *shelves*) ; When shelf exists, we only update it
(setf (gethash name *shelves*) ; Otherwise, we must create one
- (make-instance 'shelf :name name :directory directory)))))
+ (make-instance 'shelf :name name :directory directory :root-systems root-systems)))))
(when includes-p
(setf (shelf-includes shelf) includes))
(when immediate-contents-p
(setf (shelf-immediate-contents shelf) immediate-contents))
(finalize-shelf shelf)))
-(defmacro defshelf (name includes immediate-contents &key directory)
+(defmacro defshelf (name includes immediate-contents &key directory root-systems)
`(define-shelf ',name
:includes ',includes
:immediate-contents (list
@@ -73,7 +74,8 @@
`(find-library ',lib)
`(deflibrary ,@lib)))
immediate-contents))
- :directory ,directory))
+ ,@(when directory `(:directory ,directory))
+ ,@(when root-systems `(:root-systems ',root-systems))))
(defun find-shelf (name &key force-reload)
"Find shelf `NAME', returning its shelf object.
@@ -190,6 +192,17 @@
(setf *used-shelves*
(delete shelf *used-shelves*))))
+(defun asdf-operate-on-shelf (shelf operation &rest args)
+ "Perform ASDF operation OPERATION on shelf SHELF"
+ (with-shelf (shelf)
+ (mapcar #'(lambda (system)
+ (apply #'asdf:operate operation system args))
+ (shelf-root-systems shelf))))
+
+(defun load-shelf (shelf)
+ "Load shelf's root ASDF systems."
+ (asdf-operate-on-shelf shelf 'asdf:load-op))
+
(defun shelf&repo-systems (shelf repo)
(mapcan #'(lambda (pathname)
(directory