From mhenoch at common-lisp.net Wed Mar 5 05:39:54 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 00:39:54 -0500 (EST) Subject: [Cl-darcs-cvs] r159 - cl-darcs/trunk Message-ID: <20080305053954.81F474095@common-lisp.net> Author: mhenoch Date: Wed Mar 5 00:39:54 2008 New Revision: 159 Modified: cl-darcs/trunk/cmdline.lisp cl-darcs/trunk/getopt.lisp Log: Move INVALID-ARGUMENTS condition to getopt.lisp, and use it. Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 00:39:54 2008 @@ -27,9 +27,6 @@ "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 Modified: cl-darcs/trunk/getopt.lisp ============================================================================== --- cl-darcs/trunk/getopt.lisp (original) +++ cl-darcs/trunk/getopt.lisp Wed Mar 5 00:39:54 2008 @@ -16,6 +16,9 @@ (in-package :darcs) +(define-condition invalid-arguments (simple-error) + ()) + ;; The option struct describes a command line option. (defstruct option ;; keyword for return value of GETOPT @@ -53,7 +56,9 @@ (push (cons (option-keyword opt) (if (option-arg opt) (if (or no-argument (null args)) - (error "Option ~A requires an argument." arg) + (error 'invalid-arguments + :format-control "Option ~A requires an argument." + :format-arguments (list arg)) (pop args)) t)) parsed)) @@ -80,7 +85,9 @@ (long-option (maybe-split-long-option arg)) (option (find long-option options :key #'option-long :test #'string=))) (unless option - (error "Unknown long option ~S (none of ~{~S ~})." arg (mapcar #'option-long options))) + (error 'invalid-arguments + :format-control "Unknown long option ~S (none of ~{~S ~})." + :format-arguments (list arg (mapcar #'option-long options)))) (maybe-get-argument arg option))) (:short @@ -93,7 +100,9 @@ (let* ((letter (pop letters)) (option (find letter options :key #'option-short))) (unless option - (error "Unknown option ~A." letter)) + (error 'invalid-arguments + :format-control "Unknown option ~A." + :format-arguments (list letter))) ;; Only the last short option can have an argument. (maybe-get-argument letter option :no-argument (not (null letters))))))) From mhenoch at common-lisp.net Wed Mar 5 07:04:31 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 02:04:31 -0500 (EST) Subject: [Cl-darcs-cvs] r160 - cl-darcs/trunk Message-ID: <20080305070431.1636F330A4@common-lisp.net> Author: mhenoch Date: Wed Mar 5 02:04:31 2008 New Revision: 160 Modified: cl-darcs/trunk/pending.lisp Log: When adding a file, make sure that we can read it Modified: cl-darcs/trunk/pending.lisp ============================================================================== --- cl-darcs/trunk/pending.lisp (original) +++ cl-darcs/trunk/pending.lisp Wed Mar 5 02:04:31 2008 @@ -70,6 +70,11 @@ (let ((pristine-file (merge-pathnames file (upath-subdir repo '("_darcs" "pristine")))) (working-file (merge-pathnames file repo))) + ;; Make sure that we can read the file + (when (eql type :file) + (with-open-file (s working-file :direction :input) + t)) + ;; XXX: does this work properly for directories? (when (or ;; Is file/directory already committed? From mhenoch at common-lisp.net Wed Mar 5 07:18:23 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 02:18:23 -0500 (EST) Subject: [Cl-darcs-cvs] r161 - cl-darcs/trunk Message-ID: <20080305071823.2F1981B01D@common-lisp.net> Author: mhenoch Date: Wed Mar 5 02:18:21 2008 New Revision: 161 Modified: cl-darcs/trunk/pull.lisp Log: Fix typo in docstring Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Wed Mar 5 02:18:21 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 @@ -18,7 +18,7 @@ (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 +If THEIRREPO is not specified, use default repository specified in preferences. SELECT-PATCHES specifies how to select which remote patches to pull. It can be one of: From mhenoch at common-lisp.net Wed Mar 5 07:37:04 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 02:37:04 -0500 (EST) Subject: [Cl-darcs-cvs] r162 - cl-darcs/trunk Message-ID: <20080305073704.A599B330A4@common-lisp.net> Author: mhenoch Date: Wed Mar 5 02:36:57 2008 New Revision: 162 Modified: cl-darcs/trunk/cmdline.lisp Log: FIND-REPO finds repository in parent directories too Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 02:36:57 2008 @@ -105,12 +105,19 @@ (destructuring-bind ,operands ,operands-sym , at body)))))))) -(defun find-repo () - "Find repository in current directory. -Signal an error if there is none." - (unless (fad:directory-exists-p (upath-subdir *default-pathname-defaults* '("_darcs"))) - (error "Not in a darcs repo.")) - *default-pathname-defaults*) +(defun find-repo (&optional (dir *default-pathname-defaults*)) + "Find repository in current directory or above. +Signal an error if there is none, else return the repository root. +If DIR is specified, search for repository there instead." + (if (fad:directory-exists-p (upath-subdir dir '("_darcs"))) + dir + (let ((parent-dir (ignore-errors + (merge-pathnames + (make-pathname :directory '(:relative :up)) + dir)))) + (if parent-dir + (find-repo parent-dir) + (error "Not in a darcs repo."))))) (define-darcs-command add () (&rest files-and-dirs) "Add files and directories for later recording. From mhenoch at common-lisp.net Wed Mar 5 07:55:08 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 02:55:08 -0500 (EST) Subject: [Cl-darcs-cvs] r163 - cl-darcs/trunk Message-ID: <20080305075508.5CAC41B04E@common-lisp.net> Author: mhenoch Date: Wed Mar 5 02:55:07 2008 New Revision: 163 Removed: cl-darcs/trunk/init.lisp Modified: cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/repo.lisp Log: Delete init.lisp and its INIT-TREE. Write empty inventory in PREPARE-NEW-REPO. Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Wed Mar 5 02:55:07 2008 @@ -34,7 +34,6 @@ (:file "patchinfo" :depends-on ("util")) (:file "get" :depends-on ("util")) (:file "pull" :depends-on ("util")) - (:file "init" :depends-on ("util")) (:file "prefs" :depends-on ("util")) (:file "repo" :depends-on ("util")) (:file "diff" :depends-on ("util")) Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Wed Mar 5 02:55:07 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 @@ -30,7 +30,8 @@ (dolist (dir '("patches" "checkpoints" "prefs" "inventories")) (make-dir (merge-pathnames (make-pathname :directory (list :relative dir)) - darcs-dir)))) + darcs-dir))) + (write-inventory outname ())) (write-default-prefs outname)) ;; {lazily,}read_repo in DarcsRepo.lhs From mhenoch at common-lisp.net Wed Mar 5 08:01:47 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 03:01:47 -0500 (EST) Subject: [Cl-darcs-cvs] r164 - cl-darcs/trunk Message-ID: <20080305080147.C7DC433102@common-lisp.net> Author: mhenoch Date: Wed Mar 5 03:01:47 2008 New Revision: 164 Modified: cl-darcs/trunk/pull.lisp Log: Adapt message when there are no patches to pull Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Wed Mar 5 03:01:47 2008 @@ -42,7 +42,7 @@ (declare (ignore common)) (when (null only-theirs) - (format t "~&Found no new patches.") + (format t "~&No remote changes to pull in.") (return-from pull)) (format t "~&Found these new patches:") From mhenoch at common-lisp.net Wed Mar 5 08:03:55 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 03:03:55 -0500 (EST) Subject: [Cl-darcs-cvs] r165 - cl-darcs/trunk Message-ID: <20080305080355.F31F333102@common-lisp.net> Author: mhenoch Date: Wed Mar 5 03:03:55 2008 New Revision: 165 Modified: cl-darcs/trunk/repo.lisp Log: Handle empty inventory files Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Wed Mar 5 03:03:55 2008 @@ -48,8 +48,11 @@ (let (tag-patches patches) (with-open-stream (in (make-instance 'unreadable-stream :base-stream (open-upath inventory-file :binary t))) - ;; If first line is "Starting with tag:", - (let ((first-line (read-binary-line in))) + (let ((first-line (read-binary-line in nil :eof))) + (when (eq first-line :eof) + ;; XXX: should this be (list nil)? + (return-from read-repo-patch-list nil)) + ;; If first line is "Starting with tag:", (if (string= (bytes-to-string first-line) "Starting with tag:") (let* ((tag-patch ;; read the first patch... From mhenoch at common-lisp.net Wed Mar 5 08:05:42 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 03:05:42 -0500 (EST) Subject: [Cl-darcs-cvs] r166 - cl-darcs/trunk Message-ID: <20080305080542.B872240002@common-lisp.net> Author: mhenoch Date: Wed Mar 5 03:05:40 2008 New Revision: 166 Modified: cl-darcs/trunk/pull.lisp Log: Fix typo in error message Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Wed Mar 5 03:05:40 2008 @@ -30,7 +30,7 @@ (unless theirrepo (setf theirrepo (car (get-preflist ourrepo "defaultrepo"))) (unless theirrepo - (error "No remote repositiory specified, and no default available."))) + (error "No remote repository specified, and no default available."))) (add-to-preflist ourrepo "repos" theirrepo) (let ((motd (get-preflist theirrepo "motd"))) (when motd From mhenoch at common-lisp.net Wed Mar 5 08:10:12 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 03:10:12 -0500 (EST) Subject: [Cl-darcs-cvs] r167 - cl-darcs/trunk Message-ID: <20080305081012.2ECD44E03B@common-lisp.net> Author: mhenoch Date: Wed Mar 5 03:10:11 2008 New Revision: 167 Modified: cl-darcs/trunk/upath.lisp Log: UPATH-SUBDIR: assume that base pathname is a directory, and use PATHNAME-AS-DIRECTORY Modified: cl-darcs/trunk/upath.lisp ============================================================================== --- cl-darcs/trunk/upath.lisp (original) +++ cl-darcs/trunk/upath.lisp Wed Mar 5 03:10:11 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 @@ -37,7 +37,8 @@ (pathname path))))) (defun upath-subdir (base subdirs &optional filename) - "From BASE, descend into SUBDIRS and FILENAME." + "From BASE, descend into SUBDIRS and FILENAME. +PATH is assumed to refer to a directory, not a file." (setf base (make-upath base)) (let* ((subdirs-list (remove-if #'keywordp (if (pathnamep subdirs) @@ -59,6 +60,7 @@ new-uri)) ;; this won't work correctly if BASE has a filename (pathname + (setf base (fad:pathname-as-directory base)) (merge-pathnames (make-pathname :directory (cons :relative subdirs-list) :name filename) From mhenoch at common-lisp.net Wed Mar 5 08:11:37 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 03:11:37 -0500 (EST) Subject: [Cl-darcs-cvs] r168 - cl-darcs/trunk Message-ID: <20080305081137.A61D11B04E@common-lisp.net> Author: mhenoch Date: Wed Mar 5 03:11:37 2008 New Revision: 168 Modified: cl-darcs/trunk/cmdline.lisp Log: FIND-REPO: get truename of directory Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 03:11:37 2008 @@ -110,7 +110,7 @@ Signal an error if there is none, else return the repository root. If DIR is specified, search for repository there instead." (if (fad:directory-exists-p (upath-subdir dir '("_darcs"))) - dir + (fad:directory-exists-p dir) ;get directory truename (let ((parent-dir (ignore-errors (merge-pathnames (make-pathname :directory '(:relative :up)) From mhenoch at common-lisp.net Wed Mar 5 08:56:43 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 03:56:43 -0500 (EST) Subject: [Cl-darcs-cvs] r169 - cl-darcs/trunk Message-ID: <20080305085643.BDDC61503E@common-lisp.net> Author: mhenoch Date: Wed Mar 5 03:56:43 2008 New Revision: 169 Modified: cl-darcs/trunk/pull.lisp cl-darcs/trunk/upath.lisp Log: Add UPATH-TO-STRING and use it for saving repository addresses Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Wed Mar 5 03:56:43 2008 @@ -31,7 +31,7 @@ (setf theirrepo (car (get-preflist ourrepo "defaultrepo"))) (unless theirrepo (error "No remote repository specified, and no default available."))) - (add-to-preflist ourrepo "repos" theirrepo) + (add-to-preflist ourrepo "repos" (upath-to-string theirrepo)) (let ((motd (get-preflist theirrepo "motd"))) (when motd (format t "~{~&~A~}" motd))) Modified: cl-darcs/trunk/upath.lisp ============================================================================== --- cl-darcs/trunk/upath.lisp (original) +++ cl-darcs/trunk/upath.lisp Wed Mar 5 03:56:43 2008 @@ -80,3 +80,15 @@ (pathname (open upath :direction :input :if-does-not-exist :error :element-type (if binary '(unsigned-byte 8) 'character))))) + +(defun upath-to-string (upath) + "Convert UPATH to a string. +This string can be read with MAKE-UPATH." + (ctypecase upath + (string + upath) + (pathname + (namestring upath)) + (net.uri:uri + (with-output-to-string (s) + (net.uri:render-uri upath s))))) From mhenoch at common-lisp.net Wed Mar 5 08:59:08 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 03:59:08 -0500 (EST) Subject: [Cl-darcs-cvs] r170 - cl-darcs/trunk Message-ID: <20080305085908.833931B028@common-lisp.net> Author: mhenoch Date: Wed Mar 5 03:59:08 2008 New Revision: 170 Modified: cl-darcs/trunk/pull.lisp Log: Adapt message when pull finished Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Wed Mar 5 03:59:08 2008 @@ -102,4 +102,4 @@ (when source-and-pristine-differ (format t "~&~" nil))))) - (format t "~&All done"))) + (format t "~&Finished pulling and applying."))) From mhenoch at common-lisp.net Wed Mar 5 09:01:42 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 04:01:42 -0500 (EST) Subject: [Cl-darcs-cvs] r171 - cl-darcs/trunk Message-ID: <20080305090142.52149330DA@common-lisp.net> Author: mhenoch Date: Wed Mar 5 04:01:41 2008 New Revision: 171 Modified: cl-darcs/trunk/cmdline.lisp Log: Implement "pull" command. Remove obsolete handler case. Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 04:01:41 2008 @@ -49,11 +49,6 @@ (progn (warn "~A didn't give a proper exit code." command) 0))) - ;; Catch wrong number of arguments - (program-error (c) - (format *error-output* "~&Program error: ~A" c) - (command-usage command) - 1) (invalid-arguments (c) (with-accessors ((ctrl simple-condition-format-control) (args simple-condition-format-arguments)) c @@ -262,3 +257,39 @@ (format t "~&Finished recording patch '~A'~%" patch-name) 0)))) +(define-darcs-command pull + (all-patches repodir) + (&rest from-repositories) + "Copy and apply patches from another repository to this one." + (let* ((ourrepo + (if repodir + (or (fad:directory-exists-p repodir) + (error "Directory ~A does not exist." repodir)) + (find-repo))) + ;; If explicit --repodir argument was specified, change directory. + ;; Otherwise, leave it, even if the actual repository is in a + ;; parent directory. + (*default-pathname-defaults* + (if (null repodir) + *default-pathname-defaults* + (fad:pathname-as-directory ourrepo)))) + + (if from-repositories + ;; Get truename for all repositories, if they are local paths. + (map-into + from-repositories + (lambda (dir) + (setf dir (make-upath dir)) + (when (typep dir 'pathname) + (setf dir (or + (fad:directory-exists-p dir) + (error "Directory ~A does not exist." dir)))) + dir) + from-repositories) + ;; If no remote repository specified, use the default one. + (setf from-repositories (list nil))) + + (dolist (theirrepo from-repositories) + (pull ourrepo theirrepo :select-patches (if all-patches :all :ask))) + + 0)) From mhenoch at common-lisp.net Wed Mar 5 09:17:09 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 04:17:09 -0500 (EST) Subject: [Cl-darcs-cvs] r172 - cl-darcs/trunk Message-ID: <20080305091709.A39171B02E@common-lisp.net> Author: mhenoch Date: Wed Mar 5 04:17:09 2008 New Revision: 172 Modified: cl-darcs/trunk/cmdline.lisp Log: Add WITH-REPO and use it for "add". Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 04:17:09 2008 @@ -100,6 +100,13 @@ (destructuring-bind ,operands ,operands-sym , at body)))))))) +(defparameter opt-repodir + (make-option + :keyword :repodir + :long "repodir" + :arg "DIRECTORY" + :help "Use DIRECTORY instead of current directory")) + (defun find-repo (&optional (dir *default-pathname-defaults*)) "Find repository in current directory or above. Signal an error if there is none, else return the repository root. @@ -114,16 +121,39 @@ (find-repo parent-dir) (error "Not in a darcs repo."))))) -(define-darcs-command add () (&rest files-and-dirs) +(defmacro with-repo (repodir &body body) + "Given a --repodir argument, canonicalize it and change directory accordingly. +That is, if there is no --repodir option, don't change current directory, +and bind variable to the repository root directory. +If there is a --repodir option, ensure it refers to an existing directory, +and change the current directory to it. +\(This is actually how the original darcs does it.\)" + (let ((original-repodir (gensym))) + `(let* ((,original-repodir ,repodir) + (,repodir + (if ,repodir + (or (fad:directory-exists-p ,repodir) + (error "Directory ~A does not exist." ,repodir)) + (find-repo))) + ;; If explicit --repodir argument was specified, change directory. + ;; Otherwise, leave it, even if the actual repository is in a + ;; parent directory. + (*default-pathname-defaults* + (if (null ,original-repodir) + *default-pathname-defaults* + (fad:pathname-as-directory ,repodir)))) + , at body))) + +(define-darcs-command add (repodir) (&rest files-and-dirs + &aux already-there) "Add files and directories for later recording. Usage: darcs add FILE ..." - (let ((repo (find-repo)) - already-there) + (with-repo repodir (dolist (file files-and-dirs) (handler-case (progn - (add-file repo file) + (add-file repodir file) ;; (format t "~&Added ~A" file) ) (already-in-repository (c) @@ -132,7 +162,7 @@ (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)) + (let* ((with-path (mapcar (lambda (f) (merge-pathnames f repodir)) already-there)) (nfiles 0) (ndirs 0)) (dolist (f with-path) @@ -166,13 +196,6 @@ Usage: darcs whatsnew" (diff-repo-display (find-repo))) -(defparameter opt-repodir - (make-option - :keyword :repodir - :long "repodir" - :arg "DIRECTORY" - :help "Use DIRECTORY instead of current directory")) - (define-darcs-command init (repodir) () "Initialize a darcs repository in the current directory. From mhenoch at common-lisp.net Wed Mar 5 09:20:38 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 04:20:38 -0500 (EST) Subject: [Cl-darcs-cvs] r173 - cl-darcs/trunk Message-ID: <20080305092038.1665C4E03E@common-lisp.net> Author: mhenoch Date: Wed Mar 5 04:20:37 2008 New Revision: 173 Modified: cl-darcs/trunk/cmdline.lisp Log: Use WITH-REPO for "record" Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 04:20:37 2008 @@ -237,48 +237,48 @@ :help "ask for extra dependencies")) (define-darcs-command record - (author all-patches patch-name ask-deps) + (author all-patches patch-name ask-deps repodir) (&rest files) "Save changes in the working copy to the repository as a patch." - (let* ((repo (find-repo)) - (author (or author - ;; XXX: other ways to indicate author - (progn - (format *query-io* "~&Who is the author? ") - (read-line *query-io*)))) - (patch-name (or patch-name - (progn - (format *query-io* "~&What is the patch name? ") - (read-line *query-io*)))) - (files (mapcar - (lambda (file) - (setf file (enough-namestring file repo)) - (if (fad:directory-exists-p file) - (sanitize-filename file :type :directory) - (sanitize-filename file :type :file))) - files))) - ;; XXX: long log - - (let ((patches (diff-repo repo))) - (flet ((ask (patch) - ;; If any files were specified, use only patches - ;; touching those files/directories. - (if (or (null files) - (and (typep patch 'file-patch) - (member (patch-filename patch) files :test #'equal)) - (and (typep patch 'directory-patch) - (member (patch-directory patch) files :test #'equal))) - ;; If all-patches was requested, record all patches - ;; matching the file criterion. - (or all-patches + (with-repo repodir + (let* ((author (or author + ;; XXX: other ways to indicate author (progn - (display-patch patch *query-io*) - (y-or-n-p "Record patch ~A?" patch))) - nil))) - (record-patches repo patch-name author :now nil - (select-patches patches #'ask)) - (format t "~&Finished recording patch '~A'~%" patch-name) - 0)))) + (format *query-io* "~&Who is the author? ") + (read-line *query-io*)))) + (patch-name (or patch-name + (progn + (format *query-io* "~&What is the patch name? ") + (read-line *query-io*)))) + (files (mapcar + (lambda (file) + (setf file (enough-namestring file repodir)) + (if (fad:directory-exists-p file) + (sanitize-filename file :type :directory) + (sanitize-filename file :type :file))) + files))) + ;; XXX: long log + + (let ((patches (diff-repo repodir))) + (flet ((ask (patch) + ;; If any files were specified, use only patches + ;; touching those files/directories. + (if (or (null files) + (and (typep patch 'file-patch) + (member (patch-filename patch) files :test #'equal)) + (and (typep patch 'directory-patch) + (member (patch-directory patch) files :test #'equal))) + ;; If all-patches was requested, record all patches + ;; matching the file criterion. + (or all-patches + (progn + (display-patch patch *query-io*) + (y-or-n-p "Record patch ~A?" patch))) + nil))) + (record-patches repodir patch-name author :now nil + (select-patches patches #'ask)) + (format t "~&Finished recording patch '~A'~%" patch-name) + 0))))) (define-darcs-command pull (all-patches repodir) From mhenoch at common-lisp.net Wed Mar 5 09:36:07 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 04:36:07 -0500 (EST) Subject: [Cl-darcs-cvs] r174 - cl-darcs/trunk Message-ID: <20080305093607.47D8B1B04C@common-lisp.net> Author: mhenoch Date: Wed Mar 5 04:36:07 2008 New Revision: 174 Modified: cl-darcs/trunk/equal.lisp Log: EQUAL-PATCH: add method for comparing two DIRECTORY-PATCHes Modified: cl-darcs/trunk/equal.lisp ============================================================================== --- cl-darcs/trunk/equal.lisp (original) +++ cl-darcs/trunk/equal.lisp Wed Mar 5 04:36:07 2008 @@ -66,6 +66,12 @@ (compare #'hunk-old-lines) (compare #'hunk-new-lines)))) +(defmethod equal-patch ((a directory-patch) (b directory-patch) &optional really) + "Compare two directory add/remove patches." + (declare (ignore really)) + (and (eq (type-of a) (type-of b)) + (equal (patch-directory a) (patch-directory b)))) + (defmethod equal-patch ((a token-replace-patch) (b token-replace-patch) &optional really) "Compare two token replacing patches." (declare (ignore really)) From mhenoch at common-lisp.net Wed Mar 5 09:39:54 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 04:39:54 -0500 (EST) Subject: [Cl-darcs-cvs] r175 - cl-darcs/trunk Message-ID: <20080305093954.05BFC1B04C@common-lisp.net> Author: mhenoch Date: Wed Mar 5 04:39:54 2008 New Revision: 175 Modified: cl-darcs/trunk/cmdline.lisp Log: Make FIND-REPO handle its error case properly. FINISH-OUTPUT before reading answers in "record". Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 04:39:54 2008 @@ -114,10 +114,11 @@ (if (fad:directory-exists-p (upath-subdir dir '("_darcs"))) (fad:directory-exists-p dir) ;get directory truename (let ((parent-dir (ignore-errors - (merge-pathnames - (make-pathname :directory '(:relative :up)) - dir)))) - (if parent-dir + (fad:directory-exists-p + (merge-pathnames + (make-pathname :directory '(:relative :up)) + dir))))) + (if (and parent-dir (not (equal dir parent-dir))) (find-repo parent-dir) (error "Not in a darcs repo."))))) @@ -245,10 +246,12 @@ ;; XXX: other ways to indicate author (progn (format *query-io* "~&Who is the author? ") + (finish-output *query-io*) (read-line *query-io*)))) (patch-name (or patch-name (progn (format *query-io* "~&What is the patch name? ") + (finish-output *query-io*) (read-line *query-io*)))) (files (mapcar (lambda (file) From mhenoch at common-lisp.net Wed Mar 5 10:39:39 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 05:39:39 -0500 (EST) Subject: [Cl-darcs-cvs] r176 - cl-darcs/trunk Message-ID: <20080305103939.0059A15032@common-lisp.net> Author: mhenoch Date: Wed Mar 5 05:39:39 2008 New Revision: 176 Modified: cl-darcs/trunk/cmdline.lisp Log: Change default repository when pulling Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 05:39:39 2008 @@ -318,4 +318,8 @@ (dolist (theirrepo from-repositories) (pull ourrepo theirrepo :select-patches (if all-patches :all :ask))) + ;; Change the default repository. + (when (first from-repositories) + (set-default-repo ourrepo (upath-to-string (first from-repositories)))) + 0)) From mhenoch at common-lisp.net Wed Mar 5 10:44:12 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Wed, 5 Mar 2008 05:44:12 -0500 (EST) Subject: [Cl-darcs-cvs] r177 - cl-darcs/trunk Message-ID: <20080305104412.C51C84008D@common-lisp.net> Author: mhenoch Date: Wed Mar 5 05:44:12 2008 New Revision: 177 Modified: cl-darcs/trunk/cmdline.lisp Log: Check that we don't pull from current repository Modified: cl-darcs/trunk/cmdline.lisp ============================================================================== --- cl-darcs/trunk/cmdline.lisp (original) +++ cl-darcs/trunk/cmdline.lisp Wed Mar 5 05:44:12 2008 @@ -315,6 +315,10 @@ ;; If no remote repository specified, use the default one. (setf from-repositories (list nil))) + ;; We can't pull from ourselves. + (when (member ourrepo from-repositories :test #'equal) + (error "Can't pull from current repository!")) + (dolist (theirrepo from-repositories) (pull ourrepo theirrepo :select-patches (if all-patches :all :ask))) From mhenoch at common-lisp.net Mon Mar 24 00:08:39 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sun, 23 Mar 2008 19:08:39 -0500 (EST) Subject: [Cl-darcs-cvs] r178 - cl-darcs/trunk Message-ID: <20080324000839.7A9443307D@common-lisp.net> Author: mhenoch Date: Sun Mar 23 19:08:39 2008 New Revision: 178 Modified: cl-darcs/trunk/repo.lisp Log: GET-COMMON-AND-UNCOMMON returns patchinfo in correct order Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Sun Mar 23 19:08:39 2008 @@ -167,8 +167,16 @@ THEIRS." ;; Of course, there are possible optimizations here, in particular ;; regarding tags, but this will do for now. - (let ((ours-list (apply #'append (reverse ours))) - (theirs-list (apply #'append (reverse theirs)))) - (values (intersection ours-list theirs-list :test #'equalp) - (set-difference ours-list theirs-list :test #'equalp) - (set-difference theirs-list ours-list :test #'equalp)))) + (setf ours (apply #'append (reverse ours))) + (setf theirs (apply #'append (reverse theirs))) + (let (common-patches our-patches their-patches) + (loop + for ou on ours and th on theirs + while (equalp (car ou) (car th)) + collect (car ou) into common + finally + (setf common-patches common + our-patches ou + their-patches th)) + (values common-patches our-patches their-patches))) + From mhenoch at common-lisp.net Mon Mar 24 00:38:37 2008 From: mhenoch at common-lisp.net (mhenoch at common-lisp.net) Date: Sun, 23 Mar 2008 19:38:37 -0500 (EST) Subject: [Cl-darcs-cvs] r179 - in cl-darcs/trunk: . tests Message-ID: <20080324003837.8BF44620BB@common-lisp.net> Author: mhenoch Date: Sun Mar 23 19:38:36 2008 New Revision: 179 Added: cl-darcs/trunk/tests/ cl-darcs/trunk/tests/gcau-tests.lisp cl-darcs/trunk/tests/package.lisp Modified: cl-darcs/trunk/cl-darcs.asd cl-darcs/trunk/repo.lisp Log: Add test suite Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Sun Mar 23 19:38:36 2008 @@ -64,3 +64,21 @@ #+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (require :inflate)) + +(defmethod perform ((o test-op) (c (eql (find-system 'cl-darcs)))) + (operate 'load-op 'cl-darcs-tests) + (operate 'test-op 'cl-darcs-tests :force t)) + +(defsystem cl-darcs-tests + :depends-on (cl-darcs fiveam) + :components + ((:module "tests" + :components ((:file "package") + (:file "gcau-tests"))))) + +(defmethod perform ((o test-op) (c (eql (find-system 'cl-darcs-tests)))) + (operate 'load-op 'cl-darcs-tests) + (funcall (intern (symbol-name '#:run!) + (find-package '#:darcs-tests)) + (intern (symbol-name '#:darcs-suite) + (find-package '#:darcs-tests)))) \ No newline at end of file Modified: cl-darcs/trunk/repo.lisp ============================================================================== --- cl-darcs/trunk/repo.lisp (original) +++ cl-darcs/trunk/repo.lisp Sun Mar 23 19:38:36 2008 @@ -158,6 +158,7 @@ (write-patchinfo patchinfo strout))) (write-byte 10 f))) +;; See also tests/gcau-tests.lisp (defun get-common-and-uncommon (ours theirs) "Given patchsets OURS and THEIRS, find common and uncommon patches. OURS and THEIRS are lists of lists of patchinfos, as returned by Added: cl-darcs/trunk/tests/gcau-tests.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/tests/gcau-tests.lisp Sun Mar 23 19:38:36 2008 @@ -0,0 +1,58 @@ +;;; 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-tests) + +(def-suite get-common-and-uncommon-suite :in darcs-suite) +(in-suite get-common-and-uncommon-suite) + +(defun gen-patchinfo () + (darcs::make-patchinfo :name (format nil "~A" (random 1000)))) + +(defmacro tri-equal (form one two three) + `(multiple-value-bind (one two three) ,form + (is (equal ,one one)) + (is (equal ,two two)) + (is (equal ,three three)))) + +(test gcau-nil + (tri-equal (darcs::get-common-and-uncommon nil nil) + nil nil nil)) + +(test gcau-only-common + (for-all ((patchinfos (gen-list :elements #'gen-patchinfo))) + (tri-equal (darcs::get-common-and-uncommon (list patchinfos) (list patchinfos)) + patchinfos nil nil))) + +(test gcau-only-ours + (for-all ((patchinfos (gen-list :elements #'gen-patchinfo))) + (tri-equal (darcs::get-common-and-uncommon (list patchinfos) nil) + nil patchinfos nil))) + +(test gcau-only-theirs + (for-all ((patchinfos (gen-list :elements #'gen-patchinfo))) + (tri-equal (darcs::get-common-and-uncommon nil (list patchinfos)) + nil nil patchinfos))) + +(test gcau-both + (for-all ((common (gen-list :elements #'gen-patchinfo)) + (only-ours (gen-list :elements #'gen-patchinfo)) + (only-theirs (gen-list :elements #'gen-patchinfo))) + (let ((ours (list (append common only-ours))) + (theirs (list (append common only-theirs)))) + (tri-equal (darcs::get-common-and-uncommon ours theirs) + common only-ours only-theirs)))) + Added: cl-darcs/trunk/tests/package.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/tests/package.lisp Sun Mar 23 19:38:36 2008 @@ -0,0 +1,24 @@ +;;; 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 + +(defpackage :darcs-tests + (:use :cl :darcs :it.bese.FiveAM)) + +(in-package :darcs-tests) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (make-suite 'darcs-suite)) +