From f6abed732e2359e6fc87688836a396f7db35e60b Mon Sep 17 00:00:00 2001 From: AJ Rossini Date: Thu, 29 Nov 2007 17:11:30 +0100 Subject: [PATCH] update lift to 29.11.2007 version --- external/lift.darcs/README.git | 12 --- external/lift.darcs/dev/copy-file.lisp | 42 +++++--- external/lift.darcs/dev/lift.lisp | 118 ++++++++++++++++------- external/lift.darcs/dev/reports.lisp | 58 ++++++----- external/lift.darcs/examples/basic-examples.lisp | 3 - external/lift.darcs/lift-standard.config | 1 - external/lift.darcs/lift.asd | 2 +- external/lift.darcs/test/tests-in-progress.lisp | 19 ++++ 8 files changed, 166 insertions(+), 89 deletions(-) delete mode 100644 external/lift.darcs/README.git diff --git a/external/lift.darcs/README.git b/external/lift.darcs/README.git deleted file mode 100644 index 4fc014a..0000000 --- a/external/lift.darcs/README.git +++ /dev/null @@ -1,12 +0,0 @@ - -Need to record how we got this, using - - darcs pull http://common-lisp.net/project/lift/darcs/lift/ - -and then ignoring the darcs repo, as well as resources and website. - -Currently at version 1.3.5 - -Better, is that we make this into its own git submodule, and retrack -as needed from there. But need to have a one-way sync from darcs that -can be updated, which is not the current case, AFAIK. \ No newline at end of file diff --git a/external/lift.darcs/dev/copy-file.lisp b/external/lift.darcs/dev/copy-file.lisp index 3b64111..283341c 100644 --- a/external/lift.darcs/dev/copy-file.lisp +++ b/external/lift.darcs/dev/copy-file.lisp @@ -2,6 +2,7 @@ ;;; directly pullled from metatilities, sigh (in-package #:lift) +;(in-package #:metatilities) (define-condition source/target-file-error (file-error) ((pathname :reader source-pathname @@ -13,8 +14,6 @@ (source-pathname c) (target-pathname c)))) (:documentation "General condition for file errors that have a source and target.")) -;;; --------------------------------------------------------------------------- - (define-condition source/target-target-already-exists-error (source/target-file-error) () (:report (lambda (c s) @@ -22,8 +21,6 @@ (target-pathname c)))) (:documentation "This error is signaled when the target pathname already exists.")) -;;; --------------------------------------------------------------------------- - (define-condition source/target-source-does-not-exist-error (source/target-file-error) () @@ -32,8 +29,6 @@ (source-pathname c)))) (:documentation "This error is signaled when the source file does not exist.")) -;;; --------------------------------------------------------------------------- - (defun copy-file (from to &key (if-does-not-exist :error) (if-exists :error)) "Copies the file designated by the non-wild pathname designator FROM @@ -88,10 +83,35 @@ designator does not exist. (if-exists :error)) (declare (dynamic-extent args) (ignore if-exists if-does-not-exist)) - #+allegro - (excl.osi:rename (namestring from) (namestring to)) - #-allegro - (when (apply #'copy-file (namestring from) (namestring to) args) + (when (apply #'copy-file from to args) (delete-file from))) - +;;; borrowed from asdf-install -- how did this ever work ?! +;; for non-SBCL we just steal this from SB-EXECUTABLE +#-(or :digitool) +(defvar *stream-buffer-size* 8192) +#-(or :digitool) +(defun copy-stream (from to) + "Copy into TO from FROM until end of the input stream, in blocks of +*stream-buffer-size*. The streams should have the same element type." + (unless (subtypep (stream-element-type to) (stream-element-type from)) + (error "Incompatible streams ~A and ~A." from to)) + (let ((buf (make-array *stream-buffer-size* + :element-type (stream-element-type from)))) + (loop + (let ((pos #-(or :clisp :cmu) (read-sequence buf from) + #+:clisp (ext:read-byte-sequence buf from :no-hang nil) + #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil))) + (when (zerop pos) (return)) + (write-sequence buf to :end pos))))) + +#+:digitool +(defun copy-stream (from to) + "Perform copy and map EOL mode." + (multiple-value-bind (reader reader-arg) (ccl::stream-reader from) + (multiple-value-bind (writer writer-arg) (ccl::stream-writer to) + (let ((datum nil)) + (loop (unless (setf datum (funcall reader reader-arg)) + (return)) + (funcall writer writer-arg datum)))))) + diff --git a/external/lift.darcs/dev/lift.lisp b/external/lift.darcs/dev/lift.lisp index 45177f7..988ebc7 100644 --- a/external/lift.darcs/dev/lift.lisp +++ b/external/lift.darcs/dev/lift.lisp @@ -60,6 +60,7 @@ suite find-testsuite + find-test-case ensure-random-cases-failure random-instance-for-suite defrandom-instance @@ -153,8 +154,6 @@ the class itself is not included in the mapping. Proper? defaults to nil." :accessor :documentation :type :allocation)) -;;; --------------------------------------------------------------------------- - (defun parse-brief-slot (slot &optional (automatic-accessors? *automatic-slot-accessors?*) @@ -269,8 +268,6 @@ All other CLOS slot options are processed normally." ;; finish-new-slot cleans up duplicates (finish-new-slot (nreverse new-slot))))) -;;; --------------------------------------------------------------------------- - (defun convert-clauses-into-lists (clauses-and-options clauses-to-convert) ;; This is useful (for me at least!) for writing macros (let ((parsed-clauses nil)) @@ -315,12 +312,14 @@ All other CLOS slot options are processed normally." (defvar *testsuite-test-count* nil "Temporary variable used to 'communicate' between deftestsuite and addtest.") (defvar *lift-debug-output* *debug-io* - "Messages from LIFT will be sent to this stream. It can set to nil or to an output stream. It defaults to *debug-io*.") + "Messages from LIFT will be sent to this stream. It can set to nil or +to an output stream. It defaults to *debug-io*.") (defvar *test-break-on-errors?* nil) (defvar *test-do-children?* t) (defparameter *test-ignore-warnings?* nil - "If true, LIFT will not cause a test to fail if a warning occurs while the test is running. Note that this may interact oddly with ensure-warning.") + "If true, LIFT will not cause a test to fail if a warning occurs while +the test is running. Note that this may interact oddly with ensure-warning.") (defparameter *test-print-when-defined?* nil) (defparameter *test-evaluate-when-defined?* t) (defparameter *test-scratchpad* nil @@ -360,13 +359,16 @@ All other CLOS slot options are processed normally." "The current testsuite.") (defvar *lift-dribble-pathname* nil - "If bound, then test output from run-tests will be sent to this file in addition to *lift-standard-output*. It can be set to nil or to a pathname.") + "If bound, then test output from run-tests will be sent to this file in +in addition to *lift-standard-output*. It can be set to nil or to a pathname.") (defvar *lift-standard-output* *standard-output* - "Output from tests will be sent to this stream. If can set to nil or to an output stream. It defaults to *standard-output*.") + "Output from tests will be sent to this stream. If can set to nil or +to an output stream. It defaults to *standard-output*.") (defvar *lift-if-dribble-exists* :append - "Specifies what to do to any existing file at *lift-dribble-pathname*. It can be :supersede, :append, or :error.") + "Specifies what to do to any existing file at *lift-dribble-pathname*. It +can be :supersede, :append, or :error.") ;;; --------------------------------------------------------------------------- ;;; Error messages and warnings @@ -388,7 +390,9 @@ All other CLOS slot options are processed normally." "Could not find test: ~S.~S") (defparameter +run-tests-null-test-case+ - "There is no current testsuite (possibly because none have been defined yet?). You can specify the testsuite to test by evaluating (run-tests :suite ).") + "There is no current testsuite (possibly because + none have been defined yet?). You can specify the + testsuite to test by evaluating (run-tests :suite ).") (defparameter +lift-unable-to-parse-test-name-and-class+ "") @@ -420,8 +424,7 @@ All other CLOS slot options are processed normally." (defun signal-lift-error (context message &rest arguments) (let ((c (make-condition 'lift-compile-error - :lift-message (apply #'build-lift-error-message - context message arguments)))) + :lift-message (apply #'build-lift-error-message context message arguments)))) (unless (signal c) (error c)))) @@ -792,10 +795,10 @@ the methods that should be run to do the tests for this test.")) (defgeneric initialize-test (test) (:documentation "")) -(defgeneric run-test-internal (case name result) +(defgeneric run-test-internal (suite name result) (:documentation "")) -(defgeneric run-tests-internal (case &key result) +(defgeneric run-tests-internal (suite &key result) (:documentation "")) (defgeneric start-test (result case method-name) @@ -859,7 +862,8 @@ the thing being defined.") (let ((current (assoc name *current-definition*))) (if current (setf (cdr current) value) - (push (cons name value) *current-definition*))) + (push (cons name value) *current-definition*))) + (values value)) (defun def (name &optional (definition *current-definition*)) @@ -1297,11 +1301,12 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor (*current-test* (make-testsuite suite args))) (unless result (setf result (make-test-result suite :single))) - (setf *current-case-method-name* name + (setf *current-case-method-name* (find-test-case suite name) *current-suite-class-name* suite) (do-testing *current-test* result (lambda () - (run-test-internal *current-test* name result))))) + (run-test-internal + *current-test* *current-case-method-name* result))))) (defun make-testsuite (suite args) (let ((make-instance-args nil)) @@ -1413,13 +1418,15 @@ control over where in the test hierarchy the search begins." (result (make-test-result (or suite config) :multiple)) ;run-setup &allow-other-keys) - "Run all of the tests in a suite. Arguments are :suite, :result, :do-children? and :break-on-errors?" + "Run all of the tests in a suite. Arguments are :suite, :result, ~ +:do-children? and :break-on-errors?" (remf args :suite) (remf args :break-on-errors?) (remf args :run-setup) (remf args :dribble) (cond ((and suite config) - (error "Specify either configuration file or test suite but not both.")) + (error "Specify either configuration file or test suite +but not both.")) (config (run-tests-from-file config)) ((or suite (setf suite *current-suite-class-name*)) @@ -1447,7 +1454,8 @@ control over where in the test hierarchy the search begins." (setf (tests-run result) (reverse (tests-run result))) (values result))) (t - (error "There is not a current test suite and neither suite nor configuration file options were specified.")))) + (error "There is not a current test suite and neither suite +nor configuration file options were specified.")))) (defun maybe-add-dribble (stream dribble-stream) (if dribble-stream @@ -1492,7 +1500,7 @@ control over where in the test hierarchy the search begins." (dolist (key.value (current-values testsuite)) (setf (test-environment-value (car key.value)) (cdr key.value)))) -(defmethod run-test-internal ((case test-mixin) (name symbol) result) +(defmethod run-test-internal ((suite test-mixin) (name symbol) result) (when (and *test-print-test-case-names* (eq (test-mode result) :multiple)) (print-lift-message "~& run: ~a" name)) @@ -1508,7 +1516,7 @@ control over where in the test hierarchy the search begins." (lambda (cond) (setf problem (report-test-problem - 'test-error result case name cond + 'test-error result suite name cond :backtrace (get-backtrace cond))) (if *test-break-on-errors?* (invoke-debugger cond) @@ -1518,32 +1526,32 @@ control over where in the test hierarchy the search begins." (t (lambda (cond) (setf problem (report-test-problem - 'test-error result case name cond + 'test-error result suite name cond :backtrace (get-backtrace cond)))))) (setf problem nil - (current-method case) name) - (start-test result case name) - (setup-test case) + (current-method suite) name) + (start-test result suite name) + (setup-test suite) (unwind-protect (let ((result nil)) (declare (ignorable result)) - (setf (current-step case) :testing + (setf (current-step suite) :testing result (measure - (getf (test-data case) :seconds) - (getf (test-data case) :conses) - (lift-test case name))) - (check-for-surprises result case name)) - (teardown-test case) - (end-test result case name))) + (getf (test-data suite) :seconds) + (getf (test-data suite) :conses) + (lift-test suite name))) + (check-for-surprises result suite name)) + (teardown-test suite) + (end-test result suite name))) (ensure-failed (cond) (setf problem (report-test-problem - 'test-failure result case name cond))) + 'test-failure result suite name cond))) (retry-test () :report "Retry the test." (go :test-start))) :test-end)) - (setf (third (first (tests-run result))) (test-data case)) + (setf (third (first (tests-run result))) (test-data suite)) (setf *test-result* result)) (define-condition unexpected-success-failure (test-condition) @@ -2246,6 +2254,46 @@ control over where in the test hierarchy the search begins." (error "There are several test suites named ~s: they are ~{~s~^, ~}" suite-name possibilities))))) +(defun test-case-p (suite-class name) + (find-method #'lift-test nil `(,suite-class (eql ,name)) nil)) + +#+(or) +(test-case-p + (find-class (find-testsuite 'test-cluster-indexing-locally) nil) + 'db.agraph.tests::index-them) + +#+(or) +(find-test-case (find-class (find-testsuite 'test-cluster-indexing-locally)) + 'index-themxx) + +(defmethod find-test-case ((suite symbol) name) + (find-test-case (find-class (find-testsuite suite)) name)) + +(defmethod find-test-case ((suite test-mixin) name) + (find-test-case (class-of suite) name)) + +(defmethod find-test-case ((suite-class standard-class) (name symbol)) + (or (and (test-case-p suite-class name) name) + (find-test-case suite-class (symbol-name name)))) + +(defmethod find-test-case ((suite test-mixin) (name string)) + (find-test-case (class-of suite) name)) + +(defmethod find-test-case ((suite-class standard-class) (name string)) + (let* ((temp nil) + (possibilities (remove-duplicates + (loop for p in (list-all-packages) + when (and (setf temp (find-symbol name p)) + (test-case-p suite-class temp)) collect + temp)))) + (cond ((null possibilities) + (error 'test-class-not-defined :test-class-name name)) + ((= (length possibilities) 1) + (first possibilities)) + (t + (error "There are several test cases of ~s named ~s: they are ~{~s~^, ~}" + suite-class name possibilities))))) + (defun last-test-status () (cond ((typep *test-result* 'test-result) (cond ((and (null (errors *test-result*)) diff --git a/external/lift.darcs/dev/reports.lisp b/external/lift.darcs/dev/reports.lisp index 9bd29d0..2921f47 100644 --- a/external/lift.darcs/dev/reports.lisp +++ b/external/lift.darcs/dev/reports.lisp @@ -46,7 +46,7 @@ use property-list format :testing run-tests-internal - do-testing + do-testing with testsuite-run do-testing (suite) testsuite-setup * @@ -66,6 +66,10 @@ run-test-internal teardown-test * end-test - setf :end-time * (add test-data to tests-run of result) + +run-test + do-testing with run-test-internal + |# ;; when it doubt, add a special @@ -200,7 +204,7 @@ run-test-internal (length (errors result))))) (when (or (expected-errors result) (expected-failures result)) - (format stream "~&

~[~:;~:*Expected failure~:p: ~a~]~[~:;, ~]~[~:;~:*Expected error~:p: ~a~]

~%" + (format stream "~&

~[~:;~:*Expected failure~p: ~:*~a~]~[~:;, ~]~[~:;~:*Expected error~p: ~:*~a~]

~%" (length (expected-failures result)) ;; zero if only one or the other (so we don't need a separator...) (* (length (expected-failures result)) @@ -398,30 +402,31 @@ run-test-internal (defmethod generate-detailed-reports (result stream (format (eql :html))) (loop for (suite test-name datum) in (tests-run result) when (getf datum :problem) do - (let ((output-pathname (merge-pathnames - (details-link stream suite test-name) - stream))) - (ensure-directories-exist output-pathname) - (with-open-file (out output-pathname - :direction :output - :if-does-not-exist :create - :if-exists :supersede) - (html-header - out - (format nil "Test ~a details | ~a" - test-name (test-result-property result :title)) - (test-result-property result :style-sheet)) - (format out "~&

Test ~a details

" test-name) - (format out "~&Back" - (namestring (make-pathname :name (pathname-name stream) - :type (pathname-type stream)))) - (format out "~&
")
-	 (format out "~a"
-		 (encode-pre 
-		  (with-output-to-string (s)
-		    (print-test-problem "" (getf datum :problem) s))))
-	 (format out "~&
") - (html-footer out))))) + (let ((*print-right-margin* 64)) + (let ((output-pathname (merge-pathnames + (details-link stream suite test-name) + stream))) + (ensure-directories-exist output-pathname) + (with-open-file (out output-pathname + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (html-header + out + (format nil "Test ~a details | ~a" + test-name (test-result-property result :title)) + (test-result-property result :style-sheet)) + (format out "~&

Test ~a details

" test-name) + (format out "~&Back" + (namestring (make-pathname :name (pathname-name stream) + :type (pathname-type stream)))) + (format out "~&
")
+	   (format out "~a"
+		   (encode-pre 
+		    (with-output-to-string (s)
+		      (print-test-problem "" (getf datum :problem) s))))
+	   (format out "~&
") + (html-footer out)))))) #+(or) (defmethod summarize-test-environment (result stream format) @@ -622,3 +627,4 @@ run-test-internal (progn (setf (test-result-property *test-result* :if-exists) :supersede) (test-result-report *test-result* #p"/tmp/report.n3" :turtle)) + diff --git a/external/lift.darcs/examples/basic-examples.lisp b/external/lift.darcs/examples/basic-examples.lisp index 4c1c481..53f6c15 100644 --- a/external/lift.darcs/examples/basic-examples.lisp +++ b/external/lift.darcs/examples/basic-examples.lisp @@ -208,8 +208,6 @@ failure because no error will be generated.") (run-tests :suite 'lift-examples) -(describe (run-tests :suite 'lift-examples)) - ;;; --------------------------------------------------------------------------- ;;; ;;; --------------------------------------------------------------------------- @@ -289,4 +287,3 @@ failure because no error will be generated.") ((ensure-error (+ 'foo 4))) ((ensure-same 0 (+ 1 1) :report "This should fail.")))) - diff --git a/external/lift.darcs/lift-standard.config b/external/lift.darcs/lift-standard.config index 5dba80a..d9516fe 100644 --- a/external/lift.darcs/lift-standard.config +++ b/external/lift.darcs/lift-standard.config @@ -29,7 +29,6 @@ (:report-property :name "test-results/test-report.txt") (:build-report) - (:report-property :format :save) (:report-property :name "test-results/test-report.sav") (:build-report) diff --git a/external/lift.darcs/lift.asd b/external/lift.darcs/lift.asd index d5d3667..83388c5 100644 --- a/external/lift.darcs/lift.asd +++ b/external/lift.darcs/lift.asd @@ -2,7 +2,7 @@ (in-package #:asdf-lift) (defsystem lift - :version "1.3.5" + :version "1.3.6" :author "Gary Warren King " :maintainer "Gary Warren King " :licence "MIT Style License; see file COPYING for details" diff --git a/external/lift.darcs/test/tests-in-progress.lisp b/external/lift.darcs/test/tests-in-progress.lisp index bb5661c..cd8bed6 100644 --- a/external/lift.darcs/test/tests-in-progress.lisp +++ b/external/lift.darcs/test/tests-in-progress.lisp @@ -155,3 +155,22 @@ the methods that should be run to do the tests for this test.")) +(deftestsuite warnings-and-errors () + ()) + +(defun warnings-and-errors-function (mode) + (ecase mode + (:warn (warn "this is a warning all by itself")) + (:error (error "this is an error all by itself")) + (:warn-error (warn "first we warn") (error "then we error")) + (:error-warn (error "first we error") (warn "then we warn")))) + +(addtest (warnings-and-errors) + warning-does-not-hide-error-1 + (ensure-error (warnings-and-errors-function :warn-error))) + +(addtest (warnings-and-errors) + warning-does-not-hide-error-2 + (ensure-warning (warnings-and-errors-function :warn-error))) + + -- 2.11.4.GIT