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

[Cl-darcs-cvs] r157 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jan '08

08 Jan '08

Author: mhenoch Date: Tue Jan 8 13:09:17 2008 New Revision: 157 Modified: cl-darcs/trunk/cmdline.lisp Log: Hack "add" command for error messages conforming to darcs' test suite, etc Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Tue Jan 8 13:09:17 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2007 Magnus Henoch +;;; Copyright (C) 2007, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -27,6 +27,9 @@ "Turn a command symbol into a function symbol." (intern (format nil "CMD-~A" command) :darcs))) +(define-condition invalid-arguments (simple-error) + ()) + (defun handle-command-line (argv) "Handle a command line, emulating the real darcs client. ARGV is a list of strings. This function is to be called in some @@ -41,10 +44,24 @@ (format *error-output* "Invalid command '~A'!~%" (car argv))) (usage) 1) - (handler-case - (apply function (cdr argv)) + (handler-case + (let ((retval (apply function (cdr argv)))) + (fresh-line) + (if (numberp retval) + retval + (progn + (warn "~A didn't give a proper exit code." command) + 0))) + ;; Catch wrong number of arguments (program-error () (command-usage command) + 1) + (invalid-arguments (c) + (with-accessors ((ctrl simple-condition-format-control) + (args simple-condition-format-arguments)) c + (when ctrl + (apply #'format *error-output* ctrl args))) + (command-usage command) 1))))) (defun usage () @@ -60,7 +77,7 @@ (defun command-usage (command) "Print longer documentation for COMMAND." - (format *error-output* "~A~%" (documentation (command-function command) 'function))) + (format *error-output* "~&~A~%" (documentation (command-function command) 'function))) (defmacro define-darcs-command (name arglist docstring &body body) (let ((function (command-function name))) @@ -79,10 +96,47 @@ "Add files and directories for later recording. Usage: darcs add FILE ..." - (let ((repo (find-repo))) + (let ((repo (find-repo)) + already-there) (dolist (file files-and-dirs) - (add-file repo file) - (format t "~&Added ~A" file)))) + (handler-case + (progn + (add-file repo file) + ;; (format t "~&Added ~A" file) + ) + (already-in-repository (c) + ;; Save the files and directories that are already in the + ;; repository for pretty error printing. + (push (slot-value c 'file) already-there)))) + (when already-there + (setf already-there (nreverse already-there)) + (let* ((with-path (mapcar (lambda (f) (merge-pathnames f repo)) already-there)) + (nfiles 0) + (ndirs 0)) + (dolist (f with-path) + (let ((truename (fad:file-exists-p f))) + (assert truename) + (if (fad:directory-pathname-p f) + (incf ndirs) + (incf nfiles)))) + (assert (= (+ nfiles ndirs) (length already-there))) + ;; We want the message to look just like darcs', in order to + ;; pass its test suite (in particular tests/add.pl). + (format *error-output* + "~&The following ~A already in the repository" + (cond + ((zerop nfiles) + (if (= ndirs 1) + "directory is" + "directories are")) + ((zerop ndirs) + (if (= nfiles 1) + "file is" + "files are")) + (t + "files and directories are"))) + (format *error-output* ":~%~{ ~A~}" already-there)))) + 0) (define-darcs-command whatsnew () "See what has been changed in the working directory. @@ -98,12 +152,20 @@ (multiple-value-bind (operands options errors) (getopt:getopt args '(("repodir" :required))) - (declare (ignore operands)) + (unless (null operands) + (error 'invalid-arguments + :format-control "Invalid arguments: ~@{ ~A~}" + :format-arguments operands)) (if errors - (progn - (format *error-output* "Invalid arguments: ~{ ~A ~}~%" errors) - 1) + (error 'invalid-arguments + :format-control "Invalid arguments: ~@{ ~A~}" + :format-arguments errors) (let ((repodir (or (cdr (assoc "repodir" options :test #'string=)) *default-pathname-defaults*))) - (format t "Creating repo in ~S...~%" repodir) - (create-repo (truename repodir)))))) + (format t "Creating repo in ~A...~%" repodir) + (create-repo repodir) + 0)))) + +(define-darcs-command record (&rest args) + "Save changes in the working copy to the repository as a patch." + )

1 0

[Cl-darcs-cvs] r156 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jan '08

08 Jan '08

Author: mhenoch Date: Tue Jan 8 13:08:36 2008 New Revision: 156 Modified: cl-darcs/trunk/pristine.lisp Log: Add CREATE-EMPTY-PRISTINE Modified: cl-darcs/trunk/pristine.lisp ============================================================================== --- cl-darcs/trunk/pristine.lisp (original) +++ cl-darcs/trunk/pristine.lisp Tue Jan 8 13:08:36 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006 Magnus Henoch +;;; Copyright (C) 2006, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -16,6 +16,10 @@ (in-package :darcs) +(defun create-empty-pristine (repodir) + "Make an empty pristine tree in REPODIR." + (make-dir (upath-subdir repodir '("_darcs" "pristine")))) + (defun create-pristine-from-tree (repodir) "Copy the checked-out tree at REPODIR to get a pristine tree." (let* ((darcs-dir (upath-subdir repodir '("_darcs")))

1 0

[Cl-darcs-cvs] r155 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jan '08

08 Jan '08

Author: mhenoch Date: Tue Jan 8 13:08:01 2008 New Revision: 155 Added: cl-darcs/trunk/condition.lisp Modified: cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/pending.lisp cl-darcs/trunk/record.lisp Log: Remove pending patches after they are committed Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Tue Jan 8 13:08:01 2008 @@ -27,7 +27,8 @@ :components ((:file "packages") - (:file "util" :depends-on ("packages" #-allegro "inflate")) + (:file "condition" :depends-on ("packages")) + (:file "util" :depends-on ("packages" "condition" #-allegro "inflate")) (:file "unreadable-stream" :depends-on ("packages")) (:file "upath" :depends-on ("util" #|"binary-text"|#)) Added: cl-darcs/trunk/condition.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/condition.lisp Tue Jan 8 13:08:01 2008 @@ -0,0 +1,27 @@ +;;; Copyright (C) 2008 Magnus Henoch +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 2 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(in-package :darcs) + +(define-condition repository-condition () + ((repository :initarg :repository :type pathname + :documentation "The absolute path of the concerned repository.")) + (:documentation "Base class for conditions concerning a repository.")) + +(define-condition repository-file-condition (repository-condition) + ((file :initarg :file :type pathname + :documentation "The relative path of the concerned file or directory.")) + (:documentation "Base class for conditions concerning a file in a repository.")) Modified: cl-darcs/trunk/pending.lisp ============================================================================== --- cl-darcs/trunk/pending.lisp (original) +++ cl-darcs/trunk/pending.lisp Tue Jan 8 13:08:01 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2007 Magnus Henoch +;;; Copyright (C) 2007, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -26,16 +26,34 @@ (when (probe-file pending-file) (read-patch-from-file pending-file :compressed nil)))) +(defun write-pending (repodir patch) + "Write PATCH to the \"pending\" file in REPODIR. +The previous file is overwritten." + (declare (type (or null composite-patch) patch)) + (if (and patch (patches patch)) + (with-open-file (out (pending-filename repodir) + :direction :output :element-type '(unsigned-byte 8) + :if-exists :supersede) + (write-patch patch out)) + (delete-file (pending-filename repodir)))) + (defun add-to-pending (repodir patch) "Add PATCH to the list of \"pending\" patches in REPODIR." (let ((pending (read-pending repodir))) (when (null pending) (setf pending (make-instance 'composite-patch))) (setf (patches pending) (append (patches pending) (list patch))) - (with-open-file (out (pending-filename repodir) - :direction :output :element-type '(unsigned-byte 8) - :if-exists :supersede) - (write-patch pending out)))) + (write-pending repodir pending))) + +(defun remove-matching-from-pending (repodir patches) + "Remove PATCHES from the list of \"pending\" patches in REPODIR." + ;; Currently we only have ADD-FILE-PATCH and ADD-DIR-PATCH in + ;; pending, which can be compared by EQUAL-PATCH. + (let ((pending (read-pending repodir))) + (when pending + (setf (patches pending) + (nset-difference (patches pending) patches :test #'equal-patch)) + (write-pending repodir pending)))) (defun add-file (repo file) "Schedule FILE for recording to REPO. @@ -52,10 +70,23 @@ (let ((pristine-file (merge-pathnames file (upath-subdir repo '("_darcs" "pristine")))) (working-file (merge-pathnames file repo))) - (when (if (eql type :file) - (fad:file-exists-p pristine-file) - (fad:directory-exists-p pristine-file)) - (error "~A already exists in the repository." (pathname-to-string file))) + ;; XXX: does this work properly for directories? + (when (or + ;; Is file/directory already committed? + (if (eql type :file) + (fad:file-exists-p pristine-file) + (fad:directory-exists-p pristine-file)) + ;; Or is it already added to pending? + (let* ((pending (read-pending repo)) + (patches (when pending (patches pending)))) + (or + (find file patches + :key (lambda (p) (when (typep p 'add-file-patch) (patch-filename p))) + :test #'equal) + (find file patches + :key (lambda (p) (when (typep p 'add-dir-patch) (patch-directory p))) + :test #'equal)))) + (error 'already-in-repository :repository repo :file file)) (when (not (if (eql type :file) (fad:file-exists-p working-file) (fad:directory-exists-p working-file))) @@ -66,4 +97,13 @@ repo (if (eql type :file) (make-instance 'add-file-patch :filename file) - (make-instance 'add-dir-patch :directory file))))) \ No newline at end of file + (make-instance 'add-dir-patch :directory file))))) + +(define-condition already-in-repository (repository-file-condition error) + () + (:documentation "The file to be added already exists in the repository.") + (:report (lambda (condition stream) + (format stream + "~A already exists in the repository in ~A." + (slot-value condition 'file) + (slot-value condition 'repository))))) Modified: cl-darcs/trunk/record.lisp ============================================================================== --- cl-darcs/trunk/record.lisp (original) +++ cl-darcs/trunk/record.lisp Tue Jan 8 13:08:01 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006 Magnus Henoch +;;; Copyright (C) 2006, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -43,6 +43,7 @@ :patches patches)))) (write-patch-to-repo patch repo) (apply-patch-to-pristine patch repo) + (remove-matching-from-pending repo patches) (append-inventory repo patchinfo))) (defun record-changes (repo name author date log)

1 0

[Cl-darcs-cvs] r154 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jan '08

08 Jan '08

Author: mhenoch Date: Tue Jan 8 13:06:58 2008 New Revision: 154 Modified: cl-darcs/trunk/write-patch.lisp Log: Write directory patches without trailing slash Modified: cl-darcs/trunk/write-patch.lisp ============================================================================== --- cl-darcs/trunk/write-patch.lisp (original) +++ cl-darcs/trunk/write-patch.lisp Tue Jan 8 13:06:58 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006 Magnus Henoch +;;; Copyright (C) 2006, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -69,7 +69,9 @@ (defun write-token-and-filename (token filename stream) (write-as-bytes token stream) (write-byte 32 stream) - (write-as-bytes (pathname-to-string filename) stream) + ;; Both files and directories are specified in file format, + ;; i.e. without a trailing slash. + (write-as-bytes (pathname-to-string (fad:pathname-as-file filename)) stream) (write-byte 10 stream)) (defmethod write-patch ((patch add-file-patch) stream)

1 0

[Cl-darcs-cvs] r153 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jan '08

08 Jan '08

Author: mhenoch Date: Tue Jan 8 13:06:26 2008 New Revision: 153 Modified: cl-darcs/trunk/util.lisp Log: Ignore duplicated slashes in filenames Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Tue Jan 8 13:06:26 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006, 2007 Magnus Henoch +;;; Copyright (C) 2006, 2007, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -205,7 +205,7 @@ Signal an error if FILENAME doesn't denote a relative path going strictly down. If TYPE is :DIRECTORY, return pathname in directory form." - (let ((components (split-sequence:split-sequence #\/ filename))) + (let ((components (split-sequence:split-sequence #\/ filename :remove-empty-subseqs t))) (setf components (delete "." components :test #'string=)) (when (member ".." components :test #'string=) (error "Filename ~S tries to go up in directory tree." filename))

1 0

[Cl-darcs-cvs] r152 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jan '08

08 Jan '08

Author: mhenoch Date: Tue Jan 8 13:05:49 2008 New Revision: 152 Modified: cl-darcs/trunk/get.lisp Log: CREATE-REPO: Create directory if it doesn't exist. Always make an empty pristine tree. Modified: cl-darcs/trunk/get.lisp ============================================================================== --- cl-darcs/trunk/get.lisp (original) +++ cl-darcs/trunk/get.lisp Tue Jan 8 13:05:49 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006, 2007 Magnus Henoch +;;; Copyright (C) 2006, 2007, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -19,8 +19,15 @@ (defun create-repo (repodir) "Create an empty repository." (setf repodir (fad:pathname-as-directory repodir)) + + ;; Create the directory if it doesn't exist, then get the absolute + ;; path. + (ensure-directories-exist repodir) + (setf repodir (truename repodir)) + + ;; Darcsify it. (prepare-new-repo repodir) - (create-pristine-from-tree repodir)) + (create-empty-pristine repodir)) ;; get_cmd in Get.lhs (defun get-repo (inrepodir outname &key (partial nil) (query nil))

1 0

[Cl-darcs-cvs] r151 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jan '08

08 Jan '08

Author: mhenoch Date: Tue Jan 8 13:05:09 2008 New Revision: 151 Modified: cl-darcs/trunk/equal.lisp Log: Make EQUAL-PATCH work for ADD-FILE-PATCH and RM-FILE-PATCH Modified: cl-darcs/trunk/equal.lisp ============================================================================== --- cl-darcs/trunk/equal.lisp (original) +++ cl-darcs/trunk/equal.lisp Tue Jan 8 13:05:09 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006 Magnus Henoch +;;; Copyright (C) 2006, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -47,6 +47,14 @@ (equal (patch-filename a) (patch-filename b))) (call-next-method))) +(defmethod equal-patch ((a file-patch) (b file-patch) &optional really) + "Compare two simple file patches. +If the :around method proceeds to call us, and there is no more specific +method, then we have two ADD-FILE-PATCHes or RM-FILE-PATCHES, which are +equal." + (declare (ignore really)) + t) + (defmethod equal-patch ((a hunk-patch) (b hunk-patch) &optional really) "Compare two hunk patches." (declare (ignore really))

1 0

[Cl-darcs-cvs] r150 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jan '08

08 Jan '08

Author: mhenoch Date: Tue Jan 8 13:04:02 2008 New Revision: 150 Modified: cl-darcs/trunk/diff.lisp Log: Signal an error when adding a file or directory that already exists Modified: cl-darcs/trunk/diff.lisp ============================================================================== --- cl-darcs/trunk/diff.lisp (original) +++ cl-darcs/trunk/diff.lisp Tue Jan 8 13:04:02 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006, 2007 Magnus Henoch +;;; Copyright (C) 2006, 2007, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -157,7 +157,10 @@ (typecase p (add-file-patch (let ((pathname-string (pathname-to-string (patch-filename p))) + (old-file (merge-pathnames (patch-filename p) pristine)) (new-file (merge-pathnames (patch-filename p) repo))) + (when (fad:file-exists-p old-file) + (error "Pending add of file ~A, but it already exists in the repository." pathname-string)) (setf patches (nconc patches (list* p @@ -165,6 +168,10 @@ (diff-binary-file nil new-file :filename pathname-string) (diff-file nil new-file :filename pathname-string))))))) (add-dir-patch + (let ((pathname-string (pathname-to-string (patch-directory p))) + (old-dir (merge-pathnames (patch-directory p) pristine))) + (when (fad:directory-exists-p old-dir) + (error "Pending add of directory ~A, but it already exists in the repository." pathname-string))) (setf patches (nconc patches (list p)))) (t (push p pruned-pending))))

1 0

[Cl-darcs-cvs] r149 - cl-darcs/trunk
by mhenoch＠common-lisp.net 08 Jan '08

08 Jan '08

Author: mhenoch Date: Tue Jan 8 13:02:20 2008 New Revision: 149 Modified: cl-darcs/trunk/apply-patch.lisp Log: Fix error signalling when file to create already exists Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Tue Jan 8 13:02:20 2008 @@ -1,4 +1,4 @@ -;;; Copyright (C) 2006, 2007 Magnus Henoch +;;; Copyright (C) 2006, 2007, 2008 Magnus Henoch ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -107,9 +107,10 @@ (let ((new-file (merge-pathnames (patch-filename patch) repodir))) (dformat "~&Creating file ~A." new-file) - (open new-file :direction :probe - :if-does-not-exist :create - :if-exists :error))) + (with-open-file (f new-file :direction :output + :if-does-not-exist :create + :if-exists :error) + (declare (ignore f))))) (defmethod apply-patch ((patch binary-patch) repodir) "Apply a binary patch in REPODIR."

1 0

[Cl-darcs-cvs] r148 - cl-darcs/trunk
by mhenoch＠common-lisp.net 25 Nov '07

25 Nov '07

Author: mhenoch Date: Sun Nov 25 16:11:09 2007 New Revision: 148 Modified: cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/cmdline.lisp Log: Use getopt library. Use it for "init" command. Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Sun Nov 25 16:11:09 2007 @@ -22,7 +22,8 @@ ;; Regexps :cl-ppcre ;; Diff - :cl-difflib) + :cl-difflib + :getopt) :components ((:file "packages") Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Sun Nov 25 16:11:09 2007 @@ -90,6 +90,20 @@ Usage: darcs whatsnew" (diff-repo-display (find-repo))) -(define-darcs-command init () - "Initialize a darcs repository in the current directory." - (create-repo (truename *default-pathname-defaults*))) +(define-darcs-command init (&rest args) + "Initialize a darcs repository in the current directory. + +Options: +--repodir=DIRECTORY Use DIRECTORY instead of current directory" + (multiple-value-bind (operands options errors) + (getopt:getopt args + '(("repodir" :required))) + (declare (ignore operands)) + (if errors + (progn + (format *error-output* "Invalid arguments: ~{ ~A ~}~%" errors) + 1) + (let ((repodir (or (cdr (assoc "repodir" options :test #'string=)) + *default-pathname-defaults*))) + (format t "Creating repo in ~S...~%" repodir) + (create-repo (truename repodir))))))

1 0