/dvc/mode/lisp/dvc-core.el

;;; dvc-core.el --- Core functions for distributed version control

;; Copyright (C) 2005-2009 by all contributors

;; Author: Stefan Reichoer, <stefan@xsteve.at>
;; Contributions From:
;;         Matthieu Moy <Matthieu.Moy@imag.fr>

;; This file 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 3, or (at your option)
;; any later version.

;; This file 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 GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; This file provides the low-level functions used by the DVC interfaces
;; to distributed revison control systems.


;;; History:

;; This file holds general useful functions, previously only used for tla.

;;; Code:

(require 'dvc-defs)
(require 'dvc-register)
(eval-and-compile (require 'dvc-utils))
(require 'dvc-buffers)
(eval-when-compile (require 'cl))
(eval-when-compile (require 'dired))
(eval-and-compile (require 'dvc-lisp))

(defvar dvc-sh-executable "sh" "The shell that is used for dvc interaction.")

;; --------------------------------------------------------------------------------
;; Various constants
;; --------------------------------------------------------------------------------

(defconst dvc-mark (dvc-face-add "*" 'dvc-mark) "Fontified string used for marking.")
(defconst dvc-exclude (dvc-face-add "E" 'dvc-mark) "Fontified string used for excluded files.")

;; --------------------------------------------------------------------------------
;; Internal variables
;; --------------------------------------------------------------------------------

(defvar dvc-memorized-log-header nil)
(defvar dvc-memorized-log-message nil)
(defvar dvc-memorized-version nil)
(defvar dvc-memorized-patch-sender nil)

;; --------------------------------------------------------------------------------
;; Various helper functions
;; --------------------------------------------------------------------------------

;; list-buffers-directory is used by uniquify to get the directory for
;; the buffer when buffer-file-name is nil, as it is for many dvc
;; buffers (dvc-diff-mode, etc). It needs to survive
;; kill-all-local-variables, so we declare it permanent local.
(make-variable-buffer-local 'list-buffers-directory)
(put 'list-buffers-directory 'permanent-local t)

(defun dvc-find-tree-root-file-first (file-or-dir &optional location)
  "Find FILE-OR-DIR upward in the file system from LOCATION.
Finding is continued upward to \"/\" until FILE-OR-DIR can be found.
Once FILE-OR-DIR is found, the finding is broken off.
A directory which holds FILE-OR-DIR is returned. If no such directory
`nil' is returned. `default-directory' is used instead if LOCATION is not
given,

The resulting directory is guaranteed to end in a \"/\" character.

This function may be useful to find \{arch\} and/or _darcs directories."
  (let ((pwd (or location default-directory))
        (pwd-stack nil)
        new-pwd)
    (while (not (or (string= pwd "/")
                    (member pwd pwd-stack)
                    (file-exists-p (concat (file-name-as-directory pwd)
                                           file-or-dir))))
      (setq pwd-stack (cons pwd pwd-stack))
      (setq new-pwd
            (dvc-expand-file-name (concat (file-name-as-directory pwd) "..")))

      ;; detect MS-Windows roots (c:/, d:/, ...)
      (setq pwd (if (string= new-pwd pwd) "/" new-pwd)))

    (unless (string= pwd "/")
      (setq pwd (replace-regexp-in-string "\\([^:]\\)/*$" "\\1" pwd))
      (setq pwd (file-name-as-directory pwd))
      (if (memq system-type '(ms-dos windows-nt))
          (expand-file-name pwd)
        pwd))))

(defun dvc-tree-root-helper (file-or-dir interactivep msg
                                         &optional location no-error)
  "Find FILE-OR-DIR upward in the file system from LOCATION.

Calls `dvc-find-tree-root-file-first', shows a message when
called interactively, and manages no-error.

If LOCATION is nil, the tree root is returned, and it is
guaranteed to end in a \"/\" character.

MSG must be of the form \"%S is not a ...-managed tree\"."
  (let ((location (dvc-uniquify-file-name location)))
    (let ((pwd (dvc-find-tree-root-file-first
                file-or-dir location)))
      (when (and interactivep pwd)
        (dvc-trace "%s" pwd))
      (or pwd
          (if no-error
              nil
            (error msg
                   (or location default-directory)))))))

(defun dvc-find-tree-root-file-last (file-or-dir &optional location)
  "Like `dvc-find-tree-root-file-upward' but recursively if FILE-OR-DIR is found.
Finding is started from LOCATION but is stoped when FILE-OR-DIR cannot be found.
Fiddled is continued upward while FILE-OR-DIR can be found.
The last found directory which holds FILE-OR-DIR is returned. `nil' is returned
if finding failed.
`default-directory' is used instead if LOCATION is not given,

This function may be useful to find CVS or .svn directories"
  (let ((pwd (or location default-directory))
        old-pwd)
    (while (and pwd (not (string= pwd "/")))
      (if (file-exists-p (concat (file-name-as-directory pwd)
                                 file-or-dir))
          (setq old-pwd pwd
                pwd (expand-file-name (concat (file-name-as-directory pwd)
                                              "..")))
        (setq pwd nil)))
    (when old-pwd
      (expand-file-name
       (replace-regexp-in-string "/+$" "/" old-pwd)))))

(defmacro dvc-make-bymouse-function (function)
  "Create a new function by adding mouse interface to FUNCTION.
The new function is named FUNCTION-by-mouse; and takes one argument,
a mouse click event.
Thew new function moves the point to the place where mouse is clicked
then invoke FUNCTION."
  (declare (debug (&define name :name -by-mouse)))
  `(defun ,(intern (concat (symbol-name function) "-by-mouse")) (event)
     ,(concat "`" (symbol-name function) "'" " with mouse interface.")
     (interactive "e")
     (mouse-set-point event)
     (,function)))

;; Adapted from `dired-delete-file' in Emacs 22
(defun dvc-delete-recursively (file)
  "Delete FILE or directory recursively."
  (let (files)
    (if (not (eq t (car (file-attributes file))))
        (delete-file file)
      (when (setq files
                  (directory-files
                   file t "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))
        (while files
          (dvc-delete-recursively (car files))
          (setq files (cdr files))))
      (delete-directory file))))

;; --------------------------------------------------------------------------------
;; File selection helpers
;; --------------------------------------------------------------------------------

(defvar dvc-get-file-info-at-point-function nil
  "Function used to get the file at point, anywhere.")

(defun dvc-get-file-info-at-point ()
  "Gets the filename at point, according to mode.
Calls the function `dvc-get-file-info-at-point-function' if defined.
When in dired mode, return the file where point is.
Otherwise return the buffer file name."
  (cond (dvc-get-file-info-at-point-function
         (funcall dvc-get-file-info-at-point-function))
        ((eq major-mode 'dired-mode)
         (dired-get-filename))
        (t (buffer-file-name))))

;;;###autoload
(defun dvc-current-file-list (&optional selection-mode)
  "Return a list of currently active files.
When in dired mode, return the marked files or the file under point.
In a legacy DVC mode, return `dvc-buffer-marked-file-list' if non-nil.
In a fileinfo DVC mode, return `dvc-fileinfo-marked-files'.
otherwise the result depends on SELECTION-MODE:
* When 'nil-if-none-marked, return nil.
* When 'all-if-none-marked, return all files.
* Otherwise return result of calling `dvc-get-file-info-at-point'."
  (cond
   ((eq major-mode 'dired-mode)
    (dired-get-marked-files))

   ((dvc-derived-mode-p 'dvc-diff-mode 'dvc-status-mode)
    (or (remove nil dvc-buffer-marked-file-list)
        (dvc-fileinfo-marked-files)
        (cond
         ((eq selection-mode 'nil-if-none-marked)
          nil)

         ((eq selection-mode 'all-if-none-marked)
          (dvc-fileinfo-all-files))

         (t (list (dvc-get-file-info-at-point))))))

   ((eq major-mode 'dvc-bookmark-mode)
    (cond
     ((eq selection-mode 'nil-if-none-marked)
      nil)

     (t
      (error "selection-mode %s not implemented for dvc bookmark buffer" selection-mode))))

   ;; If other modes are added here, dvc-log-edit must be updated to
   ;; support them as well.

   (t
    ;; Some other mode. We assume it has no notion of "marked files",
    ;; so there are none marked. The only file name available is
    ;; buffer-file-name, so we could just return that. But some DVC
    ;; mode might set dvc-get-file-info-at-point-function without
    ;; updating this function, so support that.
    (if (eq selection-mode 'nil-if-none-marked)
        nil
      (list (dvc-get-file-info-at-point))))))

(defun dvc-confirm-read-file-name (prompt &optional mustmatch file-name default-filename)
  "A wrapper around `read-file-name' that provides some useful defaults."
  (unless file-name
    (setq file-name (dvc-get-file-info-at-point)))
  (read-file-name prompt
                  (file-name-directory (or file-name ""))
                  default-filename
                  mustmatch
                  (file-name-nondirectory (or file-name ""))))

(defun dvc-confirm-read-file-name-list (prompt &optional files single-prompt mustmatch)
  (or
   (if dvc-test-mode files)
   (let ((num-files (length files)))
     (if (= num-files 1)
         (let ((confirmed-file-name
                (dvc-confirm-read-file-name single-prompt mustmatch (car files))))
           ;; I don't think `dvc-confirm-read-file-name' can return nil.
           (assert confirmed-file-name)
           (list confirmed-file-name))
       (and (y-or-n-p (format prompt num-files))
            files)))))

(defcustom dvc-confirm-file-op-method 'y-or-n-p
  "Function to use for confirming file-based DVC operations.
Some valid options are:
y-or-n-p: Prompt for 'y' or 'n' keystroke.
yes-or-no-p: Prompt for \"yes\" or \"no\" string.
dvc-always-true: Do not display a prompt."
  :type 'function
  :group 'dvc)

(defun dvc-always-true (&rest ignore)
  "Do nothing and return t.
This function accepts any number of arguments, but ignores them."
  (interactive)
  t)

(defun dvc-confirm-file-op (operation files confirm)
  "Confirm OPERATION (a string, used in prompt) on FILE (list of strings).
If CONFIRM is nil, just return FILES (no prompt).
Returns FILES, or nil if not confirmed.

If you want to adjust the function called to confirm the
operation, then customize the `dvc-confirm-file-op-method' function."
  (or
   ;; Allow bypassing confirmation with `dvc-test-mode'. See
   ;; tests/xmtn-tests.el dvc-status-add.
   (if dvc-test-mode files)
   ;; Abstracted from pcvs.el cvs-do-removal
   (if (not confirm)
       files
     (let ((nfiles (length files)))
       (if (funcall (or (and (functionp dvc-confirm-file-op-method)
                             dvc-confirm-file-op-method)
                        'y-or-n-p)
                    (if (= 1 nfiles)
                        (format "%s file: \"%s\" ? "
                                operation
                                (car files))
                      (format "%s %d files? "
                              operation
                              nfiles)))
           files
         nil)))))

(defun dvc-dvc-files-to-commit ()
  ;;todo: set the correct modifier, one of dvc-modified, dvc-added, dvc-move, now use only nil
  ;; FIXME: this is only used by dvc-log-insert-commit-file-list; should just merge this code there.
  (let ((files
         (with-current-buffer dvc-partner-buffer (dvc-current-file-list 'all-if-none-marked))))
    (mapcar (lambda (arg) (cons nil arg)) files)))

(defun dvc-find-file-at-point ()
  "Opens the file at point.
The filename is obtained with `dvc-get-file-info-at-point'."
  (interactive)
  (let* ((file (dvc-get-file-info-at-point)))
    (cond
     ((not file)
      (error "No file at point"))
     (t
      (find-file file)))))

(dvc-make-bymouse-function dvc-find-file-at-point)

(defun dvc-find-file-other-window ()
  "Visit the current file in the other window.
The filename is obtained with `dvc-get-file-info-at-point'."
  (interactive)
  (let ((file (dvc-get-file-info-at-point)))
    (if file
        (progn
          (find-file-other-window file))
      (error "No file at point"))))

(defun dvc-view-file ()
  "Visit the current file in `view-mode'.
The filename is obtained with `dvc-get-file-info-at-point'."
  (interactive)
  (let ((file (dvc-get-file-info-at-point)))
    (if file
        (view-file-other-window file)
      (error "No file at point"))))

(defun dvc-dired-jump ()
  "Jump to a dired buffer, containing the file at point."
  (interactive)
  (let ((file-full-path (expand-file-name (or (dvc-get-file-info-at-point) ""))))
    (let ((default-directory (file-name-directory file-full-path)))
      (dvc-funcall-if-exists dired-jump))
    (dired-goto-file file-full-path)))

(defun dvc-purge-files (&rest files)
  "Delete FILES from the harddisk. No backup is created for these FILES.
These function bypasses the used revision control system."
  (interactive (dvc-current-file-list))
  (let ((multiprompt (format "Are you sure to purge %%d files? "))
        (singleprompt (format "Purge file: ")))
    (when (dvc-confirm-read-file-name-list multiprompt files singleprompt nil)
      (mapcar #'delete-file files)
      (message "Purged %S" files))))

(defun dvc-current-executable ()
  "Return the name of the binary associated with the current dvc backend.
This uses `dvc-current-active-dvc'.

\"DVC\" is returned if `dvc-current-active-dvc' returns nil."
  (let ((dvc (dvc-current-active-dvc)))
    (if (not dvc)
        "DVC"
      (dvc-variable dvc "executable"))))

;; partner buffer stuff
(defvar dvc-partner-buffer nil
  "DVC Partner buffer; stores diff buffer for log-edit, etc.
Local to each buffer, not killed by kill-all-local-variables.")
(make-variable-buffer-local 'dvc-partner-buffer)
(put 'dvc-partner-buffer 'permanent-local t)

(defun dvc-buffer-pop-to-partner-buffer ()
  "Pop to dvc-partner-buffer, if available."
  (interactive)
  (if (and (boundp 'dvc-partner-buffer) dvc-partner-buffer)
      (if (buffer-live-p dvc-partner-buffer)
          (pop-to-buffer dvc-partner-buffer)
        (message "Partner buffer has been killed"))
    (message "No partner buffer set for this buffer.")))


(defmacro dvc-with-keywords (keywords plist &rest body)
  "Execute a body of code with keywords bound.
Each keyword listed in KEYWORDS is bound to its value from PLIST, then
BODY is evaluated."
  (declare (indent 1) (debug (sexp form body)))
  (flet ((keyword-to-symbol (keyword)
                            (intern (substring (symbol-name keyword) 1))))
    (let ((keyword (make-symbol "keyword"))
          (default (make-symbol "default")))
      `(let ,(mapcar (lambda (keyword-entry)
                       (keyword-to-symbol (if (consp keyword-entry)
                                              (car keyword-entry)
                                            keyword-entry)))
                     keywords)
         (dolist (keyword-entry ',keywords)
           (let ((,keyword (if (consp keyword-entry)
                               (car keyword-entry)
                             keyword-entry))
                 (,default (if (consp keyword-entry)
                               (cadr keyword-entry)
                             nil)))
             (set (intern (substring (symbol-name ,keyword) 1))
                  (or (cadr (member ,keyword ,plist))
                      ,default))))
         ,@body))))


;; ----------------------------------------------------------------------------
;; Process management
;; ----------------------------------------------------------------------------

;; Candidates for process handlers
(defun dvc-default-error-function (output error status arguments)
  "Default function called when a DVC process ends with a non-zero status.
OUTPUT is the buffer containing process standard output.
ERROR is the buffer containing process error output.
STATUS indicates the return status of the program.
ARGUMENTS is a list of the arguments that the process was called with."
  (if (> (with-current-buffer error (point-max)) 1)
      (dvc-show-error-buffer error)
    (if (> (with-current-buffer output (point-max)) 1)
        (dvc-show-error-buffer output)
      (error "`%s %s' failed with code %d and no output!"
             (dvc-current-executable)
             (mapconcat 'identity arguments " ")
             status)))
  (error "`%s %s' failed with code %d"
         (dvc-current-executable)
         (mapconcat 'identity arguments " ")
         status))

(defvar dvc-default-killed-function-noerror 0
  "The number of killed processes we will ignore until throwing an error.
If the value is 0, `dvc-default-killed-function' will throw an error.
See `dvc-default-killed-function'.")

(defun dvc-default-killed-function (output error status arguments)
  "Default function called when a DVC process is killed.
OUTPUT is the buffer containing process standard output.
ERROR is the buffer containing process error output.
STATUS indicates the return status of the program.
ARGUMENTS is a list of the arguments that the process was called with."
  (if (> dvc-default-killed-function-noerror 0)
      (setq dvc-default-killed-function-noerror
            (- dvc-default-killed-function-noerror 1))
    (dvc-switch-to-buffer error)
    (error "`%s %s' process killed !"
           (dvc-current-executable)
           (mapconcat 'identity arguments " "))))

(defun dvc-null-handler (output error status arguments)
  "Handle a finished process without doing anything.
Candidate as an argument for one of the keywords :finished, :error or :killed
in `dvc-run-dvc-sync' or `dvc-run-dvc-async'.
OUTPUT is the buffer containing process standard output.
ERROR is the buffer containing process error output.
STATUS indicates the return status of the program.
ARGUMENTS is a list of the arguments that the process was called with."
  nil)

(defun dvc-status-handler (output error status arguments)
  "Return an integer value that reflects the process status.
Candidate as an argument for one of the keywords :finished, :error or :killed
in `dvc-run-dvc-sync' or `dvc-run-dvc-async'.
OUTPUT is the buffer containing process standard output.
ERROR is the buffer containing process error output.
STATUS indicates the return status of the program.
ARGUMENTS is a list of the arguments that the process was called with."
  (cond ((numberp status) status)
        ((string-match "^exited abnormally with code \\(.*\\)" status)
         (string-to-number (match-string 1)))
        (t (error status))))

(defun dvc-output-buffer-handler (output error status arguments)
  "Return the output of a finished process, stripping any trailing newline.
OUTPUT is the buffer containing process standard output.
ERROR is the buffer containing process error output.
STATUS indicates the return status of the program.
ARGUMENTS is a list of the arguments that the process was called with."
  (dvc-buffer-content output))

(defun dvc-output-buffer-handler-withnewline (output error status arguments)
  "Same as dvc-output-buffer-handler, but keep potential final newline."
  (with-current-buffer output (buffer-string)))

(defun dvc-output-and-error-buffer-handler (output error status arguments)
  "Return the output of a finished process, stripping any trailing newline.
OUTPUT is the buffer containing process standard output.
ERROR is the buffer containing process error output.
STATUS indicates the return status of the program.
ARGUMENTS is a list of the arguments that the process was called with."
  (concat (dvc-buffer-content output)
          (dvc-buffer-content error)))

(defun dvc-output-buffer-split-handler (output error status arguments)
  "Return the output of a finished process as a list of lines.
OUTPUT is the buffer containing process standard output.
ERROR is the buffer containing process error output.
STATUS indicates the return status of the program.
ARGUMENTS is a list of the arguments that the process was called with."
  (split-string (dvc-buffer-content output) "\n"))

(defun dvc-default-finish-function (output error status arguments)
  "Default function called when a DVC process terminates.
OUTPUT is the buffer containing process standard output.
ERROR is the buffer containing process error output.
STATUS indicates the return status of the program.
ARGUMENTS is a list of the arguments that the process was called with."
  (let ((has-output))
    (with-current-buffer output
      (dvc-process-buffer-mode)
      (setq has-output (> (point-max) 1)))
    (when has-output
      (dvc-switch-to-buffer output))
    (when (or dvc-debug has-output)
      (message "Process `%s %s' finished"
               (dvc-current-executable)
               (mapconcat 'identity arguments " ")))
    status))

(defun dvc-finish-function-without-buffer-switch (output error status arguments)
  "Similar to `dvc-default-finish-function' but no buffer switch.
OUTPUT is the buffer containing process standard output.
ERROR is the buffer containing process error output.
STATUS indicates the return status of the program.
ARGUMENTS is a list of the arguments that the process was called
  with."
  (with-current-buffer output
    (dvc-trace "Process `%s %s' finished"
               (dvc-current-executable)
               (mapconcat 'identity arguments " "))
    status))

(defvar dvc-process-running nil
  "List of DVC processes running.
A value of nil indicates no processes are running.

The list is a list of pairs (process event) where EVENT is the event
corresponding to the beginning of the execution of process.  It can be
used to get more info about the process.")

(defun dvc-build-dvc-command (dvc list-args)
  "Build a shell command to run DVC with args LIST-ARGS.
DVC can be one of 'baz, 'xhg, ..."
  (let ((executable (executable-find (dvc-variable dvc "executable"))))
    ;; 'executable-find' allows leading ~
    (if (not executable)
        (error "executable for %s not found" (symbol-name dvc)))
    (mapconcat 'shell-quote-argument
               (cons executable
                     (remq nil list-args))
               " ")))

(defcustom dvc-password-prompt-regexp
  "[Pp]ass\\(word\\|phrase\\).*:\\s *\\'"
  "*Regexp matching prompts for passwords in the inferior process."
  :type 'regexp
  :group 'dvc)

(defun dvc-process-filter (proc string &optional no-insert)
  "Filter PROC's STRING.
Prompt for password with `read-passwd' if the output of PROC matches
`dvc-password-prompt-regexp'.

If NO-INSERT is non-nil, do not insert the string.

In all cases, a new string is returned after normalizing newlines."
  (with-current-buffer (process-buffer proc)
    (setq string (replace-regexp-in-string "\015" "\n" string))
    (unless no-insert
      (goto-char (process-mark proc))
      (insert string)
      (set-marker (process-mark proc) (point)))
    (when (string-match dvc-password-prompt-regexp string)
      (string-match "^\\([^\n]+\\)\n*\\'" string)
      (let ((passwd (read-passwd (match-string 1 string))))
        (process-send-string proc (concat passwd "\n"))))
    string))

(defun dvc-prepare-environment (env)
  "By default, do not touch the environment"
  env)

(defun dvc-default-global-argument ()
  "By default, no global argument."
  nil)

(defun dvc-run-dvc-async (dvc arguments &rest keys)
  "Run a process asynchronously.
Current directory for the process is the current `default-directory'.
ARGUMENTS is a list of arguments.  nil values in this list are removed.
KEYS is a list of keywords and values.  Possible keywords are:

 :finished ....... Function run when the process finishes.  If none
                   specified, `dvc-default-finish-function' is run.

 :killed ......... Function run when the process is killed.  If none
                   specified, `dvc-default-killed-function' is run.

 :error .......... Function run when the process exits with a non 0
                   status.  If none specified,
                   `dvc-default-error-function' is run.

All these functions take 4 arguments : output, error, status, and
arguments.

   - \"output\" is the output buffer
   - \"error\" is the buffer where standard error is redirected
   - \"status\" is the numeric exit-status or the signal number
   - \"arguments\" is the list of arguments, as a list of strings,
              like '(\"changes\" \"--diffs\")

   `dvc-null-handler' can be used here if there's nothing to do.

 :filter           Function to call every time we receive output from
                   the process.  It should take arguments proc and string.
                   The string will have been run through
                   `dvc-process-filter' to deal with password prompts and
                   newlines.

 :output-buffer .. Buffer where the output of the process should be
                   redirected.  If none specified, a new one is
                   created, and will be entered in
                   `dvc-dead-process-buffer-queue' to be killed
                   later.

 :error-buffer ... Buffer where the standard error of the process
                   should be redirected.

 :related-buffer . Defaults to `current-buffer'.  This is the buffer
                   where the result of the process will be used.  If
                   this buffer is killed before the end of the
                   execution, the user is prompted if he wants to kill
                   the process."
  (dvc-with-keywords
      (:finished :killed :error :filter
                 :output-buffer :error-buffer :related-buffer)
    keys
    (let* ((output-buf (or (and output-buffer
                                (get-buffer-create output-buffer))
                           (dvc-new-process-buffer nil dvc)))
           (error-buf  (or (and error-buffer (get-buffer-create error-buffer))
                           (dvc-new-error-buffer nil dvc)))
           (error-file (dvc-make-temp-name "dvc-errors"))
           (global-arg (funcall (dvc-function dvc "default-global-argument")))
           (command (dvc-build-dvc-command
                     dvc (append global-arg arguments)))
           ;; Make the `default-directory' unique. The trailing slash
           ;; may be necessary in some cases.
           (default-directory (dvc-uniquify-file-name default-directory))
           (process
            (let ((process-environment
                   (funcall (dvc-function dvc "prepare-environment")
                            process-environment)))
              (with-current-buffer output-buf
                ;; process filter will need to know which dvc to run
                ;; if there is a choice
                (setq dvc-buffer-current-active-dvc dvc))

              ;; `start-process' sends both stderr and stdout to
              ;; `output-buf'. But we want to keep stderr separate. So
              ;; we use a shell to redirect stderr before Emacs sees
              ;; it. Note that this means we require "sh" even on
              ;; MS Windows.
              (start-process
               (dvc-variable dvc "executable") output-buf
               dvc-sh-executable "-c"
               (format "%s 2> %s"
                       command error-file))))
           (process-event
            (list process
                  (dvc-log-event output-buf
                                 error-buf
                                 command
                                 default-directory "started"))))
      (with-current-buffer (or related-buffer (current-buffer))
        (dvc-trace "Running process `%s' in `%s'" command default-directory)
        (add-to-list 'dvc-process-running process-event)
        (set-process-filter
         process
         (if (not filter)
             'dvc-process-filter
           (dvc-capturing-lambda (proc string)
             (funcall (capture filter)
                      proc
                      (dvc-process-filter proc string t)))))
        (set-process-sentinel
         process
         (dvc-capturing-lambda (process event)
           (let ((default-directory (capture default-directory)))
             (dvc-log-event (capture output-buf) (capture error-buf)
                            (capture command)
                            (capture default-directory)
                            (dvc-strip-final-newline event))
             (setq dvc-process-running
                   (delq (capture process-event) dvc-process-running))
             (when (file-exists-p (capture error-file))
               (with-current-buffer (capture error-buf)
                 (insert-file-contents (capture error-file)))
               (delete-file (capture error-file)))
             (let ((state (process-status process))
                   (status (process-exit-status process))
                   (dvc-temp-current-active-dvc (capture dvc)))
               (unwind-protect
                   (cond ((and (eq state 'exit) (= status 0))
                          (funcall (or (capture finished)
                                       'dvc-default-finish-function)
                                   (capture output-buf) (capture error-buf)
                                   status (capture arguments)))
                         ((eq state 'signal)
                          (funcall (or (capture killed)
                                       'dvc-default-killed-function)
                                   (capture output-buf) (capture error-buf)
                                   status (capture arguments)))
                         ((eq state 'exit) ;; status != 0
                          (funcall (or (capture error)
                                       'dvc-default-error-function)
                                   (capture output-buf) (capture error-buf)
                                   status (capture arguments)))))
               ;; Schedule any buffers we created for killing
               (unless (capture output-buffer)
                 (dvc-kill-process-buffer (capture output-buf)))
               (unless (capture error-buffer)
                 (dvc-kill-process-buffer (capture error-buf)))))))
        process))))

(defun dvc-run-dvc-sync (dvc arguments &rest keys)
  "Run DVC synchronously.
See `dvc-run-dvc-async' for details on possible ARGUMENTS and KEYS."
  (dvc-with-keywords
      (:finished :killed :error :output-buffer :error-buffer :related-buffer)
    keys
    (let* ((output-buf (or (and output-buffer
                                (get-buffer-create output-buffer))
                           (dvc-new-process-buffer t dvc)))
           (error-buf  (or (and error-buffer (get-buffer-create error-buffer))
                           (dvc-new-error-buffer t dvc)))
           (global-arg (funcall (dvc-function dvc "default-global-argument")))
           (command (dvc-build-dvc-command
                     dvc (append global-arg arguments)))
           (arguments (remq nil arguments))
           (error-file (dvc-make-temp-name "arch-errors"))
           ;; Make the `default-directory' unique. The trailing slash
           ;; may be necessary in some cases.
           (default-directory (dvc-uniquify-file-name default-directory)))
      (with-current-buffer (or related-buffer (current-buffer))
        (dvc-log-event output-buf error-buf command default-directory
                       "started")
        (let ((status (let ((process-environment
                             (funcall (dvc-function dvc "prepare-environment")
                                      process-environment)))
                        (call-process dvc-sh-executable nil output-buf nil "-c"
                                      (format "%s 2> %s"
                                              command
                                              error-file)))))
          (when (file-exists-p error-file)
            (with-current-buffer error-buf
              (insert-file-contents error-file))
            (delete-file error-file))
          (unwind-protect
              (let ((dvc-temp-current-active-dvc dvc))
                (cond ((stringp status)
                       (when (string= status "Terminated")
                         (funcall (or killed 'dvc-default-killed-function)
                                  output-buf error-buf status arguments)))
                      ((numberp status)
                       (if (zerop status)
                           (funcall (or finished 'dvc-default-finish-function)
                                    output-buf error-buf status arguments)
                         (funcall (or error 'dvc-default-error-function)
                                  output-buf error-buf status arguments)))
                      (t (message "Unknown status - %s" status))))
            ;; Schedule any buffers we created for killing
            (unless output-buffer (dvc-kill-process-buffer output-buf))
            (unless error-buffer (dvc-kill-process-buffer error-buf))))))))

(defun dvc-processes-related-to-buffer (buffer)
  "Returns a list of DVC process whose related buffer is BUFFER."
  (let ((accu nil))
    (dolist (entry dvc-process-running)
      (when (eq (dvc-event-related-buffer (cadr entry)) buffer)
        (push (car entry) accu)))
    (setq accu (nreverse accu))
    accu))

(defun dvc-kill-process-maybe (buffer)
  "Prompts and possibly kill process whose related buffer is BUFFER."
  ;; FIXME: It would be reasonable to run this here, to give any
  ;;  process one last chance to run. But somehow this screws up
  ;;  package-maint-clean-some-elc. (accept-process-output)
  (let* ((processes (dvc-processes-related-to-buffer buffer))
         (l (length processes)))
    (when (and processes
               (y-or-n-p (format "%s process%s running in buffer %s.  Kill %s? "
                                 l (if (= l 1) "" "es")
                                 (buffer-name buffer)
                                 (if (= l 1) "it" "them"))))
      (dolist (process processes)
        (when (eq (process-status process) 'run)
          (incf dvc-default-killed-function-noerror)
          (kill-process process)))))
  ;; make sure it worked
  (let ((processes (dvc-processes-related-to-buffer buffer)))
    (when processes
      (error "Process still running in buffer %s" buffer))))

(add-hook 'kill-buffer-hook 'dvc-kill-buffer-function)

(defun dvc-kill-buffer-function ()
  "Function run when a buffer is killed."
  (dvc-buffers-tree-remove (current-buffer))
  (dvc-kill-process-maybe (current-buffer)))

(defun dvc-run-dvc-display-as-info (dvc arg-list &optional show-error-buffer info-string asynchron)
  "Call either `dvc-run-dvc-async' or `dvc-run-dvc-sync' and display the result in an info buffer.
When INFO-STRING is given, insert it at the buffer beginning."
  (let ((buffer (dvc-get-buffer-create dvc 'info)))
    (funcall (if asynchron 'dvc-run-dvc-async 'dvc-run-dvc-sync) dvc arg-list
             :finished
             (dvc-capturing-lambda (output error status arguments)
               (progn
                 (with-current-buffer (capture buffer)
                   (let ((inhibit-read-only t))
                     (erase-buffer)
                     (dvc-info-buffer-mode)
                     (when (capture info-string)
                       (insert (capture info-string)))
                     (insert-buffer-substring output)
                     (when (capture show-error-buffer)
                       (insert-buffer-substring error))
                     (toggle-read-only 1)))
                 (dvc-switch-to-buffer (capture buffer)))))))

(defvar dvc-info-buffer-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (dvc-prefix-buffer ?L) 'dvc-open-internal-log-buffer)
    (define-key map dvc-keyvec-quit 'dvc-buffer-quit)
    map)
  "Keymap used in a dvc info buffer.")

(define-derived-mode dvc-info-buffer-mode fundamental-mode
  "DVC info mode"
  "Major mode for dvc info buffers"
  (dvc-install-buffer-menu)
  (toggle-read-only 1))


(defvar dvc-log-cookie nil)

(defstruct (dvc-event) output-buffer error-buffer related-buffer
  command tree event time)

(defsubst dvc-log-printer-print-buffer (buffer function)
  "Helper function for `dvc-log-printer'.
Print a buffer filed for BUFFER during printing a log event.
The printed name of BUFFER is mouse sensitive.  If the user
clicks it, FUNCTION is invoked."
  (let ((alive-p (buffer-live-p buffer))
        map)
    (dvc-face-add
     (or
      ;; pp-to-string is very costly.
      ;; Handle the typical case with hard-coding.
      (unless alive-p "#<killed buffer>")
      ;; Normal case.
      (buffer-name buffer)
      ;; Extra case.
      (pp-to-string buffer))
     'dvc-buffer
     (when alive-p
       (setq map (make-sparse-keymap))
       (define-key map [mouse-2] function)
       map)
     nil
     "Show the buffer")))

(defun dvc-log-recently-p (elem limit-minute)
  "Check ELEM recorded a recent event or not.
Return nil If ELEM recorded an event older than LIMIT-MINUTE.
Else return t."
  (let* ((recorded (dvc-event-time elem))
         (cur      (current-time))
         (diff-minute (/ (+ (* 65536 (- (nth 0 cur)
                                        (nth 0 recorded)))
                            (- (nth 1 cur)
                               (nth 1 recorded)))
                         60)))
    (if (> limit-minute diff-minute)
        t
      nil)))

(defun dvc-log-printer (elem)
  "Arch event printer which prints ELEM."
  (let ((event (dvc-event-event elem))
        (p (point)))
    (insert
     "Command: " (dvc-event-command elem)
     "\nDirectory: " (dvc-face-add (or (dvc-event-tree elem) "(nil)")
                                   'dvc-local-directory)
     "\nDate: " (format-time-string "%c" (dvc-event-time elem))
     "\nRelated Buffer: " (dvc-log-printer-print-buffer
                           (dvc-event-related-buffer elem)
                           'dvc-switch-to-related-buffer-by-mouse)
     "\nOutput Buffer: "  (dvc-log-printer-print-buffer
                           (dvc-event-output-buffer elem)
                           'dvc-switch-to-output-buffer-by-mouse)
     "\nError Buffer: "   (dvc-log-printer-print-buffer
                           (dvc-event-error-buffer elem)
                           'dvc-switch-to-error-buffer-by-mouse)
     (if (not (string= event "started"))
         (concat "\nEvent: " event)
       "")
     "\n")
    ;; Reflect the point to `default-directory'.
    ;; NOTE: XEmacs doesn't have `point-entered' special text property.
    (put-text-property
     p (point)
     'point-entered (lambda (old new)
                      (setq default-directory
                            (dvc-event-tree
                             (ewoc-data
                              (ewoc-locate dvc-log-cookie))))))))

(defmacro dvc-switch-to-buffer-macro (function accessor)
  "Define a FUNCTION for switching to the buffer associated with some event.
ACCESSOR is a function for retrieving the appropriate buffer from a
`dvc-event' structure."
  (declare (debug (&define name symbolp)))
  `(defun ,function ()
     "In a log buffer, pops to the output or error buffer corresponding to the
process at point"
     (interactive)
     (let ((buffer (,accessor
                    (ewoc-data (ewoc-locate dvc-log-cookie)))))
       (cond ((buffer-live-p buffer)
              (dvc-switch-to-buffer buffer)
              (unless (member buffer
                              (mapcar (lambda (p)
                                        (process-buffer (car p)))
                                      dvc-process-running))
                (dvc-process-buffer-mode)))
             (t (error "Buffer has been killed"))))))

(dvc-switch-to-buffer-macro dvc-switch-to-output-buffer
                            dvc-event-output-buffer)

(dvc-switch-to-buffer-macro dvc-switch-to-error-buffer
                            dvc-event-error-buffer)

(dvc-switch-to-buffer-macro dvc-switch-to-related-buffer
                            dvc-event-related-buffer)

(dvc-make-bymouse-function dvc-switch-to-output-buffer)
(dvc-make-bymouse-function dvc-switch-to-error-buffer)
(dvc-make-bymouse-function dvc-switch-to-related-buffer)

(defun dvc-log-event (output error command tree event)
  "Log an event in the `dvc-log-buffer' buffer.
OUTPUT is the buffer containing process standard output.
ERROR is the buffer containing process error output.
COMMAND is the command that was executed.
TREE is the process's working directory.
EVENT is the event that occurred.
Returns that event."
  (unless (and dvc-log-cookie
               (buffer-live-p (ewoc-buffer dvc-log-cookie)))
    (with-current-buffer (get-buffer-create dvc-log-buffer)
      (setq dvc-log-cookie
            (ewoc-create (dvc-ewoc-create-api-select
                          #'dvc-log-printer)))
      (dvc-log-buffer-mode)))
  (let ((related-buffer (current-buffer)))
    (with-current-buffer (ewoc-buffer dvc-log-cookie)
      (let ((elem (make-dvc-event :output-buffer output
                                  :error-buffer error
                                  :related-buffer related-buffer
                                  :command command
                                  :tree tree
                                  :event event
                                  :time (current-time)))
            buffer-read-only)
        (ewoc-enter-last dvc-log-cookie elem)
        ;; If an event is too old (30 minutes after it has been
        ;; recorded), throw it away.
        (ewoc-filter dvc-log-cookie 'dvc-log-recently-p 30)
        (ewoc-refresh dvc-log-cookie)
        elem))))

(defun dvc-log-next ()
  "Move to the next log entry."
  (interactive)
  (let ((next (ewoc-next dvc-log-cookie
                         (ewoc-locate dvc-log-cookie))))
    (when next (goto-char (ewoc-location next)))))

(defun dvc-log-prev ()
  "Move to the previous log entry."
  (interactive)
  (let ((prev (ewoc-prev dvc-log-cookie
                         (ewoc-locate dvc-log-cookie))))
    (when prev (goto-char (ewoc-location prev)))))

;;
;; Log buffer mode section
;;
(defvar dvc-log-buffer-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map dvc-keyvec-help 'describe-mode)
    (define-key map [?o] 'dvc-switch-to-output-buffer)
    (define-key map "\C-m" 'dvc-switch-to-output-buffer)
    (define-key map [?e] 'dvc-switch-to-error-buffer)
    (define-key map [?r] 'dvc-switch-to-related-buffer)
    (define-key map [?n] 'dvc-log-next)
    (define-key map [?p] 'dvc-log-prev)
    (define-key map dvc-keyvec-quit 'dvc-buffer-quit)
    map)
  "Keymap used in DVC's log buffer.")

(define-derived-mode dvc-log-buffer-mode fundamental-mode "DVC Log"
  "Major mode for DVC's internal log buffer. You can open this buffer
with `dvc-open-internal-log-buffer'."
  (toggle-read-only 1))

(defun dvc-open-internal-log-buffer ()
  "Switch to the DVC's internal log buffer.
This buffer contains a list of all the DVC commands previously executed.
The buffer uses the mode `dvc-log-buffer-mode'"
  (interactive)
  (let ((buffer-name (buffer-name)))
    (dvc-switch-to-buffer dvc-log-buffer)
    (goto-char (point-max))
    (when (re-search-backward (concat " Buffer: "
                                      (regexp-quote buffer-name)
                                      "$")
                              nil t)
      (dvc-flash-line))))

(defun dvc-clear-log-buffer ()
  "Kill the log buffer."
  (when (bufferp (get-buffer dvc-log-buffer))
    (kill-buffer dvc-log-buffer)))

(defun dvc-get-process-output ()
  "Return the content of the last process buffer.
Strips the final newline if there is one."
  (dvc-buffer-content dvc-last-process-buffer))

(defun dvc-get-error-output ()
  "Return the content of the last error buffer.
Strips the final newline if there is one."
  (dvc-buffer-content dvc-last-error-buffer))


;; TODO: per backend cound.
(add-to-list 'minor-mode-alist
             '(dvc-process-running
               (:eval (if (equal (length dvc-process-running) 1)
                          " DVC running"
                        (concat " DVC running("
                                (int-to-string (length dvc-process-running))
                                ")")))))

(defun dvc-log-edit-file-name ()
  "Return a suitable file name to edit the commit message"
  ;; FIXME: replace this with define-dvc-unified-command
  (dvc-call "dvc-log-edit-file-name-func"))

(defun dvc-dvc-log-edit-file-name-func ()
  (concat (file-name-as-directory (dvc-tree-root))
          (dvc-variable (dvc-current-active-dvc)
                        "log-edit-file-name")))

;;
;; Revision manipulation
;;

;; revision grammar is specified in ../docs/DVC-API

;; accessors
(defun dvc-revision-get-dvc (revision-id)
  (car revision-id))

(defun dvc-revision-get-type (revision-id)
  (car (nth 1 revision-id)))

(defun dvc-revision-get-data (revision-id)
  (cdr (nth 1 revision-id)))

(defun dvc-revision-to-string (revision-id &optional prev-format orig-str)
  "Return a string representation for REVISION-ID.

If PREV-FORMAT is specified, it is the format string to use for
entries that are before the given revision ID.  The format string
should take two parameters.  The first is the revision ID, and
the second is a number which indicates how many generations back
to travel.

If ORIG-STR is specified, it is the string that indicates the
current revision of the working tree."
  (let* ((type (dvc-revision-get-type revision-id))
         (data (dvc-revision-get-data revision-id)))
    ;;(dvc-trace "dvc-revision-to-string: type: %s, data: %s, orig-str: %s" type data orig-str)
    (case type
      (revision (dvc-name-construct (nth 0 data)))
      (local-tree (car data))
      (last-revision (or orig-str "original"))
      (previous-revision
       (format (or prev-format "%s:-%s")
               (dvc-revision-to-string
                (list (dvc-revision-get-dvc revision-id) (nth 0 data)))
               (int-to-string (nth 1 data))))
      (t "UNKNOWN"))))

(defun dvc-revision-get-buffer (file revision-id)
  "Return an empty buffer suitable for viewing FILE in REVISION-ID.

The name of the buffer is chosen according to FILE and REVISION-ID.

REVISION-ID may have the values described in docs/DVC-API."
  (let* ((type (dvc-revision-get-type revision-id))
         (name (concat
                (file-name-nondirectory file)
                "(" (dvc-revision-to-string revision-id) ")")))
    ;; replace / by | to work around uniquify
    (setq name (replace-regexp-in-string "\\/" "|" name))
    (let ((buffer (generate-new-buffer name)))
      (with-current-buffer buffer
        (let ((buffer-file-name file))
          (set-auto-mode t)))
      (dvc-buffers-tree-add (dvc-revision-get-dvc revision-id) type file buffer)
      buffer)))


(defun dvc-revision-get-file-in-buffer (file revision-id)
  "Return a buffer with the content of FILE at REVISION-ID.

REVISION-ID is as specified in docs/DVC-API."
  (dvc-trace "dvc-revision-get-file-in-buffer. revision-id=%S" revision-id)
  (let* ((type (dvc-revision-get-type revision-id))
         (inhibit-read-only t)
         ;; find-file-noselect will call dvc-current-active-dvc in a
         ;; hook; specify dvc for dvc-call
         (dvc-temp-current-active-dvc (dvc-revision-get-dvc revision-id))
         (buffer (unless (eq type 'local-tree) (dvc-revision-get-buffer file revision-id))))
    (case type
      (local-tree (find-file-noselect file))

      (revision
       (with-current-buffer buffer
         (dvc-call "revision-get-file-revision"
                   file (dvc-revision-get-data revision-id))
         (set-buffer-modified-p nil)
         (toggle-read-only 1)
         buffer))

      (previous-revision
       (with-current-buffer buffer
         (let* ((dvc (dvc-revision-get-dvc revision-id))
                (data (nth 0 (dvc-revision-get-data revision-id)))
                (rev-id (list dvc data)))
           (dvc-call "revision-get-previous-revision" file rev-id))
         (set-buffer-modified-p nil)
         (toggle-read-only 1)
         buffer))

      (last-revision
       (with-current-buffer buffer
         (dvc-call "revision-get-last-revision"
                   file (dvc-revision-get-data revision-id))
         (set-buffer-modified-p nil)
         (toggle-read-only 1)
         buffer))

      (t (error "TODO: dvc-revision-get-file-in-buffer type %S" type)))))

(defun dvc-dvc-revision-nth-ancestor (revision n)
  "Default function to get the n-th ancestor of REVISION."
  (let ((count n)
        (res revision))
    (while (> count 0)
      (setq res (dvc-revision-direct-ancestor res)
            count (- count 1)))
    res))

;;
;; DVC command version
;;
(defun dvc-dvc-command-version ()
  "Fallback for `dvc-command-vesion'. Returns just `nil'.
This function is called only if the current backend doesn't
implement `command-version' function."
  nil)

(provide 'dvc-core)
;;; dvc-core.el ends here