clucumber 0.1.1 → 0.2.0

data/lib/clucumber/vendor/lift/dev/utilities.lisp

@@ -0,0 +1,242 @@
+(in-package #:lift)
+
+;; stolen from metatilities
+(defun form-symbol-in-package (package &rest names)
+    "Finds or interns a symbol in package whose name is formed by concatenating the pretty printed representation of the names together."
+    (with-standard-io-syntax 
+      (let ((*package* package))
+	(intern (format nil "~{~a~}" names)
+		package))))
+     
+(defun form-symbol (&rest names)
+    "Finds or interns a symbol in the current package whose name is formed by concatenating the pretty printed representation of the names together."
+    (apply #'form-symbol-in-package *package* names))
+
+(defun form-keyword (&rest names)
+    "Finds or interns a symbol in the current package whose name is formed by concatenating the pretty printed representation of the names together."
+    (apply #'form-symbol-in-package 
+	   (load-time-value (find-package :keyword)) names))
+
+;; borrowed from asdf
+(defun pathname-sans-name+type (pathname)
+  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME and TYPE components"
+  (make-pathname :name nil :type nil :defaults pathname))
+
+(defun pathname-has-device-p (pathname)
+  (and (or (stringp pathname) (pathnamep pathname))
+       (not (member (pathname-device pathname) '(nil :unspecific)))))
+
+(defun pathname-has-host-p (pathname)
+  (and (or (stringp pathname) (pathnamep pathname))
+       (not (member (pathname-host pathname) '(nil :unspecific)))))
+
+(defun relative-pathname (relative-to pathname &key name type)
+  (let ((directory (pathname-directory pathname)))
+    (when (eq (car directory) :absolute)
+      (setf directory (copy-list directory)
+	    (car directory) :relative))
+    (merge-pathnames
+     (make-pathname :name (or name (pathname-name pathname))
+                    :type (or type (pathname-type pathname))
+                    :directory directory
+		    )
+     relative-to)))
+
+(defun directory-pathname-p (p)
+  (flet ((component-present-p (value)
+           (and value (not (eql value :unspecific)))))
+    (and 
+     (not (component-present-p (pathname-name p)))
+     (not (component-present-p (pathname-type p)))
+     p)))
+
+(defun directory-p (name)
+  (let ((truename (probe-file name)))
+    (and truename (directory-pathname-p name))))
+
+(defun containing-pathname (pathspec)
+  "Return the containing pathname of the thing to which 
+pathspac points. For example:
+
+    > \(containing-directory \"/foo/bar/bis.temp\"\)
+    \"/foo/bar/\"
+    > \(containing-directory \"/foo/bar/\"\)
+    \"/foo/\"
+"
+  (make-pathname
+   :directory `(,@(butlast (pathname-directory pathspec)
+			   (if (directory-pathname-p pathspec) 1 0)))
+   :name nil
+   :type nil
+   :defaults pathspec))
+
+;; FIXME -- abstract and merge with unique-directory
+(defun unique-filename (pathname &optional (max-count 10000))
+  (let ((date-part (date-stamp)))
+    (loop repeat max-count
+       for index from 1
+	 for name = 
+	 (merge-pathnames 
+	  (make-pathname
+	   :name (format nil "~a-~a-~d" 
+			 (pathname-name pathname)
+			 date-part index))
+	  pathname) do
+	 (unless (probe-file name)
+	   (return-from unique-filename name)))
+    (error "Unable to find unique pathname for ~a; there are already ~:d similar files" pathname max-count)))
+	    
+;; FIXME -- abstract and merge with unique-filename
+(defun unique-directory (pathname)
+  (setf pathname (merge-pathnames pathname))
+  (let* ((date-part (date-stamp))
+	 (last-directory (first (last (pathname-directory pathname))))
+	 (base-pathname (containing-pathname pathname))
+	 (base-name (pathname-name last-directory))
+	 (base-type (pathname-type last-directory)))
+    (or (loop repeat 10000
+	   for index from 1
+	   for name = 
+	   (merge-pathnames 
+	    (make-pathname
+	     :name nil
+	     :type nil
+	     :directory `(:relative 
+			  ,(format nil "~@[~a-~]~a-~d~@[.~a~]" 
+				   base-name date-part index base-type)))
+	    base-pathname) do
+	   (unless (probe-file name)
+	     (return name)))
+	(error "Unable to find unique pathname for ~a" pathname))))
+
+(defun date-stamp (&key (datetime (get-universal-time)) (include-time? nil))
+  (multiple-value-bind
+	(second minute hour day month year day-of-the-week)
+      (decode-universal-time datetime)
+    (declare (ignore day-of-the-week))
+    (let ((date-part (format nil "~d-~2,'0d-~2,'0d" year month day))
+	  (time-part (and include-time? 
+			  (list (format nil "-~2,'0d-~2,'0d-~2,'0d"
+					hour minute second)))))
+      (apply 'concatenate 'string date-part time-part))))
+
+
+#+(or)
+(date-stamp :include-time? t)	
+
+;;; ---------------------------------------------------------------------------
+;;; shared stuff
+;;; ---------------------------------------------------------------------------	
+
+(defgeneric get-class (thing &key error?)
+  (:documentation "Returns the class of thing or nil if the class cannot be found. Thing can be a class, an object representing a class or a symbol naming a class. Get-class is like find-class only not as particular.")
+  (:method ((thing symbol) &key error?)
+           (find-class thing error?))
+  (:method ((thing standard-object) &key error?)
+           (declare (ignore error?))
+           (class-of thing))
+  (:method ((thing t) &key error?) 
+           (declare (ignore error?))
+           (class-of thing))
+  (:method ((thing class) &key error?)
+           (declare (ignore error?))
+           thing))
+
+(defun direct-subclasses (thing)
+  "Returns the immediate subclasses of thing. Thing can be a class, object or symbol naming a class."
+  (class-direct-subclasses (get-class thing)))
+
+(defun map-subclasses (class fn &key proper?)
+  "Applies fn to each subclass of class. If proper? is true, then
+the class itself is not included in the mapping. Proper? defaults to nil."
+  (let ((mapped (make-hash-table :test #'eq)))
+    (labels ((mapped-p (class)
+               (gethash class mapped))
+             (do-it (class root)
+               (unless (mapped-p class)
+                 (setf (gethash class mapped) t)
+                 (unless (and proper? root)
+                   (funcall fn class))
+                 (mapc (lambda (class)
+                         (do-it class nil))
+                       (direct-subclasses class)))))
+      (do-it (get-class class) t))))
+
+(defun subclasses (class &key (proper? t))
+  "Returns all of the subclasses of the class including the class itself."
+  (let ((result nil))
+    (map-subclasses class (lambda (class)
+                            (push class result))
+                    :proper? proper?)
+    (nreverse result)))
+
+(defun superclasses (thing &key (proper? t))
+  "Returns a list of superclasses of thing. Thing can be a class, object or symbol naming a class. The list of classes returned is 'proper'; it does not include the class itself."
+  (let ((result (class-precedence-list (get-class thing))))
+    (if proper? (rest result) result)))
+
+#+(or)
+;;?? remove
+(defun direct-superclasses (thing)
+  "Returns the immediate superclasses of thing. Thing can be a class, object or symbol naming a class."
+  (class-direct-superclasses (get-class thing)))
+
+(declaim (inline length-1-list-p)) 
+(defun length-1-list-p (x) 
+  "Is x a list of length 1?"
+  (and (consp x) (null (cdr x))))
+
+(defmacro defclass-property (property &optional (default nil default-supplied?))
+  "Create getter and setter methods for 'property' on symbol's property lists." 
+  (let ((real-name (intern (format nil "~:@(~A~)" property) :keyword)))
+    `(progn
+       (defgeneric ,property (symbol))
+       (defgeneric (setf ,property) (value symbol))
+       (defmethod ,property ((class-name symbol))
+          (get class-name ,real-name ,@(when default-supplied? (list default))))
+       (defmethod (setf ,property) (value (class-name symbol))
+         (setf (get class-name ,real-name) value)))))
+
+(defun parse-brief-slot (slot)
+  (let* ((slot-spec 
+	  (typecase slot
+	    (symbol (list slot))
+	    (list slot)
+	    (t (error "Slot-spec must be a symbol or a list. `~s` is not." 
+		      slot)))))
+    (unless (null (cddr slot-spec))
+      (error "Slot-spec must be a symbol or a list of length one or two. `~s` has too many elements." slot)) 
+    `(,(first slot-spec) ,@(when (second slot-spec) 
+				 `(:initform ,(second slot-spec))))))
+
+(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))
+    (do* ((clauses clauses-and-options (rest clauses))
+          (clause (first clauses) (first clauses)))
+         ((null clauses))
+      (if (and (keywordp clause)
+               (or (null clauses-to-convert) (member clause clauses-to-convert))
+               (not (length-1-list-p clauses)))
+        (progn
+          (setf clauses (rest clauses))
+          (push (list clause (first clauses)) parsed-clauses))
+        (push clause parsed-clauses)))
+    (nreverse parsed-clauses)))
+
+(defun remove-leading-quote (list)
+  "Removes the first quote from a list if one is there."
+  (if (and (consp list) (eql (first list) 'quote))
+    (first (rest list))
+    list))
+
+(defun cleanup-parsed-parameter (parameter)
+  (if (length-1-list-p parameter)
+    (first parameter)
+    parameter))
+
+(defun ensure-string (it)
+  (etypecase it
+    (string it)
+    (symbol (symbol-name it))))

data/lib/clucumber/vendor/lift/docs/package.lisp

@@ -0,0 +1,6 @@
+(in-package #:common-lisp-user)
+
+(defpackage #:metabang.lift.documentation
+  (:use #:common-lisp #:lift #:cl-markdown-user
+	#:metabang.docudown)
+  (:nicknames #:lift-documentation))

data/lib/clucumber/vendor/lift/docs/setup.lisp

@@ -0,0 +1,17 @@
+(in-package #:lift-documentation)
+
+#+(or)
+(defmethod additional-markdown-extensions-for-system 
+    append ((system (eql (asdf:find-system 'lift-documentation))))
+  '(clcl))
+
+(defmethod search-locations-for-system 
+    append ((system (eql (asdf:find-system 'lift-documentation))))
+  (list (asdf:system-relative-pathname 
+	 'lift-documentation "website/source/resources/")
+	(asdf:system-relative-pathname 
+	 'lift-documentation "website/source/")
+	(asdf:system-relative-pathname 
+	 'lift-documentation "../shared//")
+	))
+

data/lib/clucumber/vendor/lift/examples/basic-examples.lisp

@@ -0,0 +1,289 @@
+;;;-*- Mode: Lisp; Package: LIFT -*-
+
+#| simple-header
+
+Copyright (c) 2001-2006 Gary Warren King (gwking@cs.umass.edu) 
+
+Permission is hereby granted, free of charge, to any person obtaining a 
+copy of this software and associated documentation files (the "Software"),
+to deal in the Software without restriction, including without limitation
+the rights to use, copy, modify, merge, publish, distribute, sublicense, 
+and/or sell copies of the Software, and to permit persons to whom the 
+Software is furnished to do so, subject to the following conditions: 
+
+The above copyright notice and this permission notice shall be included in 
+all copies or substantial portions of the Software. 
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL 
+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 
+DEALINGS IN THE SOFTWARE. 
+
+|#
+
+(in-package #:lift)
+
+;;; ---------------------------------------------------------------------------
+;;; a simple example
+;;; ---------------------------------------------------------------------------
+
+;;; define an empty testsuite
+(deftestsuite lift-examples-1 () ())
+;; => #<LIFT-EXAMPLES-1: no tests defined>
+
+;;; and add a test to it
+(addtest (lift-examples-1)
+  (ensure-same (+ 1 1) 2))
+;; => #<Test passed>
+
+;;; add another test using ensure-error
+(addtest (lift-examples-1)
+  (ensure-error (let ((x 0)) (/ x))))
+;; => #<Test passed>
+
+;;; add another, slightly more specific test
+(addtest (lift-examples-1)
+  (ensure-condition division-by-zero (let ((x 0)) (/ x))))
+;; => #<Test passed>
+
+;;; run all the defined tests
+(run-tests)
+;; => #<Results for LIFT-EXAMPLES-1 [3 Successful tests]>
+
+
+;;; ---------------------------------------------------------------------------
+;;; a simple example using deftestsuites :tests clause
+;;; ---------------------------------------------------------------------------
+
+(deftestsuite lift-examples-2 () 
+  ()
+  (:tests
+   ((ensure-same (+ 1 1) 2))
+   ((ensure-error (let ((x 0)) (/ x))))
+   ((ensure-condition division-by-zero (let ((x 0)) (/ x))))))
+
+
+;;; ---------------------------------------------------------------------------
+;;; testing a simple function
+;;; ---------------------------------------------------------------------------
+
+;; !!! Incorrect definition
+(defun dotted-pair-p (putative-pair)
+  (and (consp putative-pair)
+       (cdr putative-pair)))
+
+;;; ---------------------------------------------------------------------------
+
+(deftestsuite test-dotted-pair-p ()
+  ()
+  (:tests
+   ((ensure (dotted-pair-p '(a . b))))
+   ((ensure (not (dotted-pair-p '(a b)))))
+   ((ensure (not (dotted-pair-p :a))))
+   ((ensure (not (dotted-pair-p '(a b . c)))))
+   ((ensure (not (dotted-pair-p nil))))))
+;; ==> #<Results for TEST-DOTTED-PAIR-P [5 Tests, 2 Failures]>
+
+(describe (run-tests))
+;; ==> (prints)
+Test Report for TEST-DOTTED-PAIR-P: 5 tests run, 2 Failures.
+
+Failure: TEST-2
+  Condition: Ensure failed: (NOT (DOTTED-PAIR-P '(A B)))
+             
+  Code     : ((ENSURE (NOT (DOTTED-PAIR-P '(A B)))))
+  
+Failure: TEST-4
+  Condition: Ensure failed: (NOT (DOTTED-PAIR-P '(A B . C)))
+             
+  Code     : ((ENSURE (NOT (DOTTED-PAIR-P '(A B . C)))))
+
+;;; ---------------------------------------------------------------------------
+
+;; !!! Correct the defintion and run tests again
+(defun dotted-pair-p (putative-pair)
+  (and (consp putative-pair)
+       (cdr putative-pair)
+       (not (consp (cdr putative-pair)))))
+
+;;; ---------------------------------------------------------------------------
+
+(describe (run-tests))
+;; ==> Prints
+Test Report for TEST-DOTTED-PAIR-P: 5 tests run, all passed!
+
+
+;;; ---------------------------------------------------------------------------
+;;; a test suite using slots
+;;; ---------------------------------------------------------------------------
+
+(defun nearly-zero-p (number &optional (tolerance 0.0001))
+  (< (abs number) tolerance))
+
+(progn
+  (deftestsuite test-nearly-zero-p ()
+    ((the-number-zero 0.0)
+     (not-nearly-zero 10000.0)
+     (close-to-zero 0.000000001)
+     (close-but-no-cigar 0.01)))
+  
+  (addtest (test-nearly-zero-p)
+    (ensure (nearly-zero-p the-number-zero)))
+  
+  (addtest (test-nearly-zero-p)
+    (ensure (not (nearly-zero-p not-nearly-zero))))
+  
+  (addtest (test-nearly-zero-p)
+    (ensure (nearly-zero-p close-to-zero)))
+  
+  (addtest (test-nearly-zero-p)
+    (ensure (not (nearly-zero-p close-but-no-cigar))))
+  
+  (addtest (test-nearly-zero-p)
+    (ensure (nearly-zero-p close-but-no-cigar 0.1))))
+
+
+(deftestsuite lift-examples () ())
+
+(addtest (lift-examples)
+  (:documentation "This is the best test of all")
+  (let ((foo 1)
+        (faa 2)
+        (bar 3))
+    (setf foo (+ foo faa bar))
+    (setf foo 2)
+    (ensure (= (+ foo faa bar) (* foo faa bar)))))
+
+(addtest (lift-examples)
+  (:documentation "This is the best test of all")
+  (let ((foo 1)
+        (faa 2)
+        (bar 3))
+    (setf foo (+ foo faa bar))
+    (setf foo 2)
+    (ensure (= (+ foo faa bar) (* foo far bar)))))
+
+(addtest (lift-examples)
+  (ensure (= 2 3)))
+
+(addtest (lift-examples)
+  (ensure (= 2 2)))
+
+(addtest (lift-examples)
+  test-warning-2
+  (ensure-warning (+ 2 3)))
+
+(addtest (lift-examples)
+  test-warning
+  (ensure-warning (warn "Help!")))
+
+(addtest (lift-examples)
+  (:documentation "Testing ensure-same, should pass.")
+  (ensure-same (values "1" "2" "3") (values "1" "2" "3") :test #'string-equal))
+
+(addtest (lift-examples)
+  (:documentation "Testing ensure-equal, should fail")
+  (ensure-same (values "1" "2" "3") (values "1" "2" "3") :test #'eql))
+
+(addtest (lift-examples)
+  (ensure-error (warn "This test fails because a warning 
+is not an error.")))
+
+(addTest (lift-examples)
+  (:documentation "This test will be logged as a 
+failure because no error will be generated.")
+  (ensure-warning (= 2 2)))
+
+(addTest (lift-examples)
+  (:documentation "This test succeeds!")
+  (ensure-error (let ((x 0)) (print (/ 4 x)))))
+
+(addTest (lift-examples)
+  (:documentation "This test should fail.  Tests a bug where a warning would abort the test with no message.")
+  (warn "A test warning")
+  (ensure-same 1 2))
+
+(run-tests :suite 'lift-examples)
+
+;;; ---------------------------------------------------------------------------
+;;; 
+;;; ---------------------------------------------------------------------------
+
+(deftestsuite more-lift-examples (lift-examples)
+  ((var-1 1))
+  (:documentation "More Examples")
+  (:test (test-initial-slot-value (ensure (= var-1 1))))
+  (:test ((ensure (= (1+ var-1) 2))))
+  (:test ((setf var-1 0) (ensure (= (1+ var-1) 1))))
+  (:test ((setf var-1 0) (ensure-warning (/ var-1))))
+  (:test ((setf var-1 0) (/ var-1) :documentation "Wow")))
+
+(deftestsuite more-lift-examples (lift-examples)
+  ((var-1 1)
+   (var-2 2)))
+
+(addtest (more-lift-examples)
+  test-initial-slot-value
+  (ensure (= var-1 1)))
+(remove-test)
+(addtest (more-lift-examples)
+  (ensure (= (1+ var-1) 2)))
+(addtest (more-lift-examples)
+  (setf var-1 0)
+  (ensure (= (1+ var-1) 1)))
+(addtest (more-lift-examples)
+  (setf var-1 0)
+  (ensure-warning (/ var-1)))
+
+
+(addtest (more-lift-examples)
+  test-initial-slot-value
+  (ensure-same var-1 1))
+
+(addtest (more-lift-examples)
+  test-initial-slot-value
+  (ensure-same "Hello" (concatenate 'string "he" "ll" "o")))
+
+(addtest (more-lift-examples)
+  test-initial-slot-value
+  (ensure-same 1.23 1.23))
+
+(addtest (more-lift-examples)
+  test-initial-slot-value
+  (ensure-same (floor 5/3) (values 1 2/3) :test #'=))
+
+
+(addtest (more-lift-examples)
+  test-initial-slot-value
+  (ensure-same var-1 2))
+
+(addtest (more-lift-examples)
+  test-initial-slot-value
+  (ensure-same var-1 1 :report "Var-1 is ~A, not 1." :args (list var-1)))
+
+(addtest (more-lift-examples)
+  test-initial-slot-value
+  (ensure-same var-1 1 :report (lambda ()
+                                 (format nil "Var-1 is ~A, not 1." var-1))))
+
+(addtest (more-lift-examples)
+  test-initial-slot-value
+  (ensure-same var-1 1 :report ("Var-1 is ~A, not 1." var-1)))
+
+
+;;; ---------------------------------------------------------------------------
+;;; compare with fiveam
+;;; ---------------------------------------------------------------------------
+
+(deftestsuite my-suite ()
+  ()
+  (:documentation "My example suite")
+  (:tests
+   ((ensure-same 4 (+ 2 2)))
+   ((ensure-same 0 (+ -1 1)))
+   ((ensure-error (+ 'foo 4)))
+   ((ensure-same 0 (+ 1 1) :report "This should fail."))))
+

data/lib/clucumber/vendor/lift/examples/random-testing.lisp

@@ -0,0 +1,32 @@
+(in-package #:lift)
+
+(deftestsuite integer-math () ())
+
+(defrandom-instance an-integer nil (- (random 200) 100))
+
+(addtest (integer-math)
+  commutivity
+  (with-random-cases 10 ((a an-integer) (b an-integer))
+    (format t "~&~a ~a" a b)
+    (ensure-same (+ a b) (+ b a) :test =)))
+
+(deftestsuite small-positive-integer-math (integer-math)
+  ())
+
+(addtest (small-positive-integer-math)
+  commutivity
+  (with-random-cases 10 ((a an-integer) (b an-integer))
+    (ensure-same (+ a b) (+ b a) :test =)))
+
+(addtest (small-positive-integer-math)
+  closedness
+  (with-random-cases 10 ((a an-integer) (b an-integer))
+    (ensure (< (+ a b) 15))))
+
+(defrandom-instance an-integer small-positive-integer-math
+  (1+ (random 10)))
+
+(deftestsuite small-positive-integer-math (integer-math)
+  ()
+  (:random-instance an-integer (1+ (random 10))))
+

data/lib/clucumber/vendor/lift/lift-documentation.asd

@@ -0,0 +1,28 @@
+ (in-package #:common-lisp-user)
+
+(defpackage #:lift-documentation-system
+  (:use #:common-lisp #:asdf))
+(in-package #:lift-documentation-system)
+
+;; just ignore for now... sigh.
+(defsystem lift-documentation
+  :author "Gary King <gwking@metabang.com>"
+  :maintainer "Gary Warren King <gwking@metabang.com>"
+  :licence "MIT Style License"
+  :description "Documentation for LIFT"
+  :components (
+	       #+(or)
+		 (:module "setup"
+			:pathname "docs/" 
+			:components ((:file "package")
+				     (:file "setup" 
+				      :depends-on ("package"))))
+	       #+(or)
+	       (:module 
+		"docs"
+		:depends-on ("setup")
+		:pathname "website/source/"
+		:components
+		((:docudown-source "index.md")
+		 (:docudown-source "user-guide.md"))))
+  :depends-on (:lift #+(or) :docudown))

data/lib/clucumber/vendor/lift/lift-test.asd

@@ -0,0 +1,35 @@
+(defpackage #:asdf-lift-test (:use #:asdf #:cl))
+(in-package #:asdf-lift-test)
+
+(defsystem lift-test
+  :author "Gary Warren King <gwking@metabang.com>"
+  :maintainer "Gary Warren King <gwking@metabang.com>"
+  :licence "MIT Style License; see file COPYING for details"
+  :description "Tests for LIsp Framework for Testing"
+  :components ((:module 
+		"setup"
+		:pathname "test/"
+		:components ((:file "packages")
+			     (:file "lift-test"
+				    :depends-on ("packages"))))
+	       (:module 
+		"test"
+		:pathname "test/"
+		:depends-on ("setup")
+		:components ((:file "test-dynamic-variables")
+			     (:file "equality-tests")
+			     (:file "testsuite-expects")
+			     (:file "finding-tests")
+			     (:file "order-of-operations")
+			     (:file "test-config-files")
+			     (:file "test-maximum-problems")
+			     #+(or)
+			     (:file "test-prototypes"))))  
+  :depends-on (:lift))
+
+(defmethod operation-done-p 
+           ((o test-op)
+            (c (eql (find-system 'lift-test))))
+  (values nil))
+
+