- cl-darcs-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[Cl-darcs-cvs] r47 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 15:49:24 2006 New Revision: 47 Modified: cl-darcs/trunk/util.lisp Log: Add compress-file function Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Fri Oct 6 15:49:24 2006 @@ -140,6 +140,20 @@ (util.zip:inflate in out) (dformat "done")))))) +(defun compress-file (infile outfile) + "Compress INFILE and write contents to OUTFILE." + (setf infile (make-upath infile)) + (cond + #+clisp + ((pathnamep infile) + (dformat "~&Compressing ~A through external program..." outfile) + (ext:run-program "gzip" :input (namestring infile) :output (namestring outfile) + :if-output-exists :error) + (dformat "done")) + (t + (cerror "Assume compression performed." + "Don't know how to gzip ~A to ~A." infile outfile)))) + (defun make-temp-file-name () "Create a random name for a temporary file. This is hopefully random enough to avoid problems."

1 0

[Cl-darcs-cvs] r46 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 15:20:19 2006 New Revision: 46 Modified: cl-darcs/trunk/write-patch.lisp Log: Use pathname-to-string in write-patch Modified: cl-darcs/trunk/write-patch.lisp ============================================================================== --- cl-darcs/trunk/write-patch.lisp (original) +++ cl-darcs/trunk/write-patch.lisp Fri Oct 6 15:20:19 2006 @@ -50,7 +50,7 @@ (write-as-bytes (concatenate 'string "hunk " - (patch-filename patch) + (pathname-to-string (patch-filename patch)) (format nil " ~A" (hunk-line-number patch))) stream) (write-byte 10 stream) @@ -66,7 +66,7 @@ (defun write-token-and-filename (token filename stream) (write-as-bytes token stream) (write-byte 32 stream) - (write-as-bytes filename stream) + (write-as-bytes (pathname-to-string filename) stream) (write-byte 10 stream)) (defmethod write-patch ((patch add-file-patch) stream) @@ -102,7 +102,7 @@ (defmethod write-patch ((patch token-replace-patch) stream) (write-as-bytes (format nil "replace ~A [~A] ~A ~A" - (patch-filename patch) + (pathname-to-string (patch-filename patch)) (token-regexp patch) (old-token patch) (new-token patch)) @@ -138,8 +138,12 @@ (defmethod write-patch ((patch move-patch) stream) (write-sequence (string-to-bytes "move ") stream) - (write-sequence (string-to-bytes (patch-move-from patch)) stream) + (write-sequence (string-to-bytes + (pathname-to-string (patch-move-from patch))) + stream) (write-byte 32 stream) - (write-sequence (string-to-bytes (patch-move-to patch)) stream) + (write-sequence (string-to-bytes + (pathname-to-string + (patch-move-to patch))) stream) (write-byte 10 stream))

1 0

[Cl-darcs-cvs] r45 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 15:18:24 2006 New Revision: 45 Modified: cl-darcs/trunk/util.lisp Log: Add function pathname-to-string Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Fri Oct 6 15:18:24 2006 @@ -201,6 +201,21 @@ (make-pathname :directory (cons :relative directory) :name filename-without-dot :type type)))))) +(defun pathname-to-string (pathname) + "Convert PATHNAME to a string usable in darcs patch files. +PATHNAME is assumed to be a relative pathname going strictly down, +as returned by SANITIZE-FILENAME." + (apply #'concatenate 'string + "./" + (append + (mapcan (lambda (d) + (list d "/")) + (cdr (pathname-directory pathname))) + (when (pathname-name pathname) + (cons (pathname-name pathname) + (when (pathname-type pathname) + (list "." (pathname-type pathname)))))))) + (defun make-dir (pathname) "Create directory PATHNAME." (with-simple-restart (ignore-error "Ignore ~A directory creation error." pathname)

1 0

[Cl-darcs-cvs] r44 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 14:51:38 2006 New Revision: 44 Modified: cl-darcs/trunk/util.lisp Log: Fix the exclusion feature of copy-directory. Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Fri Oct 6 14:51:38 2006 @@ -223,23 +223,25 @@ to exclude. Symlinks will confuse the function." - (setq excluding (mapcar #'truename excluding)) (let* ((wild (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type :wild :version :wild)) (source-wild (merge-pathnames wild source)) (target-wild (merge-pathnames wild target)) + (excluding-wild (mapcar + (lambda (excluded) (merge-pathnames wild excluded)) + excluding)) (files (fad:list-directory (truename source)))) (dolist (source-file files) (let ((target-file (translate-pathname source-file source-wild target-wild))) (cond - ((member source-file excluding :test #'equal) + ((some (lambda (excluded) (pathname-match-p source-file excluded)) excluding-wild) ;; File excluded - do nothing. ) ((fad:directory-pathname-p source-file) (make-dir target-file) - (copy-directory source-file target-file)) + (copy-directory source-file target-file :excluding excluding)) (t (fad:copy-file source-file target-file)))))))

1 0

[Cl-darcs-cvs] r43 - cl-darcs/trunk
by mhenoch＠common-lisp.net 06 Oct '06

06 Oct '06

Author: mhenoch Date: Fri Oct 6 13:07:36 2006 New Revision: 43 Modified: cl-darcs/trunk/util.lisp Log: Add copy-directory. Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Fri Oct 6 13:07:36 2006 @@ -215,3 +215,31 @@ #+sbcl (sb-posix:rmdir pathname) #-(or clisp sbcl) (error "DELETE-DIR not implemented for ~A." (lisp-implementation-type))) + +(defun copy-directory (source target &key excluding) + "Copy all files and directories in SOURCE to TARGET. +SOURCE and TARGET are pathnames designating directories, both of +which must exist. EXCLUDING is a list of files and directories +to exclude. + +Symlinks will confuse the function." + (setq excluding (mapcar #'truename excluding)) + (let* ((wild (make-pathname :directory '(:relative :wild-inferiors) + :name :wild + :type :wild + :version :wild)) + (source-wild (merge-pathnames wild source)) + (target-wild (merge-pathnames wild target)) + + (files (fad:list-directory (truename source)))) + (dolist (source-file files) + (let ((target-file (translate-pathname source-file source-wild target-wild))) + (cond + ((member source-file excluding :test #'equal) + ;; File excluded - do nothing. + ) + ((fad:directory-pathname-p source-file) + (make-dir target-file) + (copy-directory source-file target-file)) + (t + (fad:copy-file source-file target-file)))))))

1 0

[Cl-darcs-cvs] r42 - cl-darcs/trunk
by mhenoch＠common-lisp.net 02 Sep '06

02 Sep '06

Author: mhenoch Date: Sat Sep 2 08:09:39 2006 New Revision: 42 Modified: cl-darcs/trunk/packages.lisp Log: Export *HTTP-PROXY* Modified: cl-darcs/trunk/packages.lisp ============================================================================== --- cl-darcs/trunk/packages.lisp (original) +++ cl-darcs/trunk/packages.lisp Sat Sep 2 08:09:39 2006 @@ -4,4 +4,4 @@ (:use :cl) (:nicknames :cl-darcs) (:export - #:get-repo #:pull)) + #:get-repo #:pull #:*http-proxy*))

1 0

[Cl-darcs-cvs] r41 - cl-darcs/trunk
by mhenoch＠common-lisp.net 02 Sep '06

02 Sep '06

Author: mhenoch Date: Sat Sep 2 07:18:46 2006 New Revision: 41 Modified: cl-darcs/trunk/packages.lisp Log: Export GET-REPO and PULL Modified: cl-darcs/trunk/packages.lisp ============================================================================== --- cl-darcs/trunk/packages.lisp (original) +++ cl-darcs/trunk/packages.lisp Sat Sep 2 07:18:46 2006 @@ -4,4 +4,4 @@ (:use :cl) (:nicknames :cl-darcs) (:export - )) + #:get-repo #:pull))

1 0

[Cl-darcs-cvs] r40 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Sep '06

01 Sep '06

Author: mhenoch Date: Fri Sep 1 05:48:01 2006 New Revision: 40 Modified: cl-darcs/trunk/README Log: Update README Modified: cl-darcs/trunk/README ============================================================================== --- cl-darcs/trunk/README (original) +++ cl-darcs/trunk/README Fri Sep 1 05:48:01 2006 @@ -15,9 +15,11 @@ Or if you want to select which patches to apply: (get-repo "http://path/to/repo" "/local/repo-dir/" :query t) -(apply-some-patches "/local/repo-dir/") -That's all that is implemented so far. +To pull new patches from a repo (the address from the remote repo is +optional, as it defaults to where you got the tree from): + +(pull "/local/repo-dir/" "http://path/to/repo") * Compatibility

1 0

[Cl-darcs-cvs] r39 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Sep '06

01 Sep '06

Author: mhenoch Date: Thu Aug 31 20:22:35 2006 New Revision: 39 Modified: cl-darcs/trunk/apply-patch.lisp Log: Make binary patch non-match a continuable error Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Thu Aug 31 20:22:35 2006 @@ -120,7 +120,8 @@ :element-type '(unsigned-byte 8)))) (read-sequence bytes in) (not (equalp bytes (binary-oldhex patch))))) - (error "Contents of ~A don't match patch." file))) + (cerror "Write new contents to ~A anyway." + "Contents of ~A don't match patch." file))) ;; Overwrite with new content. (with-open-file (out file :direction :output :if-exists :supersede

1 0

[Cl-darcs-cvs] r38 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Sep '06

01 Sep '06

Author: mhenoch Date: Thu Aug 31 20:22:13 2006 New Revision: 38 Modified: cl-darcs/trunk/pull.lisp Log: Use write-patch-to-repo when pulling Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Thu Aug 31 20:22:13 2006 @@ -34,7 +34,7 @@ (dolist (p only-theirs) (format t "~& - ~A" p)) ;; XXX: This is where we pick which of their patches we want to - ;; pull. And copy them to our repo. + ;; pull. (let* ((their-patches (mapcar (lambda (pi) (read-patch-from-repo theirrepo pi)) @@ -54,5 +54,6 @@ ;; If this is not a named patch, our assumptions are ;; challenged. (append-inventory ourrepo (named-patch-patchinfo p)) + (write-patch-to-repo p ourrepo) (format t "."))))) (format t "~&All done"))

1 0