Unit test for asdf's topological sort

I have written a unit test framework, and a few tests, that
test asdf's topological sort.  You write a defsystem whose
components are all of a type called test-file.  Then you
define as many tests as you want for the system, specifying
which files are already compiled as part of the initial
conditions, and saying as much as you want about the outcome
for each component: whether or not it is compiled and loaded,
and what partial orderings must be satisfied for the sort
to have done its job properly.

The cute thing is that it is entirely "black box"; it does
not peer into the asdf internals, but merely extends asdf
using the defined extension mechanism.

I did not find any bugs with it, nor did I expect to, but
if anybody tinkers with the algorithm in the future, this
set of tests might come in handy to help reduce the chance
that bugs might be introduced by such changes.  Please feel
free to add it to the set of asdf tests if you would like to.

-- Dan

;;; -*- Lisp -*-
;;; By Dan Weinreb, Oct 1, 2006.  Public domain, entirely free, etc.

(defvar *all-tests* nil)

(defclass test ()
  ((system-name :initarg :system-name :reader test-system-name)
   (operation-name :initarg :operation-name :reader test-operation-name)
   (already-compiled :initarg :already-compiled :reader test-already-compiled)
   (expected :initarg :expected :reader test-expected)))
  
(defmacro define-test (test-name system-name 
		       &key operation-name already-compiled expected)
  `(progn
     (push ',test-name *all-tests*)
     (setf (get ',test-name 'test)
	   (make-instance 'test
	     :system-name ',system-name
	     :operation-name ',operation-name
	     :already-compiled ',already-compiled
	     :expected ',expected))))

(defclass test-file (asdf:component) ())

(defvar *test* nil)

(defvar *steps* nil)

(defmethod asdf:operation-done-p ((o asdf:compile-op) (c test-file))
  (declare (ignorable o))
  (member (asdf:component-name c) (test-already-compiled *test*) 
	  :test #'string=))

(defmethod asdf:operation-done-p ((o asdf:operation) (c test-file))
  (declare (ignorable o c))
  nil)

(defmethod asdf:perform ((o asdf:compile-op) (c test-file))
  (declare (ignorable o))
  (push (cons :compiled (asdf:component-name c)) *steps*))

(defmethod asdf:perform ((o asdf:load-op) (c test-file))
  (declare (ignorable o))
  (push (cons :loaded (asdf:component-name c)) *steps*))

(defun run-unit-test (test-name)
  (let ((*test* (get test-name 'test))
	(*steps* nil)
	(succeeded t))
    (flet ((fail (format-string &rest format-args)
	     (setq succeeded nil)
	     (apply #'format t format-string format-args)
	     (terpri)))
      (let ((system-name (test-system-name *test*))
	    (operation-name (test-operation-name *test*)))
	(check-type system-name symbol)
	(check-type operation-name symbol)
	(asdf:operate operation-name system-name))
      (setq *steps* (nreverse *steps*))
      (loop for steps on *steps* do
	(when (member (first steps) (rest steps) :test #'equal)
	  (fail "The step ~S happened more than once: ~S"
		(first steps) *steps*)))
      (dolist (expectation (test-expected *test*))
	(destructuring-bind (op file &rest at) 
	    expectation
	  (check-type file string)
	  (ecase op
	    ((:compiled :loaded)
	     (let ((pos (position (cons op file) *steps* :test #'equal)))
	       (if (null pos)
		 (fail "~S was not ~A" file op)
		 (loop for (relationship file2) on at by #'cddr do
		   (check-type file2 string)
		   (let* ((op2 (ecase relationship 
				 (:after-loading :loaded) 
				 (:after-compiling :compiled)))
			  (pos2 (position (cons op2 file2) *steps*
					  :test #'equal)))
		     (cond ((null pos2)
			    (fail "~S was not ~A at all ~A ~A"
				  file op relationship file2))
			   ((< pos pos2)
			    (fail "Wrong order between ~A of ~S and ~A of ~S"
				  op file op2 file2))))))))
	    (:did-not-compile 
	     (when (member (cons :compiled file) *steps*)
	       (fail "~A compiled but should not have" file)))
	    (:did-not-load
	     (when (member (cons :loaded file) *steps*)
	       (fail "~A loaded but should not have" file)))))))))

(defun run-all-unit-tests ()
  (dolist (test-name *all-tests*)
    (run-unit-test test-name)))

(asdf:defsystem system-1
  :components ((:test-file "a")
	       (:test-file "b")
	       (:test-file "c" :depends-on ("b"))
	       (:test-file "d")))


(define-test test-1 system-1
  :operation-name asdf:load-op
  :already-compiled ("b")
  :expected ((:compiled "a")
	     (:loaded "a" :after-compiling "a")
	     (:did-not-compile "b")
	     (:loaded "b")
	     (:compiled "c" :after-loading "b")
	     (:loaded "c" :after-loading "b" :after-compiling "c")
	     (:compiled "d")
	     (:loaded "d" :after-compiling "d")))

(asdf:defsystem system-2
  :components ((:test-file "a" :depends-on ("g" "k"))
	       (:test-file "b")
	       (:test-file "c" :depends-on ("b"))
	       (:test-file "d" :depends-on ("e"))
	       (:test-file "e")
	       (:test-file "f" :depends-on ("c"))
	       (:test-file "g" :depends-on ("h"))
	       (:test-file "h")
	       (:test-file "i" :depends-on ("f" "b"))
	       (:test-file "j" :depends-on ("f" "c"))
	       (:test-file "k")
	       (:test-file "l" :depends-on ("d"))))

(define-test test-2 system-2
  :operation-name asdf:load-op
  :already-compiled ()
  :expected ((:compiled "a" :after-compiling "g" :after-compiling "k"
			:after-compiling "h" :after-loading "g" 
			:after-loading "k" :after-loading "h")
	     (:loaded "a" :after-compiling "a")
	     (:compiled "b")
	     (:loaded "b" :after-compiling "b")
	     (:compiled "c" :after-compiling "b" :after-loading "b")
	     (:loaded "c"   :after-compiling "b" :after-loading "b"
		      :after-compiling "c")
	     (:compiled "d" :after-compiling "e")
	     (:compiled "e")
	     (:compiled "f" :after-compiling "c" :after-compiling "b")
	     (:compiled "g" :after-compiling "h")
	     (:compiled "h")
	     (:compiled "i" :after-compiling "f" :after-compiling "b")
	     (:compiled "j" :after-compiling "f" :after-compiling "b"
			:after-compiling "c")
	     (:compiled "i" :after-compiling "f" :after-compiling "b"
			:after-compiling "c")
	     (:compiled "j" :after-compiling "f" :after-compiling "b"
			:after-compiling "c")
	     (:compiled "k")
	     (:compiled "l" :after-compiling "d" :after-compiling "e")))

(asdf:defsystem system-3
  :components ((:test-file "a")
	       (:test-file "b" :depends-on ("a"))))

(define-test test-3 system-3
  :operation-name asdf:compile-op
  :already-compiled ("b")
  :expected ((:compiled "a")
	     (:loaded "a" :after-compiling "a")
	     (:compiled "b" :after-compiling "a" :after-loading "a")
	     (:did-not-load "b")))

(define-test test-3a system-3
  :operation-name asdf:compile-op
  :already-compiled ("a" "b")
  :expected ((:did-not-compile "a")
	     (:did-not-load "a")
	     (:did-not-compile "b")
	     (:did-not-load "b")))

(asdf:defsystem system-4
  :components ((:test-file "a")
	       (:test-file "b" :depends-on ("a"))))

(define-test test-4 system-4
  :operation-name asdf:compile-op
  :already-compiled ("a" "b")
  :expected ((:did-not-compile "a")
	     (:did-not-load "a")
	     (:did-not-compile "b")
	     (:did-not-load "b")))

(asdf:defsystem system-5
  :components ((:test-file "a")
	       (:test-file "b" :depends-on ("a")
			       :in-order-to ((asdf:compile-op 
					      (asdf:load-op "a"))))))

(define-test test-5 system-5
  :operation-name asdf:compile-op
  :already-compiled ("a" "b")
  :expected ((:did-not-compile "a")
	     (:loaded "a")
	     (:did-not-compile "b")
	     (:did-not-load "b")))




-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys -- and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV