Skip to content
Snippets Groups Projects
Commit cd468d51 authored by Gary King's avatar Gary King
Browse files

test-op depends on load-op (thanks to rpgoldman@sift.info)

* Improve error message for bad dependencies
* New default is for test-op to depend on load-op
* tweak run-program for SBCL so that ACL isn't #+no #+no bothered
* tweak write-test-web-page and write-license
* tweak some tests
parent 2c2c62a2
No related branches found
No related tags found
No related merge requests found
...@@ -900,7 +900,7 @@ the head of the tree")) ...@@ -900,7 +900,7 @@ the head of the tree"))
forced forced
(do-one-dep op (second d) (third d)))) (do-one-dep op (second d) (third d))))
(t (t
(error "Dependencies must be (:version <version>), (:feature <feature>), or a name")))) (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature>), or a name" d))))
(t (t
(appendf forced (do-one-dep op d nil))))))))) (appendf forced (do-one-dep op d nil)))))))))
(aif (component-visited-p operation c) (aif (component-visited-p operation c)
...@@ -1129,6 +1129,10 @@ the head of the tree")) ...@@ -1129,6 +1129,10 @@ the head of the tree"))
"Testing a system is _never_ done." "Testing a system is _never_ done."
nil) nil)
(defmethod component-depends-on :around ((o test-op) (c system))
(cons `(load-op ,(component-name c)) (call-next-method)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations ;;; invoking operations
...@@ -1457,11 +1461,11 @@ output to `*verbose-out*`. Returns the shell's exit code." ...@@ -1457,11 +1461,11 @@ output to `*verbose-out*`. Returns the shell's exit code."
(asdf-message "; $ ~A~%" command) (asdf-message "; $ ~A~%" command)
#+sbcl #+sbcl
(sb-ext:process-exit-code (sb-ext:process-exit-code
(sb-ext:run-program (apply #'sb-ext:run-program
#+win32 "sh" #-win32 "/bin/sh" #+win32 "sh" #-win32 "/bin/sh"
(list "-c" command) (list "-c" command)
#+win32 #+win32 :search t :input nil :output *verbose-out*
:input nil :output *verbose-out*)) #+win32 '(:search t) #-win32 nil))
#+(or cmu scl) #+(or cmu scl)
(ext:process-exit-code (ext:process-exit-code
......
(in-package #:common-lisp-user) (in-package #:common-lisp-user)
#+(or) #+(or)
(build-web-page "/repository/git/asdf/test/results/" "/tmp/x.html" :if-exists :supersede) (build-web-page "/repository/git/asdf/test/results/" "/tmp/x.html" :if-exists :supersede)
(defvar *make-helper-home* *load-truename*)
;;; metatilities-base ;;; metatilities-base
;;; because sometimes copy and paste is just too easy ;;; because sometimes copy and paste is just too easy
...@@ -259,22 +262,24 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented." ...@@ -259,22 +262,24 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented."
(defun rewrite-license () (defun rewrite-license ()
(let* ((*default-pathname-defaults* (let* ((*default-pathname-defaults*
(make-pathname :name nil :type nil :defaults *load-truename*)) (make-pathname :name nil :type nil :defaults *make-helper-home*))
(output (merge-pathnames (make-pathname :name "LICENSE")))) (output (merge-pathnames (make-pathname :name "LICENSE"
:directory '(:relative :up)))))
(when (probe-file output) (when (probe-file output)
(delete-file output)) (delete-file output))
(extract-license (extract-license
(merge-pathnames (make-pathname :name "asdf" :type "lisp")) (merge-pathnames (make-pathname :name "asdf" :type "lisp"
:directory '(:relative :up)))
output))) output)))
(defun write-test-web-pages () (defun write-test-web-pages ()
(let* ((*default-pathname-defaults* (let* ((*default-pathname-defaults*
(make-pathname :name nil :type nil :defaults *load-truename*)) (make-pathname :name nil :type nil :defaults *make-helper-home*))
(source (merge-pathnames (source (merge-pathnames
(make-pathname (make-pathname
:directory '(:relative "results")))) :directory '(:relative :up "test" "results"))))
(output (merge-pathnames (make-pathname (output (merge-pathnames (make-pathname
:directory '(:relative "website" "output") :directory '(:relative :up "website" "output")
:name "test-results" :name "test-results"
:type "html")))) :type "html"))))
(print (list source output)) (print (list source output))
......
...@@ -48,7 +48,8 @@ ...@@ -48,7 +48,8 @@
:components :components
((:file "preflight"))) ((:file "preflight")))
#|
newer traverse always fails newer traverse always fails
older traverse fails when db-agraph-preflight is evaluated, ok older traverse fails when db-agraph-preflight is evaluated, ok
when loaded or compiled when loaded or compiled
\ No newline at end of file |#
\ No newline at end of file
...@@ -8,11 +8,11 @@ ...@@ -8,11 +8,11 @@
;(trace asdf:run-shell-command asdf:oos asdf:perform asdf:operate) ;(trace asdf:run-shell-command asdf:oos asdf:perform asdf:operate)
;#+allegro ;#+allegro
;(trace excl.osi:command-output) ;(trace excl.osi:command-output)
(defvar *caught-error* nil)
(exit-on-error (exit-on-error
(when (probe-file "try-reloading-dependency.asd") (when (probe-file "try-reloading-dependency.asd")
(asdf:run-shell-command "rm -f ~A" (asdf:run-shell-command "rm -f ~A"
(namestring "try-reloading-dependency.asd"))) (namestring "try-reloading-dependency.asd")))
(defvar *caught-error* nil)
(setf asdf:*central-registry* '(*default-pathname-defaults*)) (setf asdf:*central-registry* '(*default-pathname-defaults*))
(setf asdf::*defined-systems* (asdf::make-defined-systems-table)) (setf asdf::*defined-systems* (asdf::make-defined-systems-table))
(handler-bind ((error (lambda (c) (handler-bind ((error (lambda (c)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment