clucumber 0.1.1 → 0.2.0

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

@@ -0,0 +1,103 @@
+(in-package #:trivial-backtrace)
+
+(defstruct frame
+  func
+  source-filename
+  source-pos
+  vars)
+
+(defstruct var
+  name
+  value)
+
+(defstruct pos-form-number
+  number)
+
+(defmethod print-object ((pos-form-number pos-form-number) stream)
+  (cond 
+    (*print-readably* (call-next-method))
+    (t
+     (format stream "f~A" (pos-form-number-number pos-form-number)))))
+
+
+(defvar *trivial-backtrace-frame-print-specials*
+  '((*print-length* . 100)
+    (*print-level* . 20)
+    (*print-lines* . 5)
+    (*print-pretty* . t)
+    (*print-readably* . nil)))
+
+(defun print-frame (frame stream)
+  (format stream "~A:~@[~A:~] ~A: ~%" 
+	  (or (ignore-errors (translate-logical-pathname (frame-source-filename frame))) (frame-source-filename frame) "<unknown>")
+	  (frame-source-pos frame)
+	  (frame-func frame))
+  (loop for var in (frame-vars frame)
+	do 
+	(format stream " ~A = ~A~%" (var-name var) 
+		(or (ignore-errors 	
+			(progv 
+			    (mapcar #'car *trivial-backtrace-frame-print-specials*)
+			    (mapcar #'cdr *trivial-backtrace-frame-print-specials*)
+			  (prin1-to-string 
+			   (var-value var))))
+		    "<error>"))))
+
+(defun map-backtrace (function)
+  (impl-map-backtrace function))
+
+(defun print-map-backtrace (&optional (stream *debug-io*) &rest args)
+  (apply 'map-backtrace 
+	 (lambda (frame)
+	   (print-frame frame stream)) args))
+
+(defun backtrace-string (&rest args)
+  (with-output-to-string (stream)
+    (apply 'print-map-backtrace stream args)))
+
+
+#+ccl
+(defun impl-map-backtrace (func)
+  (ccl::map-call-frames (lambda (ptr) 
+			  (multiple-value-bind (lfun pc)
+			      (ccl::cfp-lfun ptr)
+			    (let ((source-note (ccl:function-source-note lfun)))
+			      (funcall func 
+				       (make-frame :func (ccl::lfun-name lfun)
+						   :source-filename (ccl:source-note-filename source-note)
+						   :source-pos (let ((form-number (ccl:source-note-start-pos source-note)))
+								 (when form-number (make-pos-form-number :number form-number)))
+						   :vars (loop for (name . value) in (ccl::arguments-and-locals nil ptr lfun pc)
+							       collect (make-var :name name :value value)))))))))
+
+#+sbcl
+(defun impl-map-backtrace (func)
+  (loop for f = (or sb-debug:*stack-top-hint* (sb-di:top-frame)) then (sb-di:frame-down f)
+	while f
+	do (funcall func 
+		    (make-frame :func 
+				(ignore-errors
+				  (sb-di:debug-fun-name 			    
+				   (sb-di:frame-debug-fun f)))
+				:source-filename 
+				(ignore-errors
+				  (sb-di:debug-source-namestring (sb-di:code-location-debug-source (sb-di:frame-code-location f))))
+				:source-pos
+				(ignore-errors ;;; XXX does not work
+				  (let ((cloc (sb-di:frame-code-location f)))
+				    (unless (sb-di:code-location-unknown-p cloc)
+				      (format nil "tlf~Dfn~D"
+					      (sb-di:code-location-toplevel-form-offset cloc)
+					      (sb-di:code-location-form-number cloc)))))
+				:vars
+				(remove-if 'not 
+					   (map 'list (lambda(v)
+							(ignore-errors
+							  (when (eq :valid
+							     (sb-di:debug-var-validity v (sb-di:frame-code-location f)))
+							    (make-var :name (sb-di:debug-var-symbol v)
+								      :value (sb-di:debug-var-value v f)))))
+						(ignore-errors (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun f)))))))))
+
+
+

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

@@ -0,0 +1,75 @@
+(in-package #:metabang.gsn)
+
+#|
+Need to account for different kinds of links
+  in gsn-nodes-from-json, need to return pairs of node and attributes
+
+hash-table for nodes to prevent duplicates
+queue or stack for nodes to expand
+hash-table for links (triples of A link B?) to handle duplicates
+|#
+
+(defgeneric expand-node (context node)
+  )
+
+(defgeneric find-neighbors (context node)
+  )
+
+(defgeneric expand-node-p (context node)
+  )
+
+(defgeneric add-node (context node)
+  )
+
+(defgeneric add-link (context node neighbor direction)
+  )
+
+(defgeneric update-node-data (context node data)
+  )
+
+(defclass abstract-context ()
+  ())
+
+(defclass gsn-context (abstract-context)
+  ())
+
+(defparameter +gsn-root+ "http://socialgraph.apis.google.com/")
+
+(defmethod expand-node ((context abstract-context) node)
+  (bind (((to from) (find-neighbors context node)))
+    (dolist (neighbor to)
+      (add-node context neighbor)
+      (add-link context node neighbor :to))
+    (dolist (neighbor from)
+      (add-node context neighbor)
+      (add-link context node neighbor :from))))
+
+
+
+(defmethod find-neighbors ((context gsn-context) node)
+  (bind (((result headers stream)
+	  (http-get 
+	   (format nil "~alookup?edo=1&edi=1&pretty=1&q=~a" 
+		   +gsn-root+ node)))
+	 json)
+    (unwind-protect 
+	 (setf json (json:decode-json stream))
+      (close strea))
+    (update-node-data context node json)		      
+    (list (gsn-nodes-from-json json :to)
+	  (gsn-nodes-from-json json :from))))
+  
+(gsn-nodes-from-json x :from)  
+
+(defun gsn-test (who)
+  (destructuring-bind (result headers stream)
+      (http-get 
+       (format nil "http://socialgraph.apis.google.com/lookup?edo=1&edi=1&pretty=1&q=~a" who))
+    (declare (ignore result headers))
+    (json:decode-json stream)))
+
+(assoc :nodes_referenced 
+       (assoc :nodes (gsn-test "TWITTER.COM/GWKING") :key #'first))
+
+
+(setf x (gsn-test "TWITTER.COM/GWKING")) 

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

@@ -0,0 +1,13 @@
+(in-package #:common-lisp-user)
+
+(defpackage #:trivial-backtrace
+  (:use #:common-lisp)
+  (:export #:print-backtrace
+	   #:print-backtrace-to-stream
+	   #:print-condition
+	   #:*date-time-format*
+
+
+	   #:backtrace-string
+	   #:map-backtrace))
+

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

@@ -0,0 +1,104 @@
+(in-package #:trivial-backtrace)
+
+(defparameter *date-time-format* "%Y-%m-%d-%H:%M"
+  "The default format to use when printing dates and times.
+
+* %% - A '%' character
+* %d - Day of the month as a decimal number [01-31]
+* %e - Same as %d but does not print the leading 0 for days 1 through 9 
+     [unlike strftime[], does not print a leading space]
+* %H - Hour based on a 24-hour clock as a decimal number [00-23]
+*%I - Hour based on a 12-hour clock as a decimal number [01-12]
+* %m - Month as a decimal number [01-12]
+* %M - Minute as a decimal number [00-59]
+* %S - Second as a decimal number [00-59]
+* %w - Weekday as a decimal number [0-6], where Sunday is 0
+* %y - Year without century [00-99]
+* %Y - Year with century [such as 1990]
+
+This code is borrowed from the `format-date` function in 
+[metatilities-base][].")
+
+;; modified from metatilities-base
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro generate-time-part-function (part-name position)
+    (let ((function-name 
+	   (intern 
+	    (concatenate 'string
+			 (symbol-name 'time) "-" (symbol-name part-name))
+	    :trivial-backtrace)))
+      `(eval-when (:compile-toplevel :load-toplevel :execute)
+         (defun ,function-name
+                (&optional (universal-time (get-universal-time))
+                           (time-zone nil))
+           ,(format nil "Returns the ~(~A~) part of the given time." part-name)
+           (nth-value ,position 
+		      (apply #'decode-universal-time
+			     universal-time time-zone))))))
+
+  (generate-time-part-function second 0)
+  (generate-time-part-function minute 1)
+  (generate-time-part-function hour 2)
+  (generate-time-part-function date 3)
+  (generate-time-part-function month 4)
+  (generate-time-part-function year 5)
+  (generate-time-part-function day-of-week 6)
+  (generate-time-part-function daylight-savings-time-p 7))
+
+(defun date-time-string (&key (date/time (get-universal-time))
+			 (format *date-time-format*))
+  (format-date format date/time nil))
+
+(defun format-date (format date &optional stream time-zone)
+  (declare (ignore time-zone))
+  (let ((format-length (length format)))
+    (format 
+     stream "~{~A~}"
+     (loop for index = 0 then (1+ index) 
+	while (< index format-length) collect 
+	(let ((char (aref format index)))
+	  (cond 
+	    ((char= #\% char)
+	     (setf char (aref format (incf index)))
+	     (cond 
+	       ;; %% - A '%' character
+	       ((char= char #\%) #\%)
+                            
+	       ;; %d - Day of the month as a decimal number [01-31]
+	       ((char= char #\d) (format nil "~2,'0D" (time-date date)))
+                            
+	       ;; %e - Same as %d but does not print the leading 0 for 
+	       ;; days 1 through 9. Unlike strftime, does not print a 
+	       ;; leading space
+	       ((char= char #\e) (format nil "~D" (time-date date)))
+                            
+	       ;; %H - Hour based on a 24-hour clock as a decimal number [00-23]
+	       ((char= char #\H) (format nil "~2,'0D" (time-hour date)))
+                            
+	       ;; %I - Hour based on a 12-hour clock as a decimal number [01-12]
+	       ((char= char #\I) (format nil "~2,'0D" 
+					 (1+ (mod (time-hour date) 12))))
+                            
+	       ;; %m - Month as a decimal number [01-12]
+	       ((char= char #\m) (format nil "~2,'0D" (time-month date)))
+                            
+	       ;; %M - Minute as a decimal number [00-59]
+	       ((char= char #\M) (format nil "~2,'0D" (time-minute date)))
+                            
+	       ;; %S - Second as a decimal number [00-59]
+	       ((char= char #\S) (format nil "~2,'0D" (time-second date)))
+                            
+	       ;; %w - Weekday as a decimal number [0-6], where Sunday is 0
+	       ((char= char #\w) (format nil "~D" (time-day-of-week date)))
+                            
+	       ;; %y - Year without century [00-99]
+	       ((char= char #\y) 
+		(let ((year-string (format nil "~,2A" (time-year date))))
+		  (subseq year-string (- (length year-string) 2))))
+                            
+	       ;; %Y - Year with century [such as 1990]
+	       ((char= char #\Y) (format nil "~D" (time-year date)))
+                            
+	       (t
+		(error "Ouch - unknown formatter '%~c" char))))
+	    (t char)))))))

data/lib/clucumber/vendor/trivial-backtrace/test/packages.lisp

@@ -0,0 +1,5 @@
+(in-package #:common-lisp-user)
+
+(defpackage #:trivial-backtrace-test
+  (:use #:common-lisp #:lift #:trivial-backtrace))
+

data/lib/clucumber/vendor/trivial-backtrace/test/test-setup.lisp

@@ -0,0 +1,4 @@
+(in-package #:trivial-backtrace-test)
+
+(deftestsuite trivial-backtrace-test ()
+  ())

data/lib/clucumber/vendor/trivial-backtrace/test/tests.lisp

@@ -0,0 +1,16 @@
+(in-package #:trivial-backtrace-test)
+
+(deftestsuite generates-backtrace (trivial-backtrace-test)
+  ())
+
+(addtest (generates-backtrace)
+  test-1
+  (let ((output nil))
+    (handler-case 
+	(let ((x 1))
+	  (let ((y (- x (expt 1024 0))))
+	    (/ 2 y)))
+      (error (c)
+	(setf output (print-backtrace c :output nil))))
+    (ensure (stringp output))
+    (ensure (plusp (length output)))))

data/lib/clucumber/vendor/trivial-backtrace/trivial-backtrace-test.asd

@@ -0,0 +1,22 @@
+(defpackage #:trivial-backtrace-test-system (:use #:asdf #:cl))
+(in-package #:trivial-backtrace-test-system)
+
+(defsystem trivial-backtrace-test
+  :author "Gary Warren King <gwking@metabang.com>"
+  :maintainer "Gary Warren King <gwking@metabang.com>"
+  :licence "MIT Style License; see file COPYING for details"
+  :components ((:module 
+		"setup"
+		:pathname "test/"
+		:components ((:file "packages")
+			     (:file "test-setup"
+				    :depends-on ("packages"))))
+	       (:module 
+		"test"
+		:pathname "test/"
+		:depends-on ("setup")
+		:components ((:file "tests"))))  
+  :depends-on (:lift :trivial-backtrace))
+
+
+

data/lib/clucumber/vendor/trivial-backtrace/trivial-backtrace.asd

@@ -0,0 +1,35 @@
+(in-package #:common-lisp-user)
+
+(defpackage #:trivial-backtrace-system (:use #:asdf #:cl))
+(in-package #:trivial-backtrace-system)
+
+(defsystem trivial-backtrace
+  :version "1.0.2"
+  :author "Gary Warren King <gwking@metabang.com>"
+  :maintainer "Gary Warren King <gwking@metabang.com>"
+  :licence "MIT Style license "
+  :description "trivial-backtrace"
+  :depends-on ()
+  :components
+  ((:static-file "COPYING")
+   (:module 
+    "setup"
+    :pathname "dev/"
+    :components ((:file "packages")))
+   (:module 
+    "dev"
+    :depends-on ("setup")
+    :components ((:file "utilities")
+		 (:file "backtrace")
+		 (:file "map-backtrace")
+		 (:file "fallback" :depends-on ("backtrace" "map-backtrace")))))
+  :in-order-to ((test-op (load-op trivial-backtrace-test)))
+  :perform (test-op :after (op c)
+		    (funcall
+		     (intern (symbol-name '#:run-tests) :lift)
+		     :config :generic)))
+
+(defmethod operation-done-p 
+           ((o test-op)
+            (c (eql (find-system 'trivial-backtrace))))
+  (values nil))

data/lib/clucumber/vendor/usocket/backend/allegro.lisp

@@ -0,0 +1,199 @@
+;;;; $Id: allegro.lisp 515 2010-01-07 18:26:06Z ctian $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/trunk/backend/allegro.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :sock)
+  ;; for wait-for-input:
+  (require :process)
+  ;; note: the line below requires ACL 6.2+
+  (require :osi))
+
+(defun get-host-name ()
+  ;; note: the line below requires ACL 7.0+ to actually *work* on windows
+  (excl.osi:gethostname))
+
+(defparameter +allegro-identifier-error-map+
+  '((:address-in-use . address-in-use-error)
+    (:address-not-available . address-not-available-error)
+    (:network-down . network-down-error)
+    (:network-reset . network-reset-error)
+    (:network-unreachable . network-unreachable-error)
+    (:connection-aborted . connection-aborted-error)
+    (:connection-reset . connection-reset-error)
+    (:no-buffer-space . no-buffers-error)
+    (:shutdown . shutdown-error)
+    (:connection-timed-out . timeout-error)
+    (:connection-refused . connection-refused-error)
+    (:host-down . host-down-error)
+    (:host-unreachable . host-unreachable-error)))
+
+(defun handle-condition (condition &optional (socket nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    (excl:socket-error
+     (let ((usock-err
+            (cdr (assoc (excl:stream-error-identifier condition)
+                        +allegro-identifier-error-map+))))
+       (if usock-err
+           (error usock-err :socket socket)
+         (error 'unknown-error
+                :real-error condition
+                :socket socket))))))
+
+(defun to-format (element-type)
+  (if (subtypep element-type 'character)
+      :text
+    :binary))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+                       timeout deadline
+                       (nodelay t) ;; nodelay == t is the ACL default
+                       local-host local-port)
+  (when timeout (unsupported 'timeout 'socket-connect))
+  (when deadline (unsupported 'deadline 'socket-connect))
+
+  (let ((socket))
+    (setf socket
+          (with-mapped-conditions (socket)
+            (ecase protocol
+              (:stream
+	       (labels ((make-socket ()
+			  (socket:make-socket :remote-host (host-to-hostname host)
+					      :remote-port port
+					      :local-host (when local-host
+							    (host-to-hostname local-host))
+					      :local-port local-port
+					      :format (to-format element-type)
+					      :nodelay nodelay)))
+		 (if timeout
+		     (mp:with-timeout (timeout nil)
+		       (make-socket))
+		     (make-socket))))
+              (:datagram
+	       (apply #'socket:make-socket
+		      (nconc (list :type protocol
+				   :address-family :internet
+				   :local-host (when local-host
+						 (host-to-hostname local-host))
+				   :local-port local-port
+				   :format (to-format element-type))
+			     (if (and host port)
+				 (list :connect :active
+				       :remote-host (host-to-hostname host)
+				       :remote-port port)
+				 (list :connect :passive))))))))
+    (ecase protocol
+      (:stream
+       (make-stream-socket :socket socket :stream socket))
+      (:datagram
+       (make-datagram-socket socket)))))
+
+;; One socket close method is sufficient,
+;; because socket-streams are also sockets.
+(defmethod socket-close ((usocket usocket))
+  "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
+  (with-mapped-conditions (usocket)
+    (close (socket usocket))))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'character))
+  ;; Allegro and OpenMCL socket interfaces bear very strong resemblence
+  ;; whatever you change here, change it also for OpenMCL
+  (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+         (sock (with-mapped-conditions ()
+                 (apply #'socket:make-socket
+                        (append (list :connect :passive
+                                      :reuse-address reuseaddress
+                                      :local-port port
+                                      :backlog backlog
+                                      :format (to-format element-type)
+                                      ;; allegro now ignores :format
+                                      )
+                                (when (ip/= host *wildcard-host*)
+                                  (list :local-host host)))))))
+    (make-stream-server-socket sock :element-type element-type)))
+
+(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
+  (declare (ignore element-type)) ;; allegro streams are multivalent
+  (let ((stream-sock
+         (with-mapped-conditions (socket)
+            (socket:accept-connection (socket socket)))))
+    (make-stream-socket :socket stream-sock :stream stream-sock)))
+
+(defmethod get-local-address ((usocket usocket))
+  (hbo-to-vector-quad (socket:local-host (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (hbo-to-vector-quad (socket:remote-host (socket usocket))))
+
+(defmethod get-local-port ((usocket usocket))
+  (socket:local-port (socket usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (socket:remote-port (socket usocket)))
+
+(defmethod get-local-name ((usocket usocket))
+  (values (get-local-address usocket)
+          (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+  (values (get-peer-address usocket)
+          (get-peer-port usocket)))
+
+(defmethod socket-send ((socket datagram-usocket) buffer length &key host port)
+  (with-mapped-conditions (socket)
+    (let ((s (socket socket)))
+      (socket:send-to s buffer length :remote-host host :remote-port port))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+  (with-mapped-conditions (socket)
+    (let ((s (socket socket)))
+      (socket:receive-from s length :buffer buffer :extract t))))
+
+(defun get-host-by-address (address)
+  (with-mapped-conditions ()
+    (socket:ipaddr-to-hostname (host-to-hbo address))))
+
+(defun get-hosts-by-name (name)
+  ;;###FIXME: ACL has the acldns module which returns all A records
+  ;; only problem: it doesn't fall back to tcp (from udp) if the returned
+  ;; structure is too long.
+  (with-mapped-conditions ()
+    (list (hbo-to-vector-quad (socket:lookup-hostname
+                               (host-to-hostname name))))))
+
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (push (socket waiter) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait wait-list))))
+
+(defun wait-for-input-internal (wait-list &key timeout)
+  (with-mapped-conditions ()
+    (let ((active-internal-sockets
+           (if timeout
+               (mp:wait-for-input-available (wait-list-%wait wait-list)
+                                            :timeout timeout)
+             (mp:wait-for-input-available (wait-list-%wait wait-list)))))
+      ;; this is quadratic, but hey, the active-internal-sockets
+      ;; list is very short and it's only quadratic in the length of that one.
+      ;; When I have more time I could recode it to something of linear
+      ;; complexity.
+      ;; [Same code is also used in openmcl.lisp]
+      (dolist (x active-internal-sockets)
+        (setf (state (gethash x (wait-list-map wait-list)))
+              :READ))
+      wait-list)))