clucumber 0.1.1 → 0.2.0

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

@@ -0,0 +1,229 @@
+(in-package #:lift)
+
+(defvar *measures* nil
+  "A list of defineded measures")
+
+(defparameter *benchmark-log-path*
+  (asdf:system-relative-pathname 
+   'lift "benchmark-data/benchmarks.log"))
+
+(defvar *count-calls-p* nil)
+
+(defmacro undefmeasure (name)
+  (let ((gname (gensym "name-")))
+    `(let ((,gname ,(form-keyword name)))
+       (if (find ,gname *measures* :key #'first)
+	   (setf *measures* (remove ,gname *measures* :key #'first))
+	   (error "Measure ~a not found." ,gname))
+       ,gname)))
+  
+(defmacro defmeasure (name &key (value nil) (finally nil) (type nil)
+		      (documentation nil))
+  (declare (ignore documentation))
+  (unless value
+    (error "A value must be specified to define a measure."))
+  (cond ((atom name)
+	 ;; all is well
+	 )
+	((and (eq (first name) 'quote)
+	      (eq (length name) 2))
+	 (warn "Name does not need to be quoted.")
+	 (setf name (second name)))
+	(t
+	 (error "Name should be a symbol.")))
+  (cond ((eq (first finally) 'quote)
+	 (setf finally (second finally))))
+  (let ((gname (gensym "name-")))
+    `(let ((,gname ,(form-keyword name)))
+       (setf *measures* (remove ,gname *measures* :key #'first))
+       (push (list ,gname
+		   :value ,value 
+		   :finally ',finally
+		   :type ',type)		   
+	     *measures*)
+       ,gname)))
+
+(defmacro while-measuring ((catch-errors-p &rest measures) &body body)
+  (let ((vars (loop for measure in measures collect
+		   (gensym (format nil "~a-" measure))))
+	(gcondition (gensym "condition-"))
+	(gresult (gensym "result-"))
+	(gcatch-errors-p (gensym "catch-errors-p-")))
+    (labels ((measure-1 (vars measures)
+	       (cond ((null measures) body)
+		     (t
+		      `((while-measuring-1 (,(first vars) ,(first measures))
+			 ,@(measure-1 (rest vars) (rest measures))))))))
+      `(let ((,gcondition nil)
+	     (,gresult nil)
+	     (,gcatch-errors-p ,catch-errors-p)
+	     ,@vars)
+	 (setf ,gresult
+	       (handler-case 
+		   ,@(measure-1 vars measures)
+		 (error (c)
+		   (setf ,gcondition c)
+		   (unless ,gcatch-errors-p
+		     (error c)))))
+	 (values ,gresult (list ,@vars) ,gcondition)))))
+
+#+notyet
+;; returns error as third value (and probably as first too!)
+(defmacro while-measuring ((&rest measures) (&body error-body)
+			   &body body)
+  (let ((vars (loop for measure in measures collect
+		   (gensym (format nil "~a-" measure))))
+	(gcondition (gensym "condition-"))
+	(gresult (gensym "result-")))
+    (labels ((measure-1 (vars measures)
+	       (cond ((null measures) body)
+		     (t
+		      `((while-measuring-1 (,(first vars) ,(first measures))
+			 ,@(measure-1 (rest vars) (rest measures))))))))
+      `(let ((,gcondition nil)
+	     (,gresult nil)
+	     ,@vars)
+	 (setf ,gresult
+	       (handler-case 
+		   ,@(measure-1 vars measures)
+		 (error (c) 
+		   ,@(if error-body
+			 `((progn ,error-body
+				 (error c)))
+			 `((setf ,gcondition c))))))
+	 (values ,gresult (list ,@vars) ,gcondition)))))
+
+#+(or) 
+(while-measuring (space seconds)
+    nil
+  (sleep 1)
+  (signal "hi"))
+
+#+(or)
+(measure-time-and-conses 
+  (sleep 1)
+  (signal "hi"))
+
+(defmacro while-measuring-1 ((var measure) &body body)
+  (let ((ginitial (gensym "value-"))
+	(gresult (gensym "result-"))
+	(metadata (find (form-keyword measure) *measures* :key 'first)))
+    (unless metadata
+      (error "Measure `~a` not defined." measure))
+    (destructuring-bind (&key value finally type &allow-other-keys) 
+	(rest metadata)
+      `(let ((,ginitial (,value))
+	     (,gresult nil))
+	 ,@(when type
+		 `((declare (type ,type ,ginitial))))
+	 (unwind-protect
+	      (setf ,gresult (progn ,@body))
+	   (setf ,var ,@(if finally
+			    `((funcall (lambda (it) ,finally)
+				       (- (,value) ,ginitial)))
+			    `((- ,(if type `(the ,type (,value)) `(,value))
+				 ,ginitial)))))
+	 ,gresult))))
+
+(defmacro with-profile-report 
+    ((name style &key 
+	   (log-name *benchmark-log-path* ln-supplied?)
+	   (count-calls-p *count-calls-p* ccp-supplied?)
+	   (timeout nil timeout-supplied?))
+     &body body)
+  `(with-profile-report-fn 
+       ,name ,style 
+       (lambda () (progn ,@body))
+       ',body
+       ,@(when ccp-supplied? 
+	       `(:count-calls-p ,count-calls-p))
+       ,@(when ln-supplied?
+	       `(:log-name ,log-name))
+       ,@(when (and timeout-supplied? timeout)
+	       `(:timeout ,timeout))))
+
+(defmacro while-counting-repetitions ((&optional (delay 1.0)) &body body)
+  "Execute `body` repeatedly for `delay` seconds. Returns the number
+of times `body` is executed per second. Warning: assumes that `body` will not
+be executed more than a fixnum number of times. The `delay` defaults to
+1.0."
+  (let ((gevent-count (gensym "count-"))
+	(gdelay (gensym "delay-"))
+	(gignore (gensym "ignore-"))
+	(gfn (gensym "fn-")))
+    `(let ((,gfn
+	    (compile
+	     nil
+	     (lambda () 
+	       (let ((,gevent-count 0)
+		     (,gdelay ,delay))
+		 (declare (type fixnum ,gevent-count))
+		 (handler-case
+		     (lift::with-timeout (,gdelay)
+		       (loop
+			  (progn ,@body)
+			  (setf ,gevent-count (the fixnum (1+ ,gevent-count)))))
+		   (lift::timeout-error (,gignore)
+		     (declare (ignore ,gignore))
+		     (if (plusp ,gevent-count)
+			 (float (/ ,gevent-count ,gdelay))
+			 ,gevent-count))))))))
+	   (funcall ,gfn))))
+  
+(defmacro while-counting-events ((&optional (delay 1.0)) &body body)
+  "Returns the count of the number of times `did-event` was called during 
+`delay` seconds. See also: [while-counting-repetitions][]."
+  (let ((gevent-count (gensym "count")))
+    `(let ((,gevent-count 0))
+       (flet ((did-event ()
+		(incf ,gevent-count)))
+	 (declare (type fixnum ,gevent-count)
+		  (ignorable (function did-event)))
+	 (handler-case
+	     (with-timeout (,delay) 
+	       (loop  
+		  (progn ,@body)))
+	   (timeout-error (c)
+	     (declare (ignore c))
+	     (float (/ ,gevent-count ,delay))))))))  
+
+;; stolen from metatilities
+(defmacro muffle-redefinition-warnings (&body body)
+  "Evaluate the body so that redefinition warnings will not be 
+signaled. (suppored in Allegro, Clozure CL, CLisp, and Lispworks)"
+  #+allegro
+  `(excl:without-redefinition-warnings
+     ,@body)
+  #+(or ccl mcl)
+  `(let ((ccl::*warn-if-redefine* nil)
+	 ;;?? FIXME not sure if this should be here or not...
+	 (ccl::*record-source-file* nil))
+     ,@body)
+  #+clisp
+  `(let ((custom:*suppress-check-redefinition* t))
+    ,@body)
+  #+lispworks
+  `(let ((lw:*handle-warn-on-redefinition* :quiet))
+    ,@body)
+  #+sbcl
+  ;; from http://www.sbcl.info/manual/Controlling-Verbosity.html
+  `(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note
+					       sb-ext::style-warning))
+    ,@body)
+  #-(or allegro ccl clisp mcl sbcl)
+  `(progn ,@body))
+
+
+(defmacro defconfig-variable (name var &optional docstring)
+  (declare (ignore docstring))
+  `(defmethod handle-config-preference ((name (eql ,name)) args)
+     (setf ,var (first args))))
+
+(defmacro defconfig (name &body body)
+  (let ((docstring nil))
+    (declare (ignorable docstring))
+    (when (stringp (first body))
+      (setf docstring (first body)
+	    body (rest body)))
+    `(defmethod handle-config-preference ((name (eql ,name)) args)
+       ,@body)))

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

@@ -0,0 +1,156 @@
+(in-package #:lift)
+
+(eval-when (:compile-toplevel)
+  (declaim (optimize (speed 3) (safety 1))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defmeasure :measure-seconds 
+    :value 'get-internal-real-time
+    :finally '(coerce (/ it internal-time-units-per-second) 
+			'double-float)
+    :type integer
+    :documentation 
+    "Measure how long something takes using {hs get-internal-real-time}.
+
+The accuracy can be no greater than {hs internal-time-units-per-second}.")
+
+(defmeasure :measure-space
+    :value 'total-bytes-allocated
+    :type integer
+    :documentation 
+    "Measure how many conses cells a computation generates.")
+
+)
+
+#+(or)
+(while-measuring-1 (conses measure-space)
+  (while-measuring-1 (time measure-seconds)
+    blay))
+
+#+(or)
+(let ((time 0))
+  (while-measuring-1 (time measure-seconds)
+    (sleep 1))
+  time)
+
+#+(or)
+(let ((conses 0))
+  (while-measuring-1 (conses measure-space)
+    (sleep 1))
+  conses)
+
+#+(or)
+(while-measuring (measure-seconds)
+  (sleep 1))
+
+(defmacro with-measuring ((var measure-fn) &body body)
+  (let ((ginitial (gensym "value-"))
+	(gcondition (gensym "condition-")))
+    `(let ((,ginitial (,measure-fn))
+	   (,gcondition nil))
+       (prog1
+	   (handler-case 
+	       (progn ,@body)
+	     (error (c) (setf ,gcondition c)))
+	 (setf ,var (- (,measure-fn) ,ginitial))
+	 (when ,gcondition (error ,gcondition))))))
+
+
+(defmacro measure-time ((var) &body body)
+  `(while-measuring-1 (,var measure-seconds) ,@body))
+
+#+(or)
+(let ((time 0))
+  (while-measuring-1 (time measure-seconds)
+    (sleep 1))
+  time)
+
+(defmacro measure-conses ((var) &body body)
+  `(while-measuring-1 (,var measure-space) ,@body))
+
+(defun measure-fn (fn &rest args)
+  (declare (dynamic-extent args))
+  (let ((bytes 0) (seconds 0) result)
+    (measure-time (seconds)
+      (measure-conses (bytes)
+	(setf result (apply fn args))))
+    (values seconds bytes result)))
+
+(defmacro measure (seconds bytes &body body)
+  (let ((result (gensym)))
+    `(let (,result)
+       (measure-time (,seconds)
+	 (measure-conses (,bytes)
+	   (setf ,result (progn ,@body))))
+       (values ,result))))
+
+(defmacro measure-time-and-conses (&body body)
+  (let ((seconds (gensym))
+	(conses (gensym))
+	(results (gensym)))
+    `(let ((,seconds 0) (,conses 0) ,results) 
+       (setf ,results (multiple-value-list 
+			    (measure ,seconds ,conses ,@body)))
+       (values-list (nconc (list ,seconds ,conses)
+			   ,results)))))
+
+(defvar *functions-to-profile* nil)
+
+(defvar *additional-markers* nil)
+
+(defvar *profiling-threshold* nil)
+
+(defun make-profiled-function (fn)
+  (lambda (style count-calls-p)
+    (declare (ignorable style count-calls-p))
+    #+allegro
+    (prof:with-profiling (:type style :count count-calls-p)
+      (funcall fn))
+    #-allegro
+    (funcall fn)))
+
+(defun generate-profile-log-entry (log-name name seconds conses results error)
+  (ensure-directories-exist log-name)
+  ;;log 
+  (with-open-file (output log-name
+			  :direction :output
+			  :if-does-not-exist :create
+			  :if-exists :append)
+    (with-standard-io-syntax
+      (let ((*print-readably* nil))
+	(terpri output)
+	(format output "\(~11,d ~20,s ~10,s ~10,s ~{~s~^ ~} ~s ~s ~a\)"
+		(date-stamp :include-time? t) name 
+		seconds conses *additional-markers*
+		results (current-profile-sample-count)
+		error)))))
+
+(defun count-repetitions (fn delay &rest args)
+  (declare (dynamic-extent args))
+  (let ((event-count 0))
+    (handler-case
+	(with-timeout (delay) 
+	  (loop  
+	     (apply #'funcall fn args)
+	     (incf event-count)))
+      (timeout-error (c)
+	(declare (ignore c))
+	(if (plusp event-count)
+	    (/ event-count delay)
+	    event-count)))))
+
+#+test
+(defun fibo (n)
+  (cond ((< n 2)
+	 1)
+	(t
+	 (+ (fibo (- n 1)) (fibo (- n 2))))))
+
+#+test
+(with-profile-report ('test :time) 
+  (loop for i from 1 to 10 do
+       (fibo i))
+  (loop for i from 10 downto 1 do
+       (fibo i)))
+

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

@@ -0,0 +1,161 @@
+(in-package #:common-lisp-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package '#:lift)
+    (defpackage #:lift
+      (:use #:common-lisp #:com.metabang.trivial-timeout)
+      (:import-from		     
+       #+allegro #:mop
+       #+clisp #:clos
+       #+lispworks #:clos
+       #+(or mcl ccl) #:ccl
+       #+cmu #:clos-mop
+       #+sbcl #:sb-mop
+       #+scl #:clos
+       #:class-direct-subclasses
+       #:class-direct-superclasses
+       #:class-precedence-list)
+      (:export
+       #:*lift-report-detail-hook*
+       #:*lift-report-header-hook*
+       #:*lift-report-footer-hook*
+       #:describe-test-result
+       #:with-timeout
+
+       #:testsuite-ambiguous
+       #:testsuite-not-defined)
+      (:export
+       #:test-mixin
+       #:test-result
+       #:testsuite-p
+       #:*test-result*
+       #:*current-test*
+       #:last-test-status
+       #:suite-tested-p
+       #:failures
+       #:expected-failures
+       #:errors
+       #:expected-errors
+       #:ensure-cases
+       #:ensure-random-cases
+       #:deftestsuite
+       #:addtest
+       #:remove-test
+       #:run-test
+       #:run-tests
+
+       #:defmeasure
+       #:undefmeasure
+       #:measure-space
+       #:measure-seconds
+       #:while-measuring
+
+       #:measure-time
+       #:measure-conses
+
+       #:with-profile-report
+       #:write-profile-information
+       #:profiling-threshold*
+       #:*benchmark-log-path*
+       #:count-repetitions
+       #:while-counting-repetitions
+       #:while-counting-events
+
+       ;; Variables
+       #:*test-ignore-warnings?*
+       #:*test-break-on-errors?*
+       #:*test-break-on-failures?*
+       #:*test-print-length*
+       #:*test-print-level*
+       #:*test-print-when-defined?*
+       #:*test-evaluate-when-defined?*
+       #:*test-describe-if-not-successful?*
+       #:*test-maximum-time*
+       #:*test-print-testsuite-names*
+       #:*test-print-test-case-names*
+       #:*test-maximum-error-count*
+       #:*test-maximum-failure-count*
+       #:*lift-dribble-pathname*
+       #:*lift-report-pathname*
+       #:*current-asdf-system-name*
+       #:*test-scratchpad*
+       #:*test-notepad*
+       #:*lift-equality-test*
+       #:*lift-debug-output*
+       #:*test-show-expected-p*
+       #:*test-show-details-p*
+       #:*test-show-code-p*
+          
+       ;; Other
+       #:ensure
+       #:ensure-null
+       #:ensure-same
+       #:ensure-different
+       #:ensure-condition
+       #:ensure-warning
+       #:ensure-error
+       #:ensure-no-warning
+          
+       ;;?? Not yet
+       ;; with-test
+          
+       #:list-tests
+       #:print-tests
+       #:map-testsuites
+       #:testsuites
+       #:testsuite-tests
+	    
+       #:suite
+       #:find-testsuite
+       #:find-test-case
+       #:ensure-random-cases-failure
+       #:random-instance-for-suite
+       #:defrandom-instance
+       #:ensure-random-cases
+       #:ensure-random-cases+
+       #:random-element
+       #:random-number
+       #:an-integer
+       #:a-double-float
+       #:a-single-float
+       #:a-symbol
+
+       #:lift-result
+       #:lift-property
+       #:liftpropos
+
+       #:handle-config-preference
+       ))))
+
+(unless (and (find-package :asdf)
+	     (find-symbol (symbol-name 'system-relative-pathname) :asdf)
+	     (fboundp (find-symbol
+		       (symbol-name 'system-relative-pathname) :asdf)))
+  (warn "LIFT uses asdf:system-relative-pathname which your version of ASDF 
+doesn't seem to include. LIFT will define these for now but you may want to consider updating to the most recent version of ASDF (see http://www.cliki.net/asdf for details).")
+  (intern (symbol-name 'system-source-file) :asdf)
+  (intern (symbol-name 'system-source-directory) :asdf)
+  (intern (symbol-name 'system-relative-pathname) :asdf)
+  (export 'asdf::system-relative-pathname :asdf) 
+  (defun asdf::system-source-file (system-name)
+    (let ((system (asdf:find-system system-name)))
+      (make-pathname 
+       :type "asd"
+       :name (asdf:component-name system)
+       :defaults (asdf:component-relative-pathname system))))
+
+  (defun asdf::system-source-directory (system-name)
+    (make-pathname :name nil
+		   :type nil
+		   :defaults (asdf::system-source-file system-name)))
+
+  (defun asdf::system-relative-pathname (system pathname &key name type)
+    (let ((directory (pathname-directory pathname)))
+      (when (eq (car directory) :absolute)
+	(setf (car directory) :relative))
+      (merge-pathnames
+       (make-pathname :name (or name (pathname-name pathname))
+		      :type (or type (pathname-type pathname))
+		      :directory directory)
+       (asdf::system-source-directory system)))))
+  

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

@@ -0,0 +1,151 @@
+(in-package #:lift)
+
+(setf (documentation 'get-backtrace 'function)
+  "This is the function that is used internally by Hunchentoot to
+show or log backtraces.  It accepts a condition object ERROR and
+returns a string with the corresponding backtrace.")
+
+(defun ensure-directory (pathname)
+  (merge-pathnames #+clisp
+		   (make-pathname :name "" :type "")
+		   #-clisp
+		   (make-pathname :name :unspecific :type :unspecific)
+		   pathname))
+
+(defun writable-directory-p (directory)
+  (let ((directory (ensure-directory directory)))
+    (and (probe-file directory)
+	 #+allegro
+	 (excl.osi:access directory excl.osi:*w-ok*))))
+
+;; Handle missing platforms gracefully?
+(defun total-bytes-allocated ()
+  (if (fboundp '%total-bytes-allocated)
+    (funcall '%total-bytes-allocated)
+    0))
+
+#+allegro
+(defun %total-bytes-allocated ()
+  (sys::gsgc-totalloc-bytes t))
+
+#+(or digitool openmcl ccl)
+(defun %total-bytes-allocated ()
+  (ccl::total-bytes-allocated))
+
+#+sbcl
+(defun %total-bytes-allocated ()
+  (cl-user::get-bytes-consed))
+
+#+(or cmu scl)
+(defun %total-bytes-allocated ()
+  (ext:get-bytes-consed))
+
+#+lispworks
+;; thanks to Frank Schorr, via e-mail
+(defun %total-bytes-allocated ()
+  (hcl:total-allocation))
+
+#+(or mcl ccl)
+(defun get-backtrace (error)
+  (with-output-to-string (s)
+    (let ((*debug-io* s))
+      (format *terminal-io* "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
+              error)
+      (ccl:print-call-history :detailed-p nil))))
+
+#+allegro
+(defun get-backtrace (error)
+  (with-output-to-string (s)
+    (with-standard-io-syntax
+      (let ((*print-readably* nil)
+            (*print-miser-width* 40)
+            (*print-pretty* t)
+            (tpl:*zoom-print-circle* t)
+            (tpl:*zoom-print-level* nil)
+            (tpl:*zoom-print-length* nil))
+        (cl:ignore-errors
+          (format *terminal-io* "~&~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
+                  error))
+        (cl:ignore-errors
+          (let ((*terminal-io* s)
+                (*standard-output* s))
+            (tpl:do-command "zoom"
+                            :from-read-eval-print-loop nil
+                            :count t
+                            :all t)))))))
+
+#+(or)
+(defun zoom-to-stream (condition output)
+  (with-standard-io-syntax
+    (let ((*print-readably* nil)
+	  (*print-miser-width* 40)
+	  (*print-pretty* t)
+	  (tpl:*zoom-print-circle* t)
+	  (tpl:*zoom-print-level* nil)
+	  (tpl:*zoom-print-length* nil))
+      (ignore-errors 
+	(format *terminal-io* "Creating backtrace for ~a to ~a" 
+		condition output))
+      (flet ((zoom (s)
+	       (ignore-errors
+		 (let ((*terminal-io* s)
+		       (*standard-output* s))
+		   (tpl:do-command "zoom"
+		     :from-read-eval-print-loop nil
+		   :count t :all t)))))
+	(cond ((streamp output)
+	       (zoom output))
+	      (t
+	       (ensure-directories-exist output)
+	       (with-open-file (s output :direction :output
+				  :if-exists :supersede
+				  :if-does-not-exist :create)
+		 (zoom s))))))))
+
+#+lispworks
+(defun get-backtrace (error)
+  (declare (ignore error))
+  (with-output-to-string (s)
+    (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum))
+          (*debug-io* s)
+          (dbg:*debug-print-level* nil)
+          (dbg:*debug-print-length* nil))
+      (dbg:bug-backtrace nil))))
+
+#+sbcl
+;; determine how we're going to access the backtrace in the next
+;; function
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug)
+    (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*)))
+
+#+sbcl
+(defun get-backtrace (error)
+  (declare (ignore error))
+  (with-output-to-string (s)
+    #+:hunchentoot-sbcl-debug-print-variable-alist
+    (let ((sb-debug:*debug-print-variable-alist*
+            (list* '(*print-level* . nil)
+                   '(*print-length* . nil)
+                   sb-debug:*debug-print-variable-alist*)))
+      (sb-debug:backtrace most-positive-fixnum s))
+    #-:hunchentoot-sbcl-debug-print-variable-alist
+    (let ((sb-debug:*debug-print-level* nil)
+          (sb-debug:*debug-print-length* nil))
+      (sb-debug:backtrace most-positive-fixnum s))))
+
+#+clisp
+(defun get-backtrace (error)
+  (declare (ignore error))
+  (with-output-to-string (s)
+    (system::print-backtrace :out s)))
+
+#+(or cmucl scl)
+(defun get-backtrace (error)
+  (declare (ignore error))
+  (with-output-to-string (s)
+    (let ((debug:*debug-print-level* nil)
+          (debug:*debug-print-length* nil))
+      (debug:backtrace most-positive-fixnum s))))
+
+