March 2007 - cl-darcs-cvs@lists.common-lisp.net

[Cl-darcs-cvs] r107 - cl-darcs/trunk
by mhenoch＠common-lisp.net 11 Mar '07

11 Mar '07

Author: mhenoch Date: Sat Mar 10 22:10:57 2007 New Revision: 107 Modified: cl-darcs/trunk/util.lisp Log: Fix EOF handling of READ-BINARY-LINE Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Sat Mar 10 22:10:57 2007 @@ -96,10 +96,15 @@ Return a vector of binary values. Return EOF-VALUE if EOF-ERROR-P is nil and end-of-file occurs before any data is read." (multiple-value-bind (line delim) - (read-until 10 stream eof-error-p eof-value) - (if (or (not (zerop (length line))) (eql delim 10)) - line - delim))) + (read-until 10 stream nil :eof) + (cond + ;; nothing read, and we've reached the end + ((and (zerop (length line)) (eq delim :eof)) + (if eof-error-p + (error 'end-of-file :stream stream) + eof-value)) + (t + line)))) (defun read-token (stream) "Read and return a whitespace-separated token from STREAM.

1 0

[Cl-darcs-cvs] r106 - cl-darcs/trunk
by mhenoch＠common-lisp.net 10 Mar '07

10 Mar '07

Author: mhenoch Date: Sat Mar 10 18:04:14 2007 New Revision: 106 Modified: cl-darcs/trunk/pull.lisp cl-darcs/trunk/record.lisp Log: Make PULL conditionally interactive. SELECT-PATCHES now takes a predicate as second argument. Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Sat Mar 10 18:04:14 2007 @@ -16,10 +16,16 @@ (in-package :darcs) -(defun pull (ourrepo &optional theirrepo) +(defun pull (ourrepo &optional theirrepo &key (select-patches :ask)) "Pull new patches from THEIRREPO into OURREPO. If THEIRREPO is not specified, use default repositiory specified -in preferences." +in preferences. +SELECT-PATCHES specifies how to select which remote patches to pull. +It can be one of: +:ALL - pull all patches +:ASK - ask for each patch through Y-OR-N-P +a function - call this function with a NAMED-PATCH object, and + pull if it returns true" (setf ourrepo (fad:pathname-as-directory ourrepo)) (unless theirrepo (setf theirrepo (car (get-preflist ourrepo "defaultrepo"))) @@ -42,9 +48,16 @@ (read-patch-from-repo theirrepo patchinfo)) only-theirs)) (their-patches - (if (y-or-n-p "Pull all patches?") + (if (or (eq select-patches :all) + (and (eq select-patches :ask) + (y-or-n-p "Pull all patches?"))) all-their-patches - (select-patches all-their-patches))) + (select-patches all-their-patches + (if (functionp select-patches) + select-patches + (lambda (patch) + (display-patch patch *query-io*) + (y-or-n-p "Pull patch ~A? " patch)))))) (our-patches (mapcar (lambda (patchinfo) (read-patch-from-repo ourrepo patchinfo)) Modified: cl-darcs/trunk/record.lisp ============================================================================== --- cl-darcs/trunk/record.lisp (original) +++ cl-darcs/trunk/record.lisp Sat Mar 10 18:04:14 2007 @@ -49,20 +49,22 @@ "Record changes in REPO. Arguments as to `record-patches'." (let ((patches (diff-repo repo))) - (unless patches - (error "Nothing to record.")) + (flet ((ask (patch) + (display-patch patch *query-io*) + (y-or-n-p "Record patch ~A? " patch))) + (unless patches + (error "Nothing to record.")) - (record-patches repo name author date log (select-patches patches)))) + (record-patches repo name author date log (select-patches patches #'ask))))) -(defun select-patches (patches) - "Ask the user to select some of PATCHES. +(defun select-patches (patches predicate) + "Select some of PATCHES using PREDICATE. Do the necessary commutation and dependency elimination." (let (patches-to-record) (loop while (setf patches (remove nil patches)) do ;; Should we include this patch? - (display-patch (car patches) *query-io*) - (if (y-or-n-p "Record patch ~A?" (car patches)) + (if (funcall predicate (car patches)) (progn ;; Yes, just add it to the list and go on. (push (car patches) patches-to-record)

1 0

[Cl-darcs-cvs] r105 - cl-darcs/trunk
by mhenoch＠common-lisp.net 10 Mar '07

10 Mar '07

Author: mhenoch Date: Sat Mar 10 16:18:44 2007 New Revision: 105 Modified: cl-darcs/trunk/util.lisp Log: Implement DELETE-DIR for Lispworks Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Sat Mar 10 16:18:44 2007 @@ -247,7 +247,8 @@ "Delete directory PATHNAME." #+clisp (ext:delete-dir pathname) #+sbcl (sb-posix:rmdir pathname) - #-(or clisp sbcl) + #+lispworks (lw:delete-directory pathname) + #-(or clisp sbcl lispworks) (error "DELETE-DIR not implemented for ~A." (lisp-implementation-type))) (defun copy-directory (source target &key excluding)

1 0

[Cl-darcs-cvs] r104 - cl-darcs/trunk
by mhenoch＠common-lisp.net 10 Mar '07

10 Mar '07

Author: mhenoch Date: Sat Mar 10 16:18:07 2007 New Revision: 104 Modified: cl-darcs/trunk/util.lisp Log: Use ENSURE-DIRECTORIES-EXIST in MAKE-DIR Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Sat Mar 10 16:18:07 2007 @@ -238,10 +238,10 @@ (defun make-dir (pathname) "Create directory PATHNAME." (with-simple-restart (ignore-error "Ignore ~A directory creation error." pathname) - #+clisp (ext:make-dir pathname) - #+sbcl (sb-posix:mkdir pathname #o777) - #-(or clisp sbcl) - (error "MAKE-DIR not implemented for ~A." (lisp-implementation-type)))) + (multiple-value-bind (path created) (ensure-directories-exist pathname) + (declare (ignore path)) + (unless created + (error "Directory ~A already exists." pathname))))) (defun delete-dir (pathname) "Delete directory PATHNAME."

1 0

[Cl-darcs-cvs] r103 - cl-darcs/trunk
by mhenoch＠common-lisp.net 10 Mar '07

10 Mar '07

Author: mhenoch Date: Sat Mar 10 16:13:10 2007 New Revision: 103 Modified: cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/upath.lisp Log: Use Drakma instead of Aserve Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Sat Mar 10 16:13:10 2007 @@ -12,7 +12,7 @@ :author "Magnus Henoch <henoch(a)dtek.chalmers.se>" :depends-on (:split-sequence ;; HTTP client - :aserve + :drakma :puri :trivial-gray-streams ;; SHA1, hex etc :ironclad Modified: cl-darcs/trunk/upath.lisp ============================================================================== --- cl-darcs/trunk/upath.lisp (original) +++ cl-darcs/trunk/upath.lisp Sat Mar 10 16:13:10 2007 @@ -72,77 +72,9 @@ (ctypecase upath (net.uri:uri (dformat "~&Opening ~A..." upath) - (let ((client-request (net.aserve.client:make-http-client-request upath :proxy *http-proxy*))) - (net.aserve.client:read-client-response-headers client-request) - (let ((code (net.aserve.client:client-request-response-code client-request))) - (cond - ((= code 200) - (make-instance (if binary 'http-byte-input-stream 'http-char-input-stream) - :client-request client-request)) - ((and (> redirect-max-depth 0) (member code '(301 302 303 307))) - (let ((new-location (cdr (assoc :location (net.aserve.client:client-request-headers client-request))))) - (dformat "~&Redirected to ~A." new-location) - (net.aserve.client:client-request-close client-request) - (open-upath - (net.uri:uri new-location) - :redirect-max-depth (1- redirect-max-depth) :binary binary))) - (t - (error "Couldn't read ~A: ~A ~A." - upath - (net.aserve.client:client-request-response-code client-request) - (net.aserve.client:client-request-response-comment client-request))))))) + (apply #'drakma:http-request upath :redirect redirect-max-depth + :want-stream t (when *http-proxy* `(:proxy ,*http-proxy*)))) (pathname (open upath :direction :input :if-does-not-exist :error :element-type (if binary '(unsigned-byte 8) 'character))))) - - -(defclass http-input-stream (trivial-gray-streams:trivial-gray-stream-mixin - trivial-gray-streams:fundamental-input-stream) - ((client-request :initarg :client-request) - (binary) - (unread :initform nil)) - (:documentation "A Gray stream wrapping an Allegroserve HTTP request.")) - -(defclass http-char-input-stream (http-input-stream - trivial-gray-streams:fundamental-character-input-stream) - ((binary :initform nil)) - (:documentation "An HTTP input stream for characters.")) - -(defclass http-byte-input-stream (http-input-stream - trivial-gray-streams:fundamental-binary-input-stream) - ((binary :initform t)) - (:documentation "An HTTP input stream for bytes.")) - -(defmethod trivial-gray-streams:stream-read-sequence - ((stream http-input-stream) sequence start end &key &allow-other-keys) - (if (slot-value stream 'binary) - (net.aserve.client:client-request-read-sequence - sequence (slot-value stream 'client-request)) - (let* ((buffer (make-array (- end start) :element-type '(unsigned-byte 8))) - (len (net.aserve.client:client-request-read-sequence - buffer (slot-value stream 'client-request)))) - (loop for i from 0 below len - do (setf (elt sequence (+ i start)) (aref buffer i))) - len))) - -(defmethod trivial-gray-streams:stream-read-byte ((stream http-input-stream)) - (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)))) - (if (= 1 (trivial-gray-streams:stream-read-sequence stream buffer 0 1)) - (aref buffer 0) - :eof))) - -(defmethod trivial-gray-streams:stream-read-char ((stream http-input-stream)) - (or (pop (slot-value stream 'unread)) - (let ((byte (trivial-gray-streams:stream-read-byte stream))) - (if (eql byte :eof) byte (code-char byte))))) - -(defmethod trivial-gray-streams:stream-unread-char ((stream http-input-stream) char) - (push char (slot-value stream 'unread))) - -(defmethod stream-element-type ((stream http-input-stream)) - (if (slot-value stream 'binary) '(unsigned-byte 8) 'character)) - -(defmethod close ((stream http-input-stream) &key &allow-other-keys) - (net.aserve.client:client-request-close (slot-value stream 'client-request)) - (call-next-method))

1 0

[Cl-darcs-cvs] r102 - cl-darcs/trunk
by mhenoch＠common-lisp.net 10 Mar '07

10 Mar '07

Author: mhenoch Date: Sat Mar 10 15:39:19 2007 New Revision: 102 Modified: cl-darcs/trunk/util.lisp Log: Fix off-by-ten error in HEX-TO-NUMBER Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Sat Mar 10 15:39:19 2007 @@ -47,9 +47,9 @@ ((<= (char-code #\0) c (char-code #\9)) (- c (char-code #\0))) ((<= (char-code #\A) c (char-code #\F)) - (- c (char-code #\A))) + (+ 10 (- c (char-code #\A)))) ((<= (char-code #\a) c (char-code #\f)) - (- c (char-code #\a))) + (+ 10 (- c (char-code #\a)))) (t (error "Invalid hex digit ~A." c))))

1 0