;;; more-vc.el
;;;
;;; Copyright (C) 2007, 2008 Thien-Thi Nguyen
;;;
;;; This file is part of ttn's personal elisp library, released under
;;; the terms of the GNU General Public License as published by the
;;; Free Software Foundation; either version 3, or (at your option) any
;;; later version.  There is NO WARRANTY.  See file COPYING for details.
;;;
;;; Description: Additional version-control functionality.

;;; Plug holes.

(require 'vc-cvs)

;;;###autoload
(defun ttn-cvs-cancel-version (file editable)
  "Undo the most recent checkin of FILE then do \"cvs update\".
EDITABLE non-nil means do \"cvs edit\" afterwards."
  (unless (and (stringp vc-mode) (string= " CVS-" (substring vc-mode 0 5)))
    (error "File locally modified, aborting"))
  (let ((rev (substring vc-mode 5)))
    (vc-cvs-command nil 0 file "admin" (concat "-o" rev))
    (vc-cvs-command nil 0 file "update")
    (when editable
      (vc-cvs-command nil 0 file "edit"))))

;;;###autoload
(defun ttn-cvs-rollback (files)
  ;; Usage: (defalias 'vc-cvs-rollback 'ttn-cvs-rollback)
  "Undo the most recent checkin of FILE then do \"cvs update\"."
  (ttn-cvs-cancel-version (car files) nil))


;;; New functionality.

;;;###autoload
(defun more-vc-set-state (files state)
  "Set \"file state\" to STATE for each file in FILES.
Revert any buffers visiting those files and return them in a list.
The backend to use is determined by the first element in FILES."
  (let* ((backend (or (vc-backend (expand-file-name (car files)))
                      (error "Not under version control: %s" (car files))))
         (commands (or (get backend 'more-vc-set-state-commands)
                       (error "No %s commands to set state" backend)))
         (ls (mapconcat (lambda (name)
                          (shell-quote-argument name))
                        files " "))
         (bufs (delq nil (mapcar 'find-buffer-visiting files))))
    ;; Each element in COMMANDS has the form (SHELL-COMMAND ARGS...).
    ;; SHELL-COMMAND is a string, and ARGS... are zero or more symbols, one
    ;; of `ls', which stands for the list FILES, shell-quoted and space-
    ;; separated, as a single string; or `state', which stands for STATE.
    (with-temp-buffer
      (dolist (command commands)
        (shell-command (eval (cons 'format command)) t)))
    (dolist (buf bufs)
      (with-current-buffer buf
        (revert-buffer t t)))
    bufs))

(put 'RCS 'more-vc-set-state-commands
     '(("co -l %s" ls)
       ("ci -u -s%S -m'State now %s.' %s" state state ls)))

(put 'CVS 'more-vc-set-state-commands
     '(("cvs commit -f -m'State now %s.' %s" state ls)
       ("cvs admin -s%S %s" state ls)
       ("rm -f %s" ls)
       ("cvs update %s" ls)))

;;;###autoload
(defun more-vc-make-sure-writeable ()
  "Make sure current buffer is writeable.
Do `vc-toggle-read-only' (perhaps twice!) if not.
Make sure underlying file is writeable, as well.
But all of this is done iff `this-command' is either
`add-change-log-entry' or `add-change-log-entry-other-window'."
  (when (memq this-command '(add-change-log-entry
                             add-change-log-entry-other-window))
    (flet ((try () (when buffer-read-only
                     (vc-toggle-read-only))))
      ;; twice in case vc-update intervened
      (try) (try))
    (when (and (not buffer-read-only) buffer-file-name)
      (let ((mode (file-modes buffer-file-name)))
        (when (and mode (zerop (logand #o200 mode)))
          (set-file-modes buffer-file-name (logior #o200 mode)))))))

(defun more-vc-backend-get (property &optional filename)
  (let ((backend (vc-backend (or filename
                                 buffer-file-name
                                 (buffer-file-name vc-parent-buffer)))))
    (when backend
      (get backend property))))

;;;###autoload
(defun more-vc-pretty-up-log ()
  (buffer-disable-undo)
  (vc-exec-after (more-vc-backend-get 'more-vc-pretty-up-log-code)))

(put 'RCS 'more-vc-pretty-up-log-code
     '(let ((re (concat "\\(revision \\)\\S-+"
                        "\\(.*\ndate: \\)[^;]+"
                        "\\(;.+author: \\)[^;]+"
                        "\\(;.+state: \\)[^;]+"
                        "\\(\\(;.+lines: \\)[^;\n]+\\)*"
                        "\\(;.*\\)"))
            buffer-read-only)
        (flet ((mprop (n p v) (put-text-property (match-beginning n)
                                                 (match-end n)
                                                 p v)))

          (save-excursion
            (goto-char (point-min))
            (while (re-search-forward "^-+\n" nil t)
              (mprop 0 'display "\n\n")
              (looking-at re)
              (dolist (ent '((0 font-lock-face match)
                             (1 nil "  ")
                             (2) (3) (4) (6)
                             (7 nil "\n")))
                (let ((n (pop ent))
                      (p (or (pop ent) 'display))
                      (v (or (pop ent) "      ")))
                  (when (match-end n)
                    (mprop n p v)))))))
        (when (get-buffer-window (current-buffer))
          (recenter 0))))

(put 'CVS 'more-vc-pretty-up-log-code
     (get 'RCS 'more-vc-pretty-up-log-code))

(put 'Git 'more-vc-pretty-up-log-code
     '(let ((re (concat "\\(commit .*\nAuthor:.*<\\)[^@]+"
                        "\\(@.*\nDate: +\\).*\n"))
            buffer-read-only)
        (flet ((mprop (n p v) (put-text-property (match-beginning n)
                                                 (match-end n)
                                                 p v)))

          (save-excursion
            (goto-char (point-min))
            (while (re-search-forward re nil t)
              (mprop 0 'font-lock-face 'match)
              (mprop 1 'display "  ")
              (mprop 2 'display "             "))))
        (when (get-buffer-window (current-buffer))
          (recenter 0))))

(provide 'more-vc)

;;; more-vc.el ends here