source: cl-darcs/trunk/repo.lisp

;;; 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
;;; 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)

(defun prepare-new-repo (outname)
  "Create directories for starting a repo at OUTNAME."
  (unless (fad:directory-exists-p outname)
    (error "Directory ~A does not exist." outname))
  (let ((darcs-dir (merge-pathnames
                    (make-pathname :directory (list :relative "_darcs"))
                    outname)))
    (when (fad:directory-exists-p darcs-dir)
      ;; This error message should match the one in darcs/tests/init.pl
      (error "Do not run this command in a repository."))
    (make-dir darcs-dir)
    (dolist (dir '("patches" "checkpoints" "prefs" "inventories"))
      (make-dir (merge-pathnames
                 (make-pathname :directory (list :relative dir))
                 darcs-dir)))
    (write-inventory outname ()))
  (write-default-prefs outname))

;; {lazily,}read_repo in DarcsRepo.lhs
;; read_repo_private in DarcsRepo.lhs
(defun read-repo-patch-list (inrepodir &optional inventory-file)
  "Read patch info for INREPODIR from INVENTORY-FILE.
Return a list of lists of patchinfo structures.

Note that this function returns patchinfo structures in the order
they were applied, unlike the real darcs which often uses reverse
order."
  (when (null inventory-file)
    (setf inventory-file (upath-subdir inrepodir '("_darcs") "inventory")))
  (let (tag-patches patches)
    (with-open-stream (in (make-instance 'unreadable-stream
                                         :base-stream (open-upath inventory-file :binary t)))
      (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...
                    (read-patchinfo in))
                   (new-filename (patchinfo-make-filename tag-patch)))
              ;; ...for the first patch is a tag.  Recursively read
              ;; the inventory of that file.  The tag patch then goes
              ;; at the head of the current list of patches.
              (setf tag-patches
                    (read-repo-patch-list
                     inrepodir (upath-subdir inrepodir '("_darcs" "inventories") new-filename)))
              (setf patches (list tag-patch)))
            ;; If it's not, pretend we never read that line.
            (unread-line in first-line)))
      ;; Then, just read all patches in the file.
      (format t "~&Reading patchinfo from ~A" inventory-file)
      (setf patches
            (nconc patches
                   (loop for patch = (read-patchinfo in)
                      while patch collect patch
                      do (princ #\.)))))
    (cons patches tag-patches)))

(defun read-patch-from-repo (repodir patchinfo)
  "Read patch named by PATCHINFO from REPODIR."
  (read-patch-from-file
   (upath-subdir repodir '("_darcs" "patches") (patchinfo-make-filename patchinfo))))

(defun read-checkpoint-from-repo (repodir patchinfo)
  "Read checkpoint named by PATCHINFO from REPODIR."
  (read-patch-from-file
   (upath-subdir repodir '("_darcs" "checkpoints") (patchinfo-make-filename patchinfo))))

(defun read-checkpoint-list (repodir)
  "Read a list of checkpoints from REPODIR.
Return as a patchinfo list."
  ;; If there are no checkpoints, it doesn't matter.
  (ignore-errors
    (with-open-stream (in (open-upath (upath-subdir repodir '("_darcs" "checkpoints") "inventory")))
      (format t "~&Reading checkpoints")
      (loop for patch = (read-patchinfo in)
         while patch collect patch
         do (princ #\.)))))

(defun write-inventory (out patchinfo-list &optional file)
  "Write PATCHINFO-LIST as inventory in OUT.
FILE is either nil, meaning the main \"inventory\" file, or a
string naming a file in the \"inventories\" directory."
  ;; XXX: slightly_optimize_patchset?
  (let ((inventory-file (cond
                          ((null file)
                           (merge-pathnames
                            (make-pathname :directory '(:relative "_darcs")
                                           :name "inventory")
                            out))
                          (t
                           (merge-pathnames
                            (make-pathname :directory '(:relative "_darcs" "inventories")
                                           :name file)
                            out)))))
    (with-open-file (f inventory-file :direction :output :if-exists :supersede
                       :element-type '(unsigned-byte 8))
      (flet ((print-patchinfos (patchinfos)
               ;; Convert output to binary, using the most direct possible
               ;; method...
               (dolist (patchinfo patchinfos)
                 (map nil (lambda (char)
                            (write-byte (char-code char) f))
                      (with-output-to-string (strout)
                        (write-patchinfo patchinfo strout)))
                 (write-byte 10 f))))
        (cond
          ((null patchinfo-list)
           ;; No patches - empty inventory file.  Nothing to do.
           )
          ((null (cdr patchinfo-list))
           ;; One patch list - no remaining tags.

           (print-patchinfos (car patchinfo-list)))
          (t
           ;; Several patch lists, one for each tag
           (let* ((this-tag (car patchinfo-list))
                  (other-tags (cdr patchinfo-list))
                  (tag-name (patchinfo-make-filename (car this-tag))))
             (write-inventory out other-tags tag-name)
             (write-sequence (map 'vector #'char-code "Starting with tag:") f)
             (write-byte 10 f)
             (print-patchinfos (car patchinfo-list)))))))))

(defun append-inventory (outrepo patchinfo)
  "Append PATCHINFO to inventory in OUTREPO."
  (with-open-file (f (merge-pathnames 
                      (make-pathname :directory '(:relative "_darcs")
                                     :name "inventory")
                      outrepo)
                     :direction :output
                     :if-exists :append
                     :if-does-not-exist :create
                     :element-type '(unsigned-byte 8))
    (map nil (lambda (char)
               (write-byte (char-code char) f))
         (with-output-to-string (strout)
           (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
`read-repo-patch-list'.  Three values are returned: a list of
patchinfos that appear in both sets, a list of patchinfos that
appear only in OURS, and a list of patchinfos that appear only in
THEIRS."
  ;; Of course, there are possible optimizations here, in particular
  ;; regarding tags, but this will do for now.
  (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)))