clucumber 0.1.1 → 0.2.0

data/lib/clucumber/vendor/usocket/vendor/kqueue.lisp

@@ -0,0 +1 @@
+;;;-*-Mode: LISP; Package: CCL -*-
 combining hw.cpu64bit_capable, hw.optional.x86_64 and hw.optional.64bitops
  ;; FRAMWORK CALL FUNCTIONALITY FROM BSD.LISP
  ;; (C) 2003 Brendan Burns <bburns@cs.umass.edu>
  ;; Released under LGPL.
  (with-cfstrs ((framework framework-name))
    (let ((err 0)
          (baseURL nil)
          (bundleURL nil)
          (result nil))
      (rlet ((folder :fsref))
        ;; Find the folder holding the bundle
        (setf err (#_FSFindFolder #$kOnAppropriateDisk #$kFrameworksFolderType 
                   t folder))
        
        ;; if everything's cool, make a URL for it
        (when (zerop err)
          (setf baseURL (#_CFURLCreateFromFSRef (%null-ptr) folder))
          (if (%null-ptr-p baseURL) 
            (setf err #$coreFoundationUnknownErr)))
        
        ;; if everything's cool, make a URL for the bundle
        (when (zerop err)
          (setf bundleURL (#_CFURLCreateCopyAppendingPathComponent (%null-ptr) 
                           baseURL framework nil))
          (if (%null-ptr-p bundleURL) 
            (setf err #$coreFoundationUnknownErr)))
        
        ;; if everything's cool, load it
        (when (zerop err)
          (setf result (#_CFBundleCreate (%null-ptr) bundleURL))
          (if (%null-ptr-p result)
            (setf err #$coreFoundationUnknownErr)))
        
        ;; if everything's cool, and the user wants it loaded, load it
        (when (and load-executable (zerop err))
          (if (not (#_CFBundleLoadExecutable result))
            (setf err #$coreFoundationUnknownErr)))
        
        ;; if there's an error, but we've got a pointer, free it and clear result
        (when (and (not (zerop err)) (not (%null-ptr-p result)))
          (#_CFRelease result)
          (setf result nil))
        
        ;; free the URLs if there non-null
        (when (not (%null-ptr-p bundleURL))
          (#_CFRelease bundleURL))
        (when (not (%null-ptr-p baseURL))
          (#_CFRelease baseURL))
        
        ;; return pointer + error value
        (values result err)))))
  (let* ((addr (#_CFBundleGetFunctionPointerForName bundle name)))
    (rlet ((buf :long))
      (setf (%get-ptr buf) addr)
      (ash (%get-signed-long buf) -2))))
  (with-cfstrs ((str name))
    (let* ((addr (#_CFBundleGetFunctionPointerForName bundle str)))
      (if (%null-ptr-p addr)
        (unless nil-if-not-found
          (error "Couldn't resolve address of foreign function ~s" name))
        (rlet ((buf :long)) ;; mcl 5.2 uses %fixnum-from-macptr here
          (setf (%get-ptr buf) addr)
          (ash (%get-signed-long buf) -2))))))
  #+ccl-5.2 (get-bundle-for-framework-name "System.framework")
  #-ccl-5.2
  (let ((bundle (load-framework-bundle "System.framework")))
    (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))
    bundle))
  ;; Is there an existing define-trap like macro for this? or could one be modified for use with bundles?
  `(progn
     (defloadvar ,fn
       (let* ((bundle #+ccl-5.2 (get-bundle-for-framework-name "System.framework")
                      #-ccl-5.2
                      (let ((bundle (load-framework-bundle "System.framework")))
                        (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))
                        bundle)))
         (lookup-function-in-bundle ,name-string bundle)))
     ,(let ((args (do ((arglist arglist (cddr arglist))
                      (result))
                     ((not (cdr arglist)) (nreverse result))
                   (push (second arglist) result))))        
       `(defun ,name ,args
          (ppc-ff-call ,fn ,@arglist)))))
                   :signed-fullword) ;; returns a file descriptor no!
  (let ((kq (%system-kqueue)))
    (if (= kq -1)
      (ecase (%system-errno)
        (12 (error "The kernel failed to allocate enough memory for the kernel queue")) ; ENOMEM
        (24 (error "The per-process descriptor table is full")) ; EMFILE
        (23 (error "The system file table is full"))) ; ENFILE 
      kq)))
                  :unsigned-fullword kq
                  :address ke
                  :unsigned-fullword nke
                  :address ko
                  :unsigned-fullword nko
                  :address timeout
                  :signed-fullword)
                   :address name 
                   :unsigned-fullword mode
                   :unsigned-fullword arg 
                   :signed-fullword)
 
                   :unsigned-fullword fd 
                   :signed-fullword)
                   :signed-fullword)
                   :signed-fullword errno
                   :address)
  (%get-fixnum (%int-to-ptr (%system-errno*))))
  "Low level open function, as in C, returns an fd number"
  (with-cstrs ((name posix-namestring))
    (%system-open name $O-EVTONLY 0)))
  (%system-close fd))
  (sec :unsigned-long)
  (usec :unsigned-long))
  (setf *kevent-record*
       (if (ccl::gestalt #$gestaltPowerPCProcessorFeatures
                        #+ccl-5.2 #$gestaltPowerPCHas64BitSupport #-ccl-5.2 6)
          :kevent32
          :kevent64)))
  (ident :unsigned-long) ; uintptr_t
  (filter :short)
  (flags :unsigned-short)
  (fflags :unsigned-long)
  (data :long)  ; intptr_t
  (udata :pointer))
  (:variant ; uintptr_t
   ((ident64 :uint64))
   ((ident :unsigned-long)))
  (filter :short)
  (flags :unsigned-short)
  (fflags :unsigned-long)
  (:variant  ; intptr_t
   ((data64 :sint64))
   ((data :long)))
  (:variant ; RMCL :pointer is 32bit
   ((udata64 :uint64))
   ((udata :pointer))))
   (ecase *kevent-record*
      (:kevent64   
       (make-record kevent64
                    :ident ident
                    :filter filter 
                    :flags flags
                    :fflags fflags
                    :data data 
                    :udata udata))
      (:kevent32
       (make-record kevent32
                    :ident ident
                    :filter filter 
                    :flags flags
                    :fflags fflags
                    :data data 
                    :udata udata))))
   (ecase *kevent-record*
      (:kevent32
       (ecase field
          (:ident (rref ke :kevent32.ident))
          (:filter (rref ke :kevent32.filter))
          (:flags (rref ke :kevent32.flags))
          (:fflags (rref ke :kevent32.fflags))
          (:data (rref ke :kevent32.data))
          (:udata (rref ke :kevent32.udata))))
      (:kevent64
       (ecase field
          (:ident (rref ke :kevent64.ident))
          (:filter (rref ke :kevent64.filter))
          (:flags (rref ke :kevent64.flags))
          (:fflags (rref ke :kevent64.fflags))
          (:data (rref ke :kevent64.data))
          (:udata (rref ke :kevent64.udata))))))
   (kevent-rref ke :filter))
   (kevent-rref ke :flags))
   (kevent-rref ke :data))
                                      $kevent-file-attrib $kevent-file-link $kevent-file-rename $kevent-file-revoke))
  ((errno :initform NIL :initarg :errno)
   (ko :initform nil :type (or null kevent) :initarg :ko)
   (syserr :initform (%system-errno)))
  (:report 
   (lambda (c s)
     (with-slots (errno ko syserr) c
       (format s "kevent system call error ~A [~A]" errno syserr) 
       (when errno 
          (format s "(~A)" (%get-cstring (%system-strerror errno))))
       (when ko
          (format s " for ")
          (let ((*standard-output* s))
            (print-record ko *kevent-record*)))))))
  (check-type kq integer)
  (rlet ((&timeout :timespec :sec timeout :usec 1))
    (let ((num (with-timer ;; does not seem to make a difference...  
                 (%system-kevent kq (or ke (%null-ptr))(if ke 1 0)(or ko (%null-ptr))(if ko 1 0) &timeout))))
      ; "If an error occurs while processing an element of the changelist and there 
      ; is enough room in the eventlist, then the event will be placed in the eventlist with 
      ; EV_ERROR set in flags and the system error in data."
      (when (and ko (plusp (logand $kevent-error (kevent-flags ko))))
        (error 'kevent-error 
                              :errno (kevent-data ko)
               :ko ko))
      ; "Otherwise, -1 will be returned, and errno will be set to indicate the error condition."
      (when (= num -1)
        ;; hack - opentransport provides the constants for the errors documented for the call 
        (case (%system-errno)
          (0 (error "kevent system call failed with an unspecified error")) ;; should not happen!
          (13 (error "The process does not have permission to register a filter")) 
          (14 (error "There was an error reading or writing the kevent structure"))  ; EFAULT
          (9 (error "The specified descriptor is invalid")) ; EBADF
          (4 (error "A signal was delivered before the timeout expired and before any events were placed on the kqueue for return.")) ; EINTR
          (22 (error "The specified time limit or filter is invalid")) ; EINVAL
          (2 (error "The event could not be found to be modified or deleted")) ; ENOENT
          (12 (error "No memory was available to register the event")) ; ENOMEM
          (78 (error "The specified process to attach to does not exist"))) ; ESRCH
        ;; shouldn't get here... 
        (errchk (%system-errno))
        (error "error ~A" (%system-errno)))
      (unless (zerop num)
         (values ko num)))))
  ((kq :initform (system-kqueue) 
       :documentation "file descriptor referencing the kqueue")
   (fds :initform NIL)) ;; ## better if kept on top level, perhaps as a hash table...
  (:documentation "A kernal event notification channel"))
  (declare (ignore rest))
  (terminate-when-unreachable q 'kqueue-close))
  (with-slots (kq fds) q
    (when (or kq fds) ;; allow repeated close
      (system-close kq)
      (setf fds NIL)
      (setf kq NIL))))
  "Polls a kqueue for kevents"
  ;; may not have to be cleared, but just in case:
  (flet ((kqueue-poll2 (ko)
           (let ((result (with-slots (kq) q
                            (without-interrupts 
                             (%kevent kq NIL ko)))))
             (when result
                (let ((type  (kevent-filter result)))
                  (ecase type
                     (0 (values))
                     (#.$kevent-read-filter
                          (values
                           :read
                           (kevent-rref result :ident)
                           (kevent-rref result :flags)
                           (kevent-rref result :fflags)
                           (kevent-rref result :data)
                           (kevent-rref result :udata)))
                      (#.$kevent-write-filter :write)
                      (#.$kevent-aio-filter :aio)
                      (#.$kevent-vnode-filter
                           (values
                            :vnode
                            (cdr (assoc (kevent-rref result :ident) (slot-value q 'fds)))
                            (kevent-rref result :flags)
                            (kevent-rref result :fflags)
                            (kevent-rref result :data)
                            (kevent-rref result :udata)))
                      (#.$kevent-filesystem-filter :filesystem)))))))
    (ecase *kevent-record*
       (:kevent64
        (rlet ((ko :kevent64 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))
          (kqueue-poll2 ko)))
       (:kevent32
        (rlet ((ko :kevent32 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))
          (kqueue-poll2 ko))))))
  (let ((ke (make-kevent :ident ident
                         :filter filter 
                         :flags flags
                         :fflags fflags
                         :data data 
                         :udata udata)))
    (with-slots (kq) q
       (without-interrupts
        (%kevent kq ke)))))
  "Makes the queue report an event when there is a change to a directory or file" 
  (let* ((namestring (posix-namestring (full-pathname pathname)))
         (fd (system-open namestring)))
    (with-slots (fds) q
      (push (cons fd pathname) fds))
    (kqueue-subscribe q 
                      :ident fd 
                      :filter $kevent-vnode-filter 
                      :flags (logior $kevent-add $kevent-clear) 
                      :fflags $kevent-file-all)
    namestring))
  "Report changes to a file or directory"
  (loop
    with kqueue = (make-instance 'kqueue)
    with sub = (kqueue-vnode-subscribe kqueue pathname) 
    for i from 1 to 60
    for result = (multiple-value-list (kqueue-poll kqueue))
    unless (equal result '(NIL))
    do (progn
         (format T "~A~%" result)
         (force-output))
    ; do (process-allow-schedule)
    do (sleep 1)
    finally (write-line "Done")
    ))
                      (fred))
                      (make-pathname :directory (pathname-directory *loading-file-source-file*))
                      (fred))

data/lib/clucumber/vendor/usocket/vendor/split-sequence.lisp

@@ -0,0 +1,245 @@
+;;;; SPLIT-SEQUENCE
+;;;
+;;; This code was based on Arthur Lemmens' in
+;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
+;;;
+;;; changes include:
+;;;
+;;; * altering the behaviour of the :from-end keyword argument to
+;;; return the subsequences in original order, for consistency with
+;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
+;;; affects the answer if :count is less than the number of
+;;; subsequences, by analogy with the above-referenced functions).
+;;;   
+;;; * changing the :maximum keyword argument to :count, by analogy
+;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
+;;;
+;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
+;;; than SPLIT.
+;;;
+;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
+;;;
+;;; * The second return value is now an index rather than a copy of a
+;;; portion of the sequence; this index is the `right' one to feed to
+;;; CL:SUBSEQ for continued processing.
+
+;;; There's a certain amount of code duplication here, which is kept
+;;; to illustrate the relationship between the SPLIT-SEQUENCE
+;;; functions and the CL:POSITION functions.
+
+;;; Examples:
+;;;
+;;; * (split-sequence #\; "a;;b;c")
+;;; -> ("a" "" "b" "c"), 6
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t)
+;;; -> ("a" "" "b" "c"), 0
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1)
+;;; -> ("c"), 4
+;;;
+;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
+;;; -> ("a" "b" "c"), 6
+;;;
+;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("" "" "r" "c" "d" "" "r" ""), 11
+;;;
+;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("ab" "a" "a" "ab" "a"), 11 
+;;;
+;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
+;;; -> ("oo" "bar" "b"), 9
+
+#+ignore ; comment by usocket
+(defpackage "SPLIT-SEQUENCE"
+  (:use "CL")
+  (:nicknames "PARTITION")
+  (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT"
+	   "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT"))
+
+(in-package :usocket #+ignore "SPLIT-SEQUENCE")
+
+(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
+  "Return a list of subsequences in seq delimited by delimiter.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded.  All other keywords
+work analogously to those for CL:SUBSTITUTE.  In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+  (let ((len (length seq))
+        (other-keys (nconc (when test-supplied 
+                             (list :test test))
+                           (when test-not-supplied 
+                             (list :test-not test-not))
+                           (when key-supplied 
+                             (list :key key)))))
+    (unless end (setq end len))
+    (if from-end
+        (loop for right = end then left
+              for left = (max (or (apply #'position delimiter seq 
+					 :end right
+					 :from-end t
+					 other-keys)
+				  -1)
+			      (1- start))
+              unless (and (= right (1+ left))
+                          remove-empty-subseqs) ; empty subseq we don't want
+              if (and count (>= nr-elts count))
+              ;; We can't take any more. Return now.
+              return (values (nreverse subseqs) right)
+              else 
+              collect (subseq seq (1+ left) right) into subseqs
+              and sum 1 into nr-elts
+              until (< left start)
+              finally (return (values (nreverse subseqs) (1+ left))))
+      (loop for left = start then (+ right 1)
+            for right = (min (or (apply #'position delimiter seq 
+					:start left
+					other-keys)
+				 len)
+			     end)
+            unless (and (= right left) 
+                        remove-empty-subseqs) ; empty subseq we don't want
+            if (and count (>= nr-elts count))
+            ;; We can't take any more. Return now.
+            return (values subseqs left)
+            else
+            collect (subseq seq left right) into subseqs
+            and sum 1 into nr-elts
+            until (>= right end)
+            finally (return (values subseqs right))))))
+
+(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+  "Return a list of subsequences in seq delimited by items satisfying
+predicate.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded.  All other keywords
+work analogously to those for CL:SUBSTITUTE-IF.  In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+  (let ((len (length seq))
+        (other-keys (when key-supplied 
+		      (list :key key))))
+    (unless end (setq end len))
+    (if from-end
+        (loop for right = end then left
+              for left = (max (or (apply #'position-if predicate seq 
+					 :end right
+					 :from-end t
+					 other-keys)
+				  -1)
+			      (1- start))
+              unless (and (= right (1+ left))
+                          remove-empty-subseqs) ; empty subseq we don't want
+              if (and count (>= nr-elts count))
+              ;; We can't take any more. Return now.
+              return (values (nreverse subseqs) right)
+              else 
+              collect (subseq seq (1+ left) right) into subseqs
+              and sum 1 into nr-elts
+              until (< left start)
+              finally (return (values (nreverse subseqs) (1+ left))))
+      (loop for left = start then (+ right 1)
+            for right = (min (or (apply #'position-if predicate seq 
+					:start left
+					other-keys)
+				 len)
+			     end)
+            unless (and (= right left) 
+                        remove-empty-subseqs) ; empty subseq we don't want
+            if (and count (>= nr-elts count))
+            ;; We can't take any more. Return now.
+            return (values subseqs left)
+            else
+            collect (subseq seq left right) into subseqs
+            and sum 1 into nr-elts
+            until (>= right end)
+            finally (return (values subseqs right))))))
+
+(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+  "Return a list of subsequences in seq delimited by items satisfying
+(CL:COMPLEMENT predicate).
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded.  All other keywords
+work analogously to those for CL:SUBSTITUTE-IF-NOT.  In particular,
+the behaviour of :from-end is possibly different from other versions
+of this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+  (let ((len (length seq))
+	(other-keys (when key-supplied 
+		      (list :key key))))
+    (unless end (setq end len))
+    (if from-end
+        (loop for right = end then left
+              for left = (max (or (apply #'position-if-not predicate seq 
+					 :end right
+					 :from-end t
+					 other-keys)
+				  -1)
+			      (1- start))
+              unless (and (= right (1+ left))
+                          remove-empty-subseqs) ; empty subseq we don't want
+              if (and count (>= nr-elts count))
+              ;; We can't take any more. Return now.
+              return (values (nreverse subseqs) right)
+              else 
+              collect (subseq seq (1+ left) right) into subseqs
+              and sum 1 into nr-elts
+              until (< left start)
+              finally (return (values (nreverse subseqs) (1+ left))))
+      (loop for left = start then (+ right 1)
+            for right = (min (or (apply #'position-if-not predicate seq 
+					:start left
+					other-keys)
+				 len)
+			     end)
+            unless (and (= right left) 
+                        remove-empty-subseqs) ; empty subseq we don't want
+            if (and count (>= nr-elts count))
+            ;; We can't take any more. Return now.
+            return (values subseqs left)
+            else
+            collect (subseq seq left right) into subseqs
+            and sum 1 into nr-elts
+            until (>= right end)
+            finally (return (values subseqs right))))))
+
+;;; clean deprecation
+
+(defun partition (&rest args)
+  (apply #'split-sequence args))
+
+(defun partition-if (&rest args)
+  (apply #'split-sequence-if args))
+
+(defun partition-if-not (&rest args)
+  (apply #'split-sequence-if-not args))
+
+(define-compiler-macro partition (&whole form &rest args)
+  (declare (ignore args))
+  (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.")
+  form)
+
+(define-compiler-macro partition-if (&whole form &rest args)
+  (declare (ignore args))
+  (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.")
+  form)
+
+(define-compiler-macro partition-if-not (&whole form &rest args)
+  (declare (ignore args))
+  (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead")
+  form)
+
+#+ignore ; comment by usocket
+(pushnew :split-sequence *features*)

data/lib/clucumber.rb

@@ -6,25 +6,39 @@ class ClucumberSubprocess
   
   attr_reader :output
 
+  def self.launch(dir, options={})
+    proc = ClucumberSubprocess.new(dir, options)
+    at_exit do
+      proc.kill
+    end
+    proc.run
+    proc
+  end
+  
   def initialize(dir, options={})
     @dir = dir
-    lisp = options[:lisp] || ENV['LISP'] || 'sbcl --disable-debugger'
+    @lisp = options[:lisp] || ENV['LISP'] || 'sbcl --disable-debugger'
     @port = options[:port] || raise("Need a port to run clucumber on.")
     @output = ""
-    
+  end
+
+  def run
     Dir.chdir(@dir) do
-      @out, @in, @pid = PTY.spawn(lisp)
+      @out, @in, @pid = PTY.spawn(@lisp)
     end
     @reader = Thread.start {
       record_output
-    }
+    } 
+    cluke_dir = File.expand_path("clucumber/", File.dirname(__FILE__))
+    Dir[cluke_dir + '/**/*.fasl'].each do |fasl|
+      FileUtils.rm(fasl)
+    end
     @in.puts(<<-LISP)
-      (require :asdf)
-      (load #p"#{File.expand_path("clucumber/clucumber.asd", File.dirname(__FILE__))}")
+      (load #p"#{File.expand_path("clucumber/clucumber-bootstrap.lisp", File.dirname(__FILE__))}")
     LISP
   end
   
-  def start(additional_forms="")
+  def listen(additional_forms="")
     @in.puts <<-LISP
       #{additional_forms}
       (asdf:oos 'asdf:load-op :clucumber)
@@ -68,4 +82,12 @@ class ClucumberSubprocess
       (Process.kill("CONT", @pid) && true) rescue false
     end
   end
+
+  def vendor_path
+    File.expand_path("../clucumber/vendor/", __FILE__)
+  end
+
+  def vendor_libs
+    Dir[vendor_path + '/*'].map {|dir| File.basename(dir)}
+  end
 end