clucumber 0.1.1 → 0.2.0

data/lib/clucumber/vendor/lift/timeout/with-timeout.lisp

@@ -0,0 +1,123 @@
+(in-package #:com.metabang.trivial-timeout)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(unless (and (find-symbol (symbol-name '#:with-timeout)
+        '#:com.metabang.trivial-timeout)
+       (fboundp (find-symbol (symbol-name '#:with-timeout)
+        '#:com.metabang.trivial-timeout)))
+(define-condition timeout-error (error)
+                  ()
+  (:report (lambda (c s)
+       (declare (ignore c))
+       (format s "Process timeout")))
+  (:documentation "An error signaled when the duration specified in 
+the [with-timeout][] is exceeded."))
+
+(defmacro with-timeout ((seconds) &body body)
+  "Execute `body` for no more than `seconds` time. 
+
+If `seconds` is exceeded, then a [timeout-error][] will be signaled. 
+
+If `seconds` is nil, then the body will be run normally until it completes
+or is interrupted."
+  (build-with-timeout seconds body))
+
+(defun build-with-timeout (seconds body)
+  (let ((gseconds (gensym "seconds-"))
+  (gdoit (gensym "doit-")))
+    `(let ((,gseconds ,seconds))
+       (flet ((,gdoit ()
+    (progn ,@body)))
+   (cond (,gseconds
+    ,(generate-platform-specific-code gseconds gdoit))
+         (t
+    (,gdoit)))))))
+
+#+allegro
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+  `(mp:with-timeout (,seconds-symbol (error 'timeout-error)) 
+     (,doit-symbol)))
+
+
+#+(and sbcl (not sb-thread))
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+  (let ((glabel (gensym "label-"))
+  (gused-timer? (gensym "used-timer-")))
+    `(let ((,gused-timer? nil))
+       (catch ',glabel
+   (sb-ext:schedule-timer
+    (sb-ext:make-timer (lambda ()
+             (setf ,gused-timer? t)
+             (throw ',glabel nil)))
+    ,seconds-symbol)
+   (,doit-symbol))
+       (when ,gused-timer?
+   (error 'timeout-error)))))
+
+#+(and sbcl sb-thread)
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+  `(handler-case 
+      (sb-ext:with-timeout ,seconds-symbol (,doit-symbol))
+    (sb-ext::timeout (c)
+      (declare (ignore c))
+      (error 'timeout-error))))
+
+#+cmu
+;;; surely wrong
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+  `(handler-case 
+      (mp:with-timeout (seconds-symbol) (,doit-symbol))
+    (sb-ext::timeout (c)
+      (declare (ignore c))
+      (error 'timeout-error))))
+
+#+(or digitool openmcl ccl)
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+  (let ((checker-process (format nil "Checker ~S" (gensym)))
+   (waiting-process (format nil "Waiter ~S" (gensym)))
+   (result (gensym))
+   (process (gensym)))
+    `(let* ((,result nil)
+      (,process (ccl:process-run-function 
+           ,checker-process
+           (lambda ()
+       (setf ,result (progn (,doit-symbol))))))) 
+       (ccl:process-wait-with-timeout
+  ,waiting-process
+  (* ,seconds-symbol #+(or openmcl ccl)
+     ccl:*ticks-per-second* #+digitool 60)
+  (lambda ()
+    (not (ccl::process-active-p ,process)))) 
+       (when (ccl::process-active-p ,process)
+   (ccl:process-kill ,process)
+   (cerror "Timeout" 'timeout-error))
+       (values ,result))))
+
+#+lispworks
+(defun generate-platform-specific-code (seconds-symbol doit-symbol)
+  (let ((gresult (gensym "result-"))
+  (gprocess (gensym "process-")))
+    `(let* (,gresult
+      (,gprocess (mp:process-run-function
+      "WITH-TIMEOUT"
+      '()
+      (lambda ()
+        (setq ,gresult (,doit-symbol))))))
+       (unless (mp:process-wait-with-timeout
+    "WITH-TIMEOUT"
+    ,seconds-symbol
+    (lambda ()
+      (not (mp:process-alive-p ,gprocess))))
+   (mp:process-kill ,gprocess)
+   (cerror "Timeout" 'timeout-error))
+       ,gresult)))
+
+(unless (let ((symbol
+         (find-symbol (symbol-name '#:generate-platform-specific-code)
+          '#:com.metabang.trivial-timeout)))
+    (and symbol (fboundp symbol)))
+  (defun generate-platform-specific-code (seconds-symbol doit-symbol)
+    (declare (ignore seconds-symbol))
+    `(,doit-symbol)))
+
+))

data/lib/clucumber/vendor/lift/website/stuff/Temp.lisp

@@ -0,0 +1,34 @@
+(in-package #:few)
+
+#+Ignore
+;; suck site up and output as LML
+(mapc 
+ (lambda (file)
+   (let ((html (net.html.parser:parse-html file)))
+     (setf html (remove-if (lambda (x)
+                             (and (consp x)
+                                  (member (first x) '(:!doctype))))
+                           html))
+     (with-new-file (s (make-pathname :type "lml" :defaults file)
+                       :print-right-margin 70)
+       (format s "~S" html))))
+ (directory "Billy-Pilgrim:Users:gwking:darcs:metabang.tinaa:website:*.html"))
+
+(net.html.parser:parse-html 
+ #P"Billy-Pilgrim:Users:gwking:darcs:metabang.tinaa:website:index.html")
+
+(probe-file
+ "Billy-Pilgrim:Users:gwking:darcs:cl-containers:website:index.shtml")
+
+(eval `(html
+        ((:html :xmlns "http://www.w3.org/1999/xhtml")
+         ,@(rest ccl:!))))
+
+
+
+#+No
+(with-new-file (*html-stream* (spy (make-pathname :type "lml" :defaults file)))
+  (dtd-prologue :xhtml11)
+  (eval `(html
+          ((:html :xmlns "http://www.w3.org/1999/xhtml")
+           ,@html))))

data/lib/clucumber/vendor/st-json/st-json.asd

@@ -0,0 +1,3 @@
+(asdf:defsystem :st-json
+  :depends-on ()
+  :components ((:file "st-json")))

data/lib/clucumber/vendor/st-json/st-json.lisp

@@ -0,0 +1,310 @@
+(defpackage :st-json
+  (:use :common-lisp)
+  (:export #:read-json #:read-json-as-type #:read-json-from-string
+           #:write-json #:write-json-to-string #:write-json-element
+           #:as-json-bool #:from-json-bool
+           #:json-bool #:json-null
+           #:jso #:getjso #:mapjso
+           #:json-error #:json-type-error #:json-parse-error
+           #:json-eof-error
+           #:*script-tag-hack*))
+
+(in-package :st-json)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *optimize*
+    '(optimize (speed 3) (safety 0) (space 1) (debug 1) (compilation-speed 0))))
+
+;; Boolean types. It is hard to see what is meant by NIL when encoding
+;; a lisp value -- false or [] -- so :false and :true are used instead
+;; of T and NIL.
+(defun as-json-bool (value)
+  "Convert a generalised boolean to a :true/:false keyword."
+  (if value :true :false))
+(defun from-json-bool (value)
+  "Convert :true or :false to its boolean equivalent."
+  (ecase value (:true t) (:false nil)))
+
+;; Types that might be useful when checking the type of input.
+(deftype json-bool () '(member :true :false))
+(deftype json-null () '(eql :null))
+
+;; These are used to represent JS objects on the Lisp side -- hash
+;; tables are too heavyweight on some implementations.
+(defstruct jso alist)
+(defun jso (&rest fields)
+  "Create a JS object. Arguments should be alternating labels and values."
+  (make-jso :alist (loop :for (key val) :on fields :by #'cddr
+                           :collect (cons key val))))
+
+;; A hash-table-like interface for JS objects.
+(defun getjso (key map)
+  "Fetch a value from a JS object. Returns a second value like
+gethash."
+  (let ((pair (assoc key (jso-alist map) :test #'string=)))
+    (values (cdr pair) (and pair t))))
+(defun (setf getjso) (val key map)
+  "Store a value in a JS object."
+  (let ((pair (assoc key (jso-alist map) :test #'string=)))
+    (if pair
+        (setf (cdr pair) val)
+        (prog1 val (push (cons key val) (jso-alist map))))))
+(defun mapjso (func map)
+  "Iterate over the key/value pairs in a JS object."
+  (loop :for (key . val) :in (jso-alist map)
+        :do (funcall func key val)))
+
+;; Reader
+
+(define-condition json-error (simple-error) ())
+(define-condition json-parse-error (json-error) ())
+(define-condition json-eof-error (json-parse-error) ())
+(define-condition json-write-error (json-error) ())
+(define-condition json-type-error (json-error) ())
+(defun raise (type format &rest args)
+  (error type :format-control format :format-arguments args))
+
+(defvar *reading-slot-name* nil)
+
+(defun is-whitespace (char)
+  (member char '(#\space #\newline #\return #\tab)))
+
+(defun ends-atom (char)
+  (or (is-whitespace char) (member char '(#\) #\] #\} #\, #\:))))
+
+(defun skip-whitespace (stream)
+  (declare #.*optimize*)
+  (loop :while (is-whitespace (peek-char nil stream nil))
+        :do (read-char stream)))
+
+(defun at-eof (stream)
+  (eql (peek-char nil stream nil :eof) :eof))
+
+(defgeneric read-json (in &optional junk-allowed-p)
+  (:documentation "Read a JSON-encoded value from a stream or a string."))
+
+(defmethod read-json ((in stream) &optional (junk-allowed-p t))
+  (let ((value (read-json-element in)))
+    (skip-whitespace in)
+    (unless (or junk-allowed-p (at-eof in))
+      (raise 'json-parse-error "Unused characters at end of input."))
+    value))
+
+(defmethod read-json ((in string) &optional (junk-allowed-p nil))
+  (with-input-from-string (stream in)
+    (read-json stream junk-allowed-p)))
+
+(defun read-json-from-string (string &key (start 0) end junk-allowed-p)
+  (let (index value)
+    (with-input-from-string (stream string :index index :start start :end end)
+      (setf value (read-json stream junk-allowed-p)))
+    (values value index)))
+
+(defun read-json-as-type (source type)
+  "Read a JSON value and assert the result to be of a given type.
+Raises a json-type-error when the type is wrong."
+  (let ((val (read-json source)))
+    (if (typep val type)
+        val
+        (raise 'json-type-error "JSON input '~A' is not of expected type ~A." source type))))
+
+(defun read-json-element (stream)
+  (declare #.*optimize*)
+  (skip-whitespace stream)
+  (case (peek-char nil stream nil :eof)
+    (:eof (raise 'json-eof-error "Unexpected end of input."))
+    ((#\" #\') (read-json-string stream))
+    (#\[ (read-json-list stream))
+    (#\{ (read-json-object stream))
+    (t (read-json-atom stream))))
+
+(defun read-json-string (stream)
+  (declare #.*optimize*)
+  (labels ((interpret (char)
+             (if (eql char #\\)
+                 (let ((escaped (read-char stream)))
+                   (case escaped
+                     (#\u (read-unicode))
+                     (#\b #\backspace) (#\n #\newline) (#\r #\return)
+                     (#\t #\tab) (#\f #\page) (t escaped)))
+                 char))
+           (read-unicode ()
+             (code-char (loop :for pos :from 0 :below 4
+                              :for weight :of-type fixnum := #.(expt 16 3) :then (ash weight -4)
+                              :for digit := (digit-char-p (read-char stream) 16)
+                              :do (unless digit (raise 'json-parse-error "Invalid unicode constant in string."))
+                              :sum (* digit weight)))))
+    (with-output-to-string (out)
+      (handler-case
+          (loop :with quote :of-type character := (read-char stream)
+                :for next :of-type character := (read-char stream)
+                :until (eql next quote)
+                :do (write-char (interpret next) out))
+        (end-of-file () (raise 'json-eof-error "Encountered end of input inside string constant."))))))
+
+(defun gather-comma-separated (stream end-char obj-name gather-func)
+  (declare #.*optimize*)
+  (declare (type character end-char))
+  (declare (type function gather-func))
+  ;; Throw away opening char
+  (read-char stream)
+  (let ((finished nil))
+    (loop
+     (skip-whitespace stream)
+     (let ((next (peek-char nil stream nil #\nul)))
+       (declare (type character next))
+       (when (eql next #\nul)
+         (raise 'json-eof-error "Encountered end of input inside ~A." obj-name))
+       (when (eql next end-char)
+         (read-char stream)
+         (return))
+       (when finished
+         (raise 'json-parse-error "Comma or end of ~A expected, found '~A'" obj-name next)))
+     (funcall gather-func)
+     (skip-whitespace stream)
+     (if (eql (peek-char nil stream nil) #\,)
+         (read-char stream)
+         (setf finished t)))))
+
+(defun read-json-list (stream)
+  (declare #.*optimize*)
+  (let ((accum ()))
+    (gather-comma-separated
+     stream #\] "list"
+     (lambda ()
+       (push (read-json-element stream) accum)))
+    (nreverse accum)))
+
+(defun read-json-object (stream)
+  (declare #.*optimize*)
+  (let ((accum ()))
+    (gather-comma-separated 
+     stream #\} "object literal"
+     (lambda ()
+       (let ((slot-name (let ((*reading-slot-name* t)) (read-json-element stream))))
+         (unless (or (typep slot-name 'string) (typep slot-name 'number))
+           (raise 'json-parse-error "Invalid slot name in object literal: ~A" slot-name))
+         (skip-whitespace stream)
+         (when (not (eql (read-char stream nil) #\:))
+           (raise 'json-parse-error "Colon expected after '~a'." slot-name))
+         (push (cons slot-name (read-json-element stream)) accum))))
+    (make-jso :alist (nreverse accum))))
+
+(defun looks-like-a-number (string)
+  (declare #.*optimize*)
+  (let ((string (coerce string 'simple-string)))
+    (every (lambda (char)
+             (or (digit-char-p char)
+                 (member char '(#\e #\E #\. #\- #\+))))
+           string)))
+
+(defun read-json-atom (stream)
+  (declare #.*optimize*)
+  (let ((accum (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
+    (loop
+     (let ((next (peek-char nil stream nil :eof)))
+       (when (or (ends-atom next) (eql next :eof))
+         (return))
+       (vector-push-extend next accum)
+       (read-char stream)))
+    (let ((number-val (and (looks-like-a-number accum)
+                           (ignore-errors (read-from-string accum)))))
+      (cond ((numberp number-val) number-val)
+            ((string= accum "false") :false)
+            ((string= accum "true") :true)
+            ((string= accum "null") :null)
+            ((string= accum "undefined") :undefined)
+            ((and *reading-slot-name*
+                  (every (lambda (c)
+                           (declare (type character c))
+                           (or (alphanumericp c) (eql c #\_) (eql c #\$)))
+                         accum))
+             accum)
+            (t (raise 'json-parse-error "Unrecognized value in JSON data: ~A" accum))))))
+
+;; Writer
+
+(defparameter *script-tag-hack* nil
+  "Bind this to T when writing JSON that will be written to an HTML
+  document. It prevents '</script>' from occurring in strings by
+  escaping any slash following a '<' character.")
+
+(defun write-json-to-string (element)
+  "Write a value's JSON representation to a string."
+  (with-output-to-string (out)
+    (write-json element out)))
+
+(defun write-json (element stream)
+  "Write a value's JSON representation to a stream."
+  (let ((*print-pretty* nil))
+    (write-json-element element stream)
+    (values)))
+
+(defgeneric write-json-element (element stream)
+  (:method (element stream)
+    (declare (ignore stream))
+    (raise 'json-write-error "Can not write object of type ~A as JSON." (type-of element)))
+  (:documentation "Method used for writing values of a specific type.
+  You can specialise this for your own types."))
+
+(defmethod write-json-element ((element symbol) stream)
+  (declare #.*optimize*)
+  (ecase element
+    ((nil) (write-string "[]" stream))
+    ((t :true) (write-string "true" stream))
+    (:false (write-string "false" stream))
+    (:undefined (write-string "undefined" stream))
+    (:null (write-string "null" stream))))
+
+(defmethod write-json-element ((element string) stream)
+  (declare #.*optimize*)
+  (let ((element (coerce element 'simple-string)))
+    (write-char #\" stream)
+    (loop :for prev := nil :then ch
+          :for ch :across element
+          :do (princ
+               (case ch
+                 (#\\ "\\\\") (#\" "\\\"")
+                 (#\backspace "\\b") (#\newline "\\n")
+                 (#\return "\\r") (#\page "\\f")
+                 (#\tab "\\t")
+                 ;; Prevent </script> by escaping every #\/ that follows a #\<
+                 (#\/ (if (and *script-tag-hack* (eql prev #\<)) "\\/" #\/))
+                 (t ch))
+               stream))
+    (write-char #\" stream)))
+
+(defmethod write-json-element ((element integer) stream)
+  (write element :stream stream))
+
+(defmethod write-json-element ((element real) stream)
+  (format stream "~,,,,,,'eE" element))
+
+(defmethod write-json-element ((element hash-table) stream)
+  (declare #.*optimize*)
+  (write-json-element
+   (make-jso :alist (loop :for key :being :the :hash-key :using (hash-value val) :of element
+                            :collect (cons key val)))
+   stream))
+
+(defmethod write-json-element ((element jso) stream)
+  (declare #.*optimize*)
+  (write-char #\{ stream)
+  (loop :for (key . val) :in (jso-alist element)
+        :for first := t :then nil
+        :unless first :do (write-char #\, stream)
+        :do (write-json-element key stream)
+        :do (write-char #\: stream)
+        :do (write-json-element val stream))
+  (write-char #\} stream))
+
+(defmethod write-json-element ((element list) stream)
+  (declare #.*optimize*)
+  (write-char #\[ stream)
+  (let ((first t))
+    (dolist (part element)
+     (if first
+         (setf first nil)
+         (write-char #\, stream))
+     (write-json-element part stream)))
+  (write-char #\] stream))

data/lib/clucumber/vendor/trivial-backtrace/dev/backtrace.lisp

@@ -0,0 +1,127 @@
+(in-package #:trivial-backtrace)
+
+(defun print-condition (condition stream)
+  "Print `condition` to `stream` using the pretty printer."
+  (format
+   stream
+   "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
+   condition))
+  
+(defun print-backtrace (error &key (output *debug-io*)
+			(if-exists :append)
+			(verbose nil))
+  "Send a backtrace for the error `error` to `output`. 
+
+The keywords arguments are:
+
+ * :output - where to send the output. This can be:
+
+     * a string (which is assumed to designate a pathname)
+     * an open stream
+     * nil to indicate that the backtrace information should be 
+       returned as a string
+
+ * if-exists - what to do if output designates a pathname and 
+   the pathname already exists. Defaults to :append.
+
+ * verbose - if true, then a message about the backtrace is sent
+   to \\*terminal-io\\*. Defaults to `nil`.
+
+If the `output` is nil, the returns the backtrace output as a
+string. Otherwise, returns nil.
+"
+  (when verbose
+    (print-condition error *terminal-io*))
+  (multiple-value-bind (stream close?)
+      (typecase output
+	(null (values (make-string-output-stream) nil))
+	(string (values (open output :if-exists if-exists
+			      :if-does-not-exist :create
+			      :direction :output) t))
+	(stream (values output nil)))
+    (unwind-protect
+	 (progn
+	   (format stream "~&Date/time: ~a" (date-time-string))
+	   (print-condition error stream)
+	   (terpri stream)
+	   (print-backtrace-to-stream stream)
+	   (terpri stream)
+	   (when (typep stream 'string-stream)
+	     (get-output-stream-string stream)))
+	 ;; cleanup
+	 (when close?
+	   (close stream)))))
+
+#+(or mcl ccl)
+(defun print-backtrace-to-stream (stream)
+  (let ((*debug-io* stream))
+    (ccl:print-call-history :detailed-p nil)))
+
+#+allegro
+(defun print-backtrace-to-stream (stream)
+  (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
+       (let ((*terminal-io* stream)
+	     (*standard-output* stream))
+	 (tpl:do-command "zoom"
+	   :from-read-eval-print-loop nil
+	   :count t
+	   :all t))))))
+
+#+lispworks
+(defun print-backtrace-to-stream (stream)
+  (let ((dbg::*debugger-stack*
+	 (dbg::grab-stack nil :how-many most-positive-fixnum))
+	(*debug-io* stream)
+	(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 :sbcl-debug-print-variable-alist *features*)))
+
+#+sbcl
+(defun print-backtrace-to-stream (stream)
+  (let (#+:sbcl-debug-print-variable-alist
+	(sb-debug:*debug-print-variable-alist*
+	 (list* '(*print-level* . nil)
+		'(*print-length* . nil)
+		sb-debug:*debug-print-variable-alist*))
+	#-:sbcl-debug-print-variable-alist
+	(sb-debug:*debug-print-level* nil)
+	#-:sbcl-debug-print-variable-alist
+	(sb-debug:*debug-print-length* nil))
+    (sb-debug:backtrace most-positive-fixnum stream)))
+
+#+clisp
+(defun print-backtrace-to-stream (stream)
+  (system::print-backtrace :out stream))
+
+#+(or cmucl scl)
+(defun print-backtrace-to-stream (stream)
+  (let ((debug:*debug-print-level* nil)
+	(debug:*debug-print-length* nil))
+    (debug:backtrace most-positive-fixnum stream)))
+
+
+;; must be after the defun above or the docstring may be wiped out
+(setf (documentation 'print-backtrace-to-stream 'function)
+  "Send a backtrace of the current error to stream. 
+
+Stream is assumed to be an open writable file stream or a
+string-output-stream. Note that `print-backtrace-to-stream`
+will print a backtrace for whatever the Lisp deems to be the 
+*current* error.
+")
+
+

data/lib/clucumber/vendor/trivial-backtrace/dev/fallback.lisp

@@ -0,0 +1,10 @@
+(in-package #:trivial-backtrace)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (fboundp 'map-backtrace)
+    (defun map-backtrace (func)
+      (declare (ignore func))))
+
+  (unless (fboundp 'print-backtrace-to-stream)
+    (defun print-backtrace-to-stream (stream)
+      (format stream "~&backtrace output unavailable.~%"))))