+2010-06-11 Juri Linkov <juri@jurta.org>
+
+ Move version control related files to the "vc" subdirectory.
+ * add-log.el, cvs-status.el, diff.el, diff-mode.el, ediff-diff.el,
+ * ediff.el, ediff-help.el, ediff-hook.el, ediff-init.el,
+ * ediff-merg.el, ediff-mult.el, ediff-ptch.el, ediff-util.el,
+ * ediff-vers.el, ediff-wind.el, emerge.el, log-edit.el, log-view.el,
+ * pcvs-defs.el, pcvs.el, pcvs-info.el, pcvs-parse.el, pcvs-util.el,
+ * smerge-mode.el, vc-annotate.el, vc-arch.el, vc-bzr.el, vc-cvs.el,
+ * vc-dav.el, vc-dir.el, vc-dispatcher.el, vc.el, vc-git.el,
+ * vc-hg.el, vc-hooks.el, vc-mtn.el, vc-rcs.el, vc-sccs.el, vc-svn.el:
+ Move files to the "vc" subdirectory.
+
2010-06-11 Chong Yidong <cyd@stupidchicken.com>
* comint.el (comint-password-prompt-regexp): Fix 2010-04-10 change
+++ /dev/null
-;;; add-log.el --- change log maintenance commands for Emacs
-
-;; Copyright (C) 1985, 1986, 1988, 1993, 1994, 1997, 1998, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This facility is documented in the Emacs Manual.
-
-;; Todo:
-
-;; - Find/use/create _MTN/log if there's a _MTN directory.
-;; - Find/use/create ++log.* if there's an {arch} directory.
-;; - Use an open *VC-Log* or *cvs-commit* buffer if it's related to the
-;; source file.
-;; - Don't add TAB indents (and username?) if inserting entries in those
-;; special places.
-
-;;; Code:
-
-(eval-when-compile
- (require 'timezone))
-
-(defgroup change-log nil
- "Change log maintenance."
- :group 'tools
- :link '(custom-manual "(emacs)Change Log")
- :prefix "change-log-"
- :prefix "add-log-")
-
-
-(defcustom change-log-default-name nil
- "Name of a change log file for \\[add-change-log-entry]."
- :type '(choice (const :tag "default" nil)
- string)
- :group 'change-log)
-;;;###autoload
-(put 'change-log-default-name 'safe-local-variable 'string-or-null-p)
-
-(defcustom change-log-mode-hook nil
- "Normal hook run by `change-log-mode'."
- :type 'hook
- :group 'change-log)
-
-;; Many modes set this variable, so avoid warnings.
-;;;###autoload
-(defcustom add-log-current-defun-function nil
- "If non-nil, function to guess name of surrounding function.
-It is used by `add-log-current-defun' in preference to built-in rules.
-Returns function's name as a string, or nil if outside a function."
- :type '(choice (const nil) function)
- :group 'change-log)
-
-;;;###autoload
-(defcustom add-log-full-name nil
- "Full name of user, for inclusion in ChangeLog daily headers.
-This defaults to the value returned by the function `user-full-name'."
- :type '(choice (const :tag "Default" nil)
- string)
- :group 'change-log)
-
-;;;###autoload
-(defcustom add-log-mailing-address nil
- "Email addresses of user, for inclusion in ChangeLog headers.
-This defaults to the value of `user-mail-address'. In addition to
-being a simple string, this value can also be a list. All elements
-will be recognized as referring to the same user; when creating a new
-ChangeLog entry, one element will be chosen at random."
- :type '(choice (const :tag "Default" nil)
- (string :tag "String")
- (repeat :tag "List of Strings" string))
- :group 'change-log)
-
-(defcustom add-log-time-format 'add-log-iso8601-time-string
- "Function that defines the time format.
-For example, `add-log-iso8601-time-string', which gives the
-date in international ISO 8601 format,
-and `current-time-string' are two valid values."
- :type '(radio (const :tag "International ISO 8601 format"
- add-log-iso8601-time-string)
- (const :tag "Old format, as returned by `current-time-string'"
- current-time-string)
- (function :tag "Other"))
- :group 'change-log)
-
-(defcustom add-log-keep-changes-together nil
- "If non-nil, normally keep day's log entries for one file together.
-
-Log entries for a given file made with \\[add-change-log-entry] or
-\\[add-change-log-entry-other-window] will only be added to others \
-for that file made
-today if this variable is non-nil or that file comes first in today's
-entries. Otherwise another entry for that file will be started. An
-original log:
-
- * foo (...): ...
- * bar (...): change 1
-
-in the latter case, \\[add-change-log-entry-other-window] in a \
-buffer visiting `bar', yields:
-
- * bar (...): -!-
- * foo (...): ...
- * bar (...): change 1
-
-and in the former:
-
- * foo (...): ...
- * bar (...): change 1
- (...): -!-
-
-The NEW-ENTRY arg to `add-change-log-entry' can override the effect of
-this variable."
- :version "20.3"
- :type 'boolean
- :group 'change-log)
-
-(defcustom add-log-always-start-new-record nil
- "If non-nil, `add-change-log-entry' will always start a new record."
- :version "22.1"
- :type 'boolean
- :group 'change-log)
-
-(defcustom add-log-buffer-file-name-function nil
- "If non-nil, function to call to identify the full filename of a buffer.
-This function is called with no argument. If this is nil, the default is to
-use `buffer-file-name'."
- :type '(choice (const nil) function)
- :group 'change-log)
-
-(defcustom add-log-file-name-function nil
- "If non-nil, function to call to identify the filename for a ChangeLog entry.
-This function is called with one argument, the value of variable
-`buffer-file-name' in that buffer. If this is nil, the default is to
-use the file's name relative to the directory of the change log file."
- :type '(choice (const nil) function)
- :group 'change-log)
-
-
-(defcustom change-log-version-info-enabled nil
- "If non-nil, enable recording version numbers with the changes."
- :version "21.1"
- :type 'boolean
- :group 'change-log)
-
-(defcustom change-log-version-number-regexp-list
- (let ((re "\\([0-9]+\.[0-9.]+\\)"))
- (list
- ;; (defconst ad-version "2.15"
- (concat "^(def[^ \t\n]+[ \t]+[^ \t\n][ \t]\"" re)
- ;; Revision: pcl-cvs.el,v 1.72 1999/09/05 20:21:54 monnier Exp
- (concat "^;+ *Revision: +[^ \t\n]+[ \t]+" re)))
- "List of regexps to search for version number.
-The version number must be in group 1.
-Note: The search is conducted only within 10%, at the beginning of the file."
- :version "21.1"
- :type '(repeat regexp)
- :group 'change-log)
-
-(defface change-log-date
- '((t (:inherit font-lock-string-face)))
- "Face used to highlight dates in date lines."
- :version "21.1"
- :group 'change-log)
-(define-obsolete-face-alias 'change-log-date-face 'change-log-date "22.1")
-
-(defface change-log-name
- '((t (:inherit font-lock-constant-face)))
- "Face for highlighting author names."
- :version "21.1"
- :group 'change-log)
-(define-obsolete-face-alias 'change-log-name-face 'change-log-name "22.1")
-
-(defface change-log-email
- '((t (:inherit font-lock-variable-name-face)))
- "Face for highlighting author email addresses."
- :version "21.1"
- :group 'change-log)
-(define-obsolete-face-alias 'change-log-email-face 'change-log-email "22.1")
-
-(defface change-log-file
- '((t (:inherit font-lock-function-name-face)))
- "Face for highlighting file names."
- :version "21.1"
- :group 'change-log)
-(define-obsolete-face-alias 'change-log-file-face 'change-log-file "22.1")
-
-(defface change-log-list
- '((t (:inherit font-lock-keyword-face)))
- "Face for highlighting parenthesized lists of functions or variables."
- :version "21.1"
- :group 'change-log)
-(define-obsolete-face-alias 'change-log-list-face 'change-log-list "22.1")
-
-(defface change-log-conditionals
- '((t (:inherit font-lock-variable-name-face)))
- "Face for highlighting conditionals of the form `[...]'."
- :version "21.1"
- :group 'change-log)
-(define-obsolete-face-alias 'change-log-conditionals-face
- 'change-log-conditionals "22.1")
-
-(defface change-log-function
- '((t (:inherit font-lock-variable-name-face)))
- "Face for highlighting items of the form `<....>'."
- :version "21.1"
- :group 'change-log)
-(define-obsolete-face-alias 'change-log-function-face
- 'change-log-function "22.1")
-
-(defface change-log-acknowledgement
- '((t (:inherit font-lock-comment-face)))
- "Face for highlighting acknowledgments."
- :version "21.1"
- :group 'change-log)
-(define-obsolete-face-alias 'change-log-acknowledgement-face
- 'change-log-acknowledgement "22.1")
-
-(defconst change-log-file-names-re "^\\( +\\|\t\\)\\* \\([^ ,:([\n]+\\)")
-(defconst change-log-start-entry-re "^\\sw.........[0-9:+ ]*")
-
-(defvar change-log-font-lock-keywords
- `(;;
- ;; Date lines, new (2000-01-01) and old (Sat Jan 1 00:00:00 2000) styles.
- ;; Fixme: this regepx is just an approximate one and may match
- ;; wrongly with a non-date line existing as a random note. In
- ;; addition, using any kind of fixed setting like this doesn't
- ;; work if a user customizes add-log-time-format.
- ("^[0-9-]+ +\\|^ \\{11,\\}\\|^\\(Sun\\|Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\) [A-z][a-z][a-z] [0-9:+ ]+"
- (0 'change-log-date-face)
- ;; Name and e-mail; some people put e-mail in parens, not angles.
- ("\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" nil nil
- (1 'change-log-name)
- (2 'change-log-email)))
- ;;
- ;; File names.
- (,change-log-file-names-re
- (2 'change-log-file)
- ;; Possibly further names in a list:
- ("\\=, \\([^ ,:([\n]+\\)" nil nil (1 'change-log-file))
- ;; Possibly a parenthesized list of names:
- ("\\= (\\([^(),\n]+\\|(\\(setf\\|SETF\\) [^() ,\n]+)\\)"
- nil nil (1 'change-log-list))
- ("\\=, *\\([^(),\n]+\\|(\\(setf\\|SETF\\) [^() ,\n]+)\\)"
- nil nil (1 'change-log-list)))
- ;;
- ;; Function or variable names.
- ("^\\( +\\|\t\\)(\\([^(),\n]+\\|(\\(setf\\|SETF\\) [^() ,\n]+)\\)"
- (2 'change-log-list)
- ("\\=, *\\([^(),\n]+\\|(\\(setf\\|SETF\\) [^() ,\n]+)\\)" nil nil
- (1 'change-log-list)))
- ;;
- ;; Conditionals.
- ("\\[!?\\([^]\n]+\\)\\]\\(:\\| (\\)" (1 'change-log-conditionals))
- ;;
- ;; Function of change.
- ("<\\([^>\n]+\\)>\\(:\\| (\\)" (1 'change-log-function))
- ;;
- ;; Acknowledgements.
- ;; Don't include plain "From" because that is vague;
- ;; we want to encourage people to say something more specific.
- ;; Note that the FSF does not use "Patches by"; our convention
- ;; is to put the name of the author of the changes at the top
- ;; of the change log entry.
- ("\\(^\\( +\\|\t\\)\\| \\)\\(Patch\\(es\\)? by\\|Report\\(ed by\\| from\\)\\|Suggest\\(ed by\\|ion from\\)\\)"
- 3 'change-log-acknowledgement))
- "Additional expressions to highlight in Change Log mode.")
-
-(defun change-log-search-file-name (where)
- "Return the file-name for the change under point."
- (save-excursion
- (goto-char where)
- (beginning-of-line 1)
- (if (looking-at change-log-start-entry-re)
- ;; We are at the start of an entry, search forward for a file
- ;; name.
- (progn
- (re-search-forward change-log-file-names-re nil t)
- (match-string-no-properties 2))
- (if (looking-at change-log-file-names-re)
- ;; We found a file name.
- (match-string-no-properties 2)
- ;; Look backwards for either a file name or the log entry start.
- (if (re-search-backward
- (concat "\\(" change-log-start-entry-re
- "\\)\\|\\("
- change-log-file-names-re "\\)") nil t)
- (if (match-beginning 1)
- ;; We got the start of the entry, look forward for a
- ;; file name.
- (progn
- (re-search-forward change-log-file-names-re nil t)
- (match-string-no-properties 2))
- (match-string-no-properties 4))
- ;; We must be before any file name, look forward.
- (re-search-forward change-log-file-names-re nil t)
- (match-string-no-properties 2))))))
-
-(defun change-log-find-file ()
- "Visit the file for the change under point."
- (interactive)
- (let ((file (change-log-search-file-name (point))))
- (if (and file (file-exists-p file))
- (find-file file)
- (message "No such file or directory: %s" file))))
-
-(defun change-log-search-tag-name-1 (&optional from)
- "Search for a tag name within subexpression 1 of last match.
-Optional argument FROM specifies a buffer position where the tag
-name should be located. Return value is a cons whose car is the
-string representing the tag and whose cdr is the position where
-the tag was found."
- (save-restriction
- (narrow-to-region (match-beginning 1) (match-end 1))
- (when from (goto-char from))
- ;; The regexp below skips any symbol near `point' (FROM) followed by
- ;; whitespace and another symbol. This should skip, for example,
- ;; "struct" in a specification like "(struct buffer)" and move to
- ;; "buffer". A leading paren is ignored.
- (when (looking-at
- "[(]?\\(?:\\(?:\\sw\\|\\s_\\)+\\(?:[ \t]+\\(\\sw\\|\\s_\\)+\\)\\)")
- (goto-char (match-beginning 1)))
- (cons (find-tag-default) (point))))
-
-(defconst change-log-tag-re
- "(\\(\\(?:\\sw\\|\\s_\\)+\\(?:[, \t]+\\(?:\\sw\\|\\s_\\)+\\)*\\))"
- "Regexp matching a tag name in change log entries.")
-
-(defun change-log-search-tag-name (&optional at)
- "Search for a tag name near `point'.
-Optional argument AT non-nil means search near buffer position AT.
-Return value is a cons whose car is the string representing
-the tag and whose cdr is the position where the tag was found."
- (save-excursion
- (goto-char (setq at (or at (point))))
- (save-restriction
- (widen)
- (or (condition-case nil
- ;; Within parenthesized list?
- (save-excursion
- (backward-up-list)
- (when (looking-at change-log-tag-re)
- (change-log-search-tag-name-1 at)))
- (error nil))
- (condition-case nil
- ;; Before parenthesized list on same line?
- (save-excursion
- (when (and (skip-chars-forward " \t")
- (looking-at change-log-tag-re))
- (change-log-search-tag-name-1)))
- (error nil))
- (condition-case nil
- ;; Near file name?
- (save-excursion
- (when (and (progn
- (beginning-of-line)
- (looking-at change-log-file-names-re))
- (goto-char (match-end 0))
- (skip-syntax-forward " ")
- (looking-at change-log-tag-re))
- (change-log-search-tag-name-1)))
- (error nil))
- (condition-case nil
- ;; Anywhere else within current entry?
- (let ((from
- (save-excursion
- (end-of-line)
- (if (re-search-backward change-log-start-entry-re nil t)
- (match-beginning 0)
- (point-min))))
- (to
- (save-excursion
- (end-of-line)
- (if (re-search-forward change-log-start-entry-re nil t)
- (match-beginning 0)
- (point-max)))))
- (when (and (< from to) (<= from at) (<= at to))
- (save-restriction
- ;; Narrow to current change log entry.
- (narrow-to-region from to)
- (cond
- ((re-search-backward change-log-tag-re nil t)
- (narrow-to-region (match-beginning 1) (match-end 1))
- (goto-char (point-max))
- (cons (find-tag-default) (point-max)))
- ((re-search-forward change-log-tag-re nil t)
- (narrow-to-region (match-beginning 1) (match-end 1))
- (goto-char (point-min))
- (cons (find-tag-default) (point-min)))))))
- (error nil))))))
-
-(defvar change-log-find-head nil)
-(defvar change-log-find-tail nil)
-(defvar change-log-find-window nil)
-
-(defun change-log-goto-source-1 (tag regexp file buffer
- &optional window first last)
- "Search for tag TAG in buffer BUFFER visiting file FILE.
-REGEXP is a regular expression for TAG. The remaining arguments
-are optional: WINDOW denotes the window to display the results of
-the search. FIRST is a position in BUFFER denoting the first
-match from previous searches for TAG. LAST is the position in
-BUFFER denoting the last match for TAG in the last search."
- (with-current-buffer buffer
- (save-excursion
- (save-restriction
- (widen)
- (if last
- (progn
- ;; When LAST is set make sure we continue from the next
- ;; line end to not find the same tag again.
- (goto-char last)
- (end-of-line)
- (condition-case nil
- ;; Try to go to the end of the current defun to avoid
- ;; false positives within the current defun's body
- ;; since these would match `add-log-current-defun'.
- (end-of-defun)
- ;; Don't fall behind when `end-of-defun' fails.
- (error (progn (goto-char last) (end-of-line))))
- (setq last nil))
- ;; When LAST was not set start at beginning of BUFFER.
- (goto-char (point-min)))
- (let (current-defun)
- (while (and (not last) (re-search-forward regexp nil t))
- ;; Verify that `add-log-current-defun' invoked at the end
- ;; of the match returns TAG. This heuristic works well
- ;; whenever the name of the defun occurs within the first
- ;; line of the defun.
- (setq current-defun (add-log-current-defun))
- (when (and current-defun (string-equal current-defun tag))
- ;; Record this as last match.
- (setq last (line-beginning-position))
- ;; Record this as first match when there's none.
- (unless first (setq first last)))))))
- (if (or last first)
- (with-selected-window
- (setq change-log-find-window (or window (display-buffer buffer)))
- (if last
- (progn
- (when (or (< last (point-min)) (> last (point-max)))
- ;; Widen to show TAG.
- (widen))
- (push-mark)
- (goto-char last))
- ;; When there are no more matches go (back) to FIRST.
- (message "No more matches for tag `%s' in file `%s'" tag file)
- (setq last first)
- (goto-char first))
- ;; Return new "tail".
- (list (selected-window) first last))
- (message "Source location of tag `%s' not found in file `%s'" tag file)
- nil)))
-
-(defun change-log-goto-source ()
- "Go to source location of \"change log tag\" near `point'.
-A change log tag is a symbol within a parenthesized,
-comma-separated list. If no suitable tag can be found nearby,
-try to visit the file for the change under `point' instead."
- (interactive)
- (if (and (eq last-command 'change-log-goto-source)
- change-log-find-tail)
- (setq change-log-find-tail
- (condition-case nil
- (apply 'change-log-goto-source-1
- (append change-log-find-head change-log-find-tail))
- (error
- (format "Cannot find more matches for tag `%s' in file `%s'"
- (car change-log-find-head)
- (nth 2 change-log-find-head)))))
- (save-excursion
- (let* ((at (point))
- (tag-at (change-log-search-tag-name))
- (tag (car tag-at))
- (file (when tag-at (change-log-search-file-name (cdr tag-at))))
- (file-at (when file (match-beginning 2)))
- ;; `file-2' is the file `change-log-search-file-name' finds
- ;; at `point'. We use `file-2' as a fallback when `tag' or
- ;; `file' are not suitable for some reason.
- (file-2 (change-log-search-file-name at))
- (file-2-at (when file-2 (match-beginning 2))))
- (cond
- ((and (or (not tag) (not file) (not (file-exists-p file)))
- (or (not file-2) (not (file-exists-p file-2))))
- (error "Cannot find tag or file near `point'"))
- ((and file-2 (file-exists-p file-2)
- (or (not tag) (not file) (not (file-exists-p file))
- (and (or (and (< file-at file-2-at) (<= file-2-at at))
- (and (<= at file-2-at) (< file-2-at file-at))))))
- ;; We either have not found a suitable file name or `file-2'
- ;; provides a "better" file name wrt `point'. Go to the
- ;; buffer of `file-2' instead.
- (setq change-log-find-window
- (display-buffer (find-file-noselect file-2))))
- (t
- (setq change-log-find-head
- (list tag (concat "\\_<" (regexp-quote tag) "\\_>")
- file (find-file-noselect file)))
- (condition-case nil
- (setq change-log-find-tail
- (apply 'change-log-goto-source-1 change-log-find-head))
- (error
- (format "Cannot find matches for tag `%s' in file `%s'"
- tag file)))))))))
-
-(defun change-log-next-error (&optional argp reset)
- "Move to the Nth (default 1) next match in a ChangeLog buffer.
-Compatibility function for \\[next-error] invocations."
- (interactive "p")
- (let* ((argp (or argp 0))
- (count (abs argp)) ; how many cycles
- (down (< argp 0)) ; are we going down? (is argp negative?)
- (up (not down))
- (search-function (if up 're-search-forward 're-search-backward)))
-
- ;; set the starting position
- (goto-char (cond (reset (point-min))
- (down (line-beginning-position))
- (up (line-end-position))
- ((point))))
-
- (funcall search-function change-log-file-names-re nil t count))
-
- (beginning-of-line)
- ;; if we found a place to visit...
- (when (looking-at change-log-file-names-re)
- (let (change-log-find-window)
- (change-log-goto-source)
- (when change-log-find-window
- ;; Select window displaying source file.
- (select-window change-log-find-window)))))
-
-(defvar change-log-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap)))
- (define-key map [?\C-c ?\C-p] 'add-log-edit-prev-comment)
- (define-key map [?\C-c ?\C-n] 'add-log-edit-next-comment)
- (define-key map [?\C-c ?\C-f] 'change-log-find-file)
- (define-key map [?\C-c ?\C-c] 'change-log-goto-source)
- (define-key map [menu-bar changelog] (cons "ChangeLog" menu-map))
- (define-key menu-map [gs]
- '(menu-item "Go To Source" change-log-goto-source
- :help "Go to source location of ChangeLog tag near point"))
- (define-key menu-map [ff]
- '(menu-item "Find File" change-log-find-file
- :help "Visit the file for the change under point"))
- (define-key menu-map [sep] '("--"))
- (define-key menu-map [nx]
- '(menu-item "Next Log-Edit Comment" add-log-edit-next-comment
- :help "Cycle forward through Log-Edit mode comment history"))
- (define-key menu-map [pr]
- '(menu-item "Previous Log-Edit Comment" add-log-edit-prev-comment
- :help "Cycle backward through Log-Edit mode comment history"))
- map)
- "Keymap for Change Log major mode.")
-
-;; It used to be called change-log-time-zone-rule but really should be
-;; called add-log-time-zone-rule since it's only used from add-log-* code.
-(defvaralias 'change-log-time-zone-rule 'add-log-time-zone-rule)
-(defvar add-log-time-zone-rule nil
- "Time zone used for calculating change log time stamps.
-It takes the same format as the TZ argument of `set-time-zone-rule'.
-If nil, use local time.
-If t, use universal time.")
-(put 'add-log-time-zone-rule 'safe-local-variable
- '(lambda (x) (or (booleanp x) (stringp x))))
-
-(defun add-log-iso8601-time-zone (&optional time)
- (let* ((utc-offset (or (car (current-time-zone time)) 0))
- (sign (if (< utc-offset 0) ?- ?+))
- (sec (abs utc-offset))
- (ss (% sec 60))
- (min (/ sec 60))
- (mm (% min 60))
- (hh (/ min 60)))
- (format (cond ((not (zerop ss)) "%c%02d:%02d:%02d")
- ((not (zerop mm)) "%c%02d:%02d")
- (t "%c%02d"))
- sign hh mm ss)))
-
-(defvar add-log-iso8601-with-time-zone nil)
-
-(defun add-log-iso8601-time-string ()
- (let ((time (format-time-string "%Y-%m-%d"
- nil (eq t add-log-time-zone-rule))))
- (if add-log-iso8601-with-time-zone
- (concat time " " (add-log-iso8601-time-zone))
- time)))
-
-(defun change-log-name ()
- "Return (system-dependent) default name for a change log file."
- (or change-log-default-name
- "ChangeLog"))
-
-(defun add-log-edit-prev-comment (arg)
- "Cycle backward through Log-Edit mode comment history.
-With a numeric prefix ARG, go back ARG comments."
- (interactive "*p")
- (save-restriction
- (narrow-to-region (point)
- (if (memq last-command '(add-log-edit-prev-comment
- add-log-edit-next-comment))
- (mark) (point)))
- (when (fboundp 'log-edit-previous-comment)
- (log-edit-previous-comment arg)
- (indent-region (point-min) (point-max))
- (goto-char (point-min))
- (unless (save-restriction (widen) (bolp))
- (delete-region (point) (progn (skip-chars-forward " \t\n") (point))))
- (set-mark (point-min))
- (goto-char (point-max))
- (delete-region (point) (progn (skip-chars-backward " \t\n") (point))))))
-
-(defun add-log-edit-next-comment (arg)
- "Cycle forward through Log-Edit mode comment history.
-With a numeric prefix ARG, go back ARG comments."
- (interactive "*p")
- (add-log-edit-prev-comment (- arg)))
-
-;;;###autoload
-(defun prompt-for-change-log-name ()
- "Prompt for a change log name."
- (let* ((default (change-log-name))
- (name (expand-file-name
- (read-file-name (format "Log file (default %s): " default)
- nil default))))
- ;; Handle something that is syntactically a directory name.
- ;; Look for ChangeLog or whatever in that directory.
- (if (string= (file-name-nondirectory name) "")
- (expand-file-name (file-name-nondirectory default)
- name)
- ;; Handle specifying a file that is a directory.
- (if (file-directory-p name)
- (expand-file-name (file-name-nondirectory default)
- (file-name-as-directory name))
- name))))
-
-(defun change-log-version-number-search ()
- "Return version number of current buffer's file.
-This is the value returned by `vc-working-revision' or, if that is
-nil, by matching `change-log-version-number-regexp-list'."
- (let* ((size (buffer-size))
- (limit
- ;; The version number can be anywhere in the file, but
- ;; restrict search to the file beginning: 10% should be
- ;; enough to prevent some mishits.
- ;;
- ;; Apply percentage only if buffer size is bigger than
- ;; approx 100 lines.
- (if (> size (* 100 80)) (+ (point) (/ size 10)))))
- (or (and buffer-file-name (vc-working-revision buffer-file-name))
- (save-restriction
- (widen)
- (let ((regexps change-log-version-number-regexp-list)
- version)
- (while regexps
- (save-excursion
- (goto-char (point-min))
- (when (re-search-forward (pop regexps) limit t)
- (setq version (match-string 1)
- regexps nil))))
- version)))))
-
-(declare-function diff-find-source-location "diff-mode"
- (&optional other-file reverse noprompt))
-
-;;;###autoload
-(defun find-change-log (&optional file-name buffer-file)
- "Find a change log file for \\[add-change-log-entry] and return the name.
-
-Optional arg FILE-NAME specifies the file to use.
-If FILE-NAME is nil, use the value of `change-log-default-name'.
-If `change-log-default-name' is nil, behave as though it were 'ChangeLog'
-\(or whatever we use on this operating system).
-
-If `change-log-default-name' contains a leading directory component, then
-simply find it in the current directory. Otherwise, search in the current
-directory and its successive parents for a file so named.
-
-Once a file is found, `change-log-default-name' is set locally in the
-current buffer to the complete file name.
-Optional arg BUFFER-FILE overrides `buffer-file-name'."
- ;; If we are called from a diff, first switch to the source buffer;
- ;; in order to respect buffer-local settings of change-log-default-name, etc.
- (with-current-buffer (let ((buff (if (eq major-mode 'diff-mode)
- (car (ignore-errors
- (diff-find-source-location))))))
- (if (buffer-live-p buff) buff
- (current-buffer)))
- ;; If user specified a file name or if this buffer knows which one to use,
- ;; just use that.
- (or file-name
- (setq file-name (and change-log-default-name
- (file-name-directory change-log-default-name)
- change-log-default-name))
- (progn
- ;; Chase links in the source file
- ;; and use the change log in the dir where it points.
- (setq file-name (or (and (or buffer-file buffer-file-name)
- (file-name-directory
- (file-chase-links
- (or buffer-file buffer-file-name))))
- default-directory))
- (if (file-directory-p file-name)
- (setq file-name (expand-file-name (change-log-name) file-name)))
- ;; Chase links before visiting the file.
- ;; This makes it easier to use a single change log file
- ;; for several related directories.
- (setq file-name (file-chase-links file-name))
- (setq file-name (expand-file-name file-name))
- ;; Move up in the dir hierarchy till we find a change log file.
- (let ((file1 file-name)
- parent-dir)
- (while (and (not (or (get-file-buffer file1) (file-exists-p file1)))
- (progn (setq parent-dir
- (file-name-directory
- (directory-file-name
- (file-name-directory file1))))
- ;; Give up if we are already at the root dir.
- (not (string= (file-name-directory file1)
- parent-dir))))
- ;; Move up to the parent dir and try again.
- (setq file1 (expand-file-name
- (file-name-nondirectory (change-log-name))
- parent-dir)))
- ;; If we found a change log in a parent, use that.
- (if (or (get-file-buffer file1) (file-exists-p file1))
- (setq file-name file1)))))
- ;; Make a local variable in this buffer so we needn't search again.
- (set (make-local-variable 'change-log-default-name) file-name))
- file-name)
-
-(defun add-log-file-name (buffer-file log-file)
- ;; Never want to add a change log entry for the ChangeLog file itself.
- (unless (or (null buffer-file) (string= buffer-file log-file))
- (if add-log-file-name-function
- (funcall add-log-file-name-function buffer-file)
- (setq buffer-file
- (file-relative-name buffer-file (file-name-directory log-file)))
- ;; If we have a backup file, it's presumably because we're
- ;; comparing old and new versions (e.g. for deleted
- ;; functions) and we'll want to use the original name.
- (if (backup-file-name-p buffer-file)
- (file-name-sans-versions buffer-file)
- buffer-file))))
-
-;;;###autoload
-(defun add-change-log-entry (&optional whoami file-name other-window new-entry
- put-new-entry-on-new-line)
- "Find change log file, and add an entry for today and an item for this file.
-Optional arg WHOAMI (interactive prefix) non-nil means prompt for user
-name and email (stored in `add-log-full-name' and `add-log-mailing-address').
-
-Second arg FILE-NAME is file name of the change log.
-If nil, use the value of `change-log-default-name'.
-
-Third arg OTHER-WINDOW non-nil means visit in other window.
-
-Fourth arg NEW-ENTRY non-nil means always create a new entry at the front;
-never append to an existing entry. Option `add-log-keep-changes-together'
-otherwise affects whether a new entry is created.
-
-Fifth arg PUT-NEW-ENTRY-ON-NEW-LINE non-nil means that if a new
-entry is created, put it on a new line by itself, do not put it
-after a comma on an existing line.
-
-Option `add-log-always-start-new-record' non-nil means always create a
-new record, even when the last record was made on the same date and by
-the same person.
-
-The change log file can start with a copyright notice and a copying
-permission notice. The first blank line indicates the end of these
-notices.
-
-Today's date is calculated according to `add-log-time-zone-rule' if
-non-nil, otherwise in local time."
- (interactive (list current-prefix-arg
- (prompt-for-change-log-name)))
- (let* ((defun (add-log-current-defun))
- (version (and change-log-version-info-enabled
- (change-log-version-number-search)))
- (buf-file-name (if add-log-buffer-file-name-function
- (funcall add-log-buffer-file-name-function)
- buffer-file-name))
- (buffer-file (if buf-file-name (expand-file-name buf-file-name)))
- (file-name (expand-file-name (find-change-log file-name buffer-file)))
- ;; Set ITEM to the file name to use in the new item.
- (item (add-log-file-name buffer-file file-name)))
-
- (unless (equal file-name buffer-file-name)
- (cond
- ((equal file-name (buffer-file-name (window-buffer (selected-window))))
- ;; If the selected window already shows the desired buffer don't show
- ;; it again (particularly important if other-window is true).
- ;; This is important for diff-add-change-log-entries-other-window.
- (set-buffer (window-buffer (selected-window))))
- ((or other-window (window-dedicated-p (selected-window)))
- (find-file-other-window file-name))
- (t (find-file file-name))))
- (or (derived-mode-p 'change-log-mode)
- (change-log-mode))
- (undo-boundary)
- (goto-char (point-min))
-
- (let ((full-name (or add-log-full-name (user-full-name)))
- (mailing-address (or add-log-mailing-address user-mail-address)))
-
- (when whoami
- (setq full-name (read-string "Full name: " full-name))
- ;; Note that some sites have room and phone number fields in
- ;; full name which look silly when inserted. Rather than do
- ;; anything about that here, let user give prefix argument so that
- ;; s/he can edit the full name field in prompter if s/he wants.
- (setq mailing-address
- (read-string "Mailing address: " mailing-address)))
-
- ;; If file starts with a copyright and permission notice, skip them.
- ;; Assume they end at first blank line.
- (when (looking-at "Copyright")
- (search-forward "\n\n")
- (skip-chars-forward "\n"))
-
- ;; Advance into first entry if it is usable; else make new one.
- (let ((new-entries
- (mapcar (lambda (addr)
- (concat
- (if (stringp add-log-time-zone-rule)
- (let ((tz (getenv "TZ")))
- (unwind-protect
- (progn
- (set-time-zone-rule add-log-time-zone-rule)
- (funcall add-log-time-format))
- (set-time-zone-rule tz)))
- (funcall add-log-time-format))
- " " full-name
- " <" addr ">"))
- (if (consp mailing-address)
- mailing-address
- (list mailing-address)))))
- (if (and (not add-log-always-start-new-record)
- (let ((hit nil))
- (dolist (entry new-entries hit)
- (when (looking-at (regexp-quote entry))
- (setq hit t)))))
- (forward-line 1)
- (insert (nth (random (length new-entries))
- new-entries)
- (if use-hard-newlines hard-newline "\n")
- (if use-hard-newlines hard-newline "\n"))
- (forward-line -1))))
-
- ;; Determine where we should stop searching for a usable
- ;; item to add to, within this entry.
- (let ((bound
- (save-excursion
- (if (looking-at "\n*[^\n* \t]")
- (skip-chars-forward "\n")
- (if add-log-keep-changes-together
- (forward-page) ; page delimits entries for date
- (forward-paragraph))) ; paragraph delimits entries for file
- (point))))
-
- ;; Now insert the new line for this item.
- (cond ((re-search-forward "^\\s *\\*\\s *$" bound t)
- ;; Put this file name into the existing empty item.
- (if item
- (insert item)))
- ((and (not new-entry)
- (let (case-fold-search)
- (re-search-forward
- (concat (regexp-quote (concat "* " item))
- ;; Don't accept `foo.bar' when
- ;; looking for `foo':
- "\\(\\s \\|[(),:]\\)")
- bound t)))
- ;; Add to the existing item for the same file.
- (re-search-forward "^\\s *$\\|^\\s \\*")
- (goto-char (match-beginning 0))
- ;; Delete excess empty lines; make just 2.
- (while (and (not (eobp)) (looking-at "^\\s *$"))
- (delete-region (point) (line-beginning-position 2)))
- (insert (if use-hard-newlines hard-newline "\n")
- (if use-hard-newlines hard-newline "\n"))
- (forward-line -2)
- (indent-relative-maybe))
- (t
- ;; Make a new item.
- (while (looking-at "\\sW")
- (forward-line 1))
- (while (and (not (eobp)) (looking-at "^\\s *$"))
- (delete-region (point) (line-beginning-position 2)))
- (insert (if use-hard-newlines hard-newline "\n")
- (if use-hard-newlines hard-newline "\n")
- (if use-hard-newlines hard-newline "\n"))
- (forward-line -2)
- (indent-to left-margin)
- (insert "* ")
- (if item (insert item)))))
- ;; Now insert the function name, if we have one.
- ;; Point is at the item for this file,
- ;; either at the end of the line or at the first blank line.
- (if (not defun)
- ;; No function name, so put in a colon unless we have just a star.
- (unless (save-excursion
- (beginning-of-line 1)
- (looking-at "\\s *\\(\\*\\s *\\)?$"))
- (insert ": ")
- (if version (insert version ?\s)))
- ;; Make it easy to get rid of the function name.
- (undo-boundary)
- (unless (save-excursion
- (beginning-of-line 1)
- (looking-at "\\s *$"))
- (insert ?\s))
- ;; See if the prev function name has a message yet or not.
- ;; If not, merge the two items.
- (let ((pos (point-marker)))
- (skip-syntax-backward " ")
- (skip-chars-backward "):")
- (if (and (not put-new-entry-on-new-line)
- (looking-at "):")
- (let ((pos (save-excursion (backward-sexp 1) (point))))
- (when (equal (buffer-substring pos (point)) defun)
- (delete-region pos (point)))
- (> fill-column (+ (current-column) (length defun) 4))))
- (progn (skip-chars-backward ", ")
- (delete-region (point) pos)
- (unless (memq (char-before) '(?\()) (insert ", ")))
- (when (and (not put-new-entry-on-new-line) (looking-at "):"))
- (delete-region (+ 1 (point)) (line-end-position)))
- (goto-char pos)
- (insert "("))
- (set-marker pos nil))
- (insert defun "): ")
- (if version (insert version ?\s)))))
-
-;;;###autoload
-(defun add-change-log-entry-other-window (&optional whoami file-name)
- "Find change log file in other window and add entry and item.
-This is just like `add-change-log-entry' except that it displays
-the change log file in another window."
- (interactive (if current-prefix-arg
- (list current-prefix-arg
- (prompt-for-change-log-name))))
- (add-change-log-entry whoami file-name t))
-
-
-(defvar change-log-indent-text 0)
-
-(defun change-log-fill-parenthesized-list ()
- ;; Fill parenthesized lists of names according to GNU standards.
- ;; * file-name.ext (very-long-foo, very-long-bar, very-long-foobar):
- ;; should be filled as
- ;; * file-name.ext (very-long-foo, very-long-bar)
- ;; (very-long-foobar):
- (save-excursion
- (end-of-line 0)
- (skip-chars-backward " \t")
- (when (and (equal (char-before) ?\,)
- (> (point) (1+ (point-min))))
- (condition-case nil
- (when (save-excursion
- (and (prog2
- (up-list -1)
- (equal (char-after) ?\()
- (skip-chars-backward " \t"))
- (or (bolp)
- ;; Skip everything but a whitespace or asterisk.
- (and (not (zerop (skip-chars-backward "^ \t\n*")))
- (skip-chars-backward " \t")
- ;; We want one asterisk here.
- (= (skip-chars-backward "*") -1)
- (skip-chars-backward " \t")
- (bolp)))))
- ;; Delete the comma.
- (delete-char -1)
- ;; Close list on previous line.
- (insert ")")
- (skip-chars-forward " \t\n")
- ;; Start list on new line.
- (insert-before-markers "("))
- (error nil)))))
-
-(defun change-log-indent ()
- (change-log-fill-parenthesized-list)
- (let* ((indent
- (save-excursion
- (beginning-of-line)
- (skip-chars-forward " \t")
- (cond
- ((and (looking-at "\\(.*\\) [^ \n].*[^ \n] <.*>\\(?: +(.*)\\)? *$")
- ;; Matching the output of add-log-time-format is difficult,
- ;; but I'll get it has at least two adjacent digits.
- (string-match "[[:digit:]][[:digit:]]" (match-string 1)))
- 0)
- ((looking-at "[^*(]")
- (+ (current-left-margin) change-log-indent-text))
- (t (current-left-margin)))))
- (pos (save-excursion (indent-line-to indent) (point))))
- (if (> pos (point)) (goto-char pos))))
-
-
-(defvar smerge-resolve-function)
-(defvar copyright-at-end-flag)
-
-;;;###autoload
-(define-derived-mode change-log-mode text-mode "Change Log"
- "Major mode for editing change logs; like Indented Text mode.
-Prevents numeric backups and sets `left-margin' to 8 and `fill-column' to 74.
-New log entries are usually made with \\[add-change-log-entry] or \\[add-change-log-entry-other-window].
-Each entry behaves as a paragraph, and the entries for one day as a page.
-Runs `change-log-mode-hook'.
-\n\\{change-log-mode-map}"
- (setq left-margin 8
- fill-column 74
- indent-tabs-mode t
- tab-width 8
- show-trailing-whitespace t)
- (set (make-local-variable 'fill-forward-paragraph-function)
- 'change-log-fill-forward-paragraph)
- ;; Make sure we call `change-log-indent' when filling.
- (set (make-local-variable 'fill-indent-according-to-mode) t)
- ;; Avoid that filling leaves behind a single "*" on a line.
- (add-hook 'fill-nobreak-predicate
- '(lambda ()
- (looking-back "^\\s *\\*\\s *" (line-beginning-position)))
- nil t)
- (set (make-local-variable 'indent-line-function) 'change-log-indent)
- (set (make-local-variable 'tab-always-indent) nil)
- (set (make-local-variable 'copyright-at-end-flag) t)
- ;; We really do want "^" in paragraph-start below: it is only the
- ;; lines that begin at column 0 (despite the left-margin of 8) that
- ;; we are looking for. Adding `* ' allows eliding the blank line
- ;; between entries for different files.
- (set (make-local-variable 'paragraph-start) "\\s *$\\|\f\\|^\\<")
- (set (make-local-variable 'paragraph-separate) paragraph-start)
- ;; Match null string on the date-line so that the date-line
- ;; is grouped with what follows.
- (set (make-local-variable 'page-delimiter) "^\\<\\|^\f")
- (set (make-local-variable 'version-control) 'never)
- (set (make-local-variable 'smerge-resolve-function)
- 'change-log-resolve-conflict)
- (set (make-local-variable 'adaptive-fill-regexp) "\\s *")
- (set (make-local-variable 'font-lock-defaults)
- '(change-log-font-lock-keywords t nil nil backward-paragraph))
- (set (make-local-variable 'multi-isearch-next-buffer-function)
- 'change-log-next-buffer)
- (set (make-local-variable 'beginning-of-defun-function)
- 'change-log-beginning-of-defun)
- (set (make-local-variable 'end-of-defun-function)
- 'change-log-end-of-defun)
- ;; next-error function glue
- (setq next-error-function 'change-log-next-error)
- (setq next-error-last-buffer (current-buffer)))
-
-(defun change-log-next-buffer (&optional buffer wrap)
- "Return the next buffer in the series of ChangeLog file buffers.
-This function is used for multiple buffers isearch.
-A sequence of buffers is formed by ChangeLog files with decreasing
-numeric file name suffixes in the directory of the initial ChangeLog
-file were isearch was started."
- (let* ((name (change-log-name))
- (files (cons name (sort (file-expand-wildcards
- (concat name "[-.][0-9]*"))
- (lambda (a b)
- ;; The file's extension may not have a valid
- ;; version form (e.g. VC backup revisions).
- (ignore-errors
- (version< (substring b (length name))
- (substring a (length name))))))))
- (files (if isearch-forward files (reverse files))))
- (find-file-noselect
- (if wrap
- (car files)
- (cadr (member (file-name-nondirectory (buffer-file-name buffer))
- files))))))
-
-(defun change-log-fill-forward-paragraph (n)
- "Cut paragraphs so filling preserves open parentheses at beginning of lines."
- (let (;; Add lines starting with whitespace followed by a left paren or an
- ;; asterisk.
- (paragraph-start (concat paragraph-start "\\|\\s *\\(?:\\s(\\|\\*\\)")))
- (forward-paragraph n)))
-\f
-(defcustom add-log-current-defun-header-regexp
- "^\\([[:upper:]][[:upper:]_ ]*[[:upper:]_]\\|[-_[:alpha:]]+\\)[ \t]*[:=]"
- "Heuristic regexp used by `add-log-current-defun' for unknown major modes.
-The regexp's first submatch is placed in the ChangeLog entry, in
-parentheses."
- :type 'regexp
- :group 'change-log)
-
-;;;###autoload
-(defvar add-log-lisp-like-modes
- '(emacs-lisp-mode lisp-mode scheme-mode dsssl-mode lisp-interaction-mode)
- "*Modes that look like Lisp to `add-log-current-defun'.")
-
-;;;###autoload
-(defvar add-log-c-like-modes
- '(c-mode c++-mode c++-c-mode objc-mode)
- "*Modes that look like C to `add-log-current-defun'.")
-
-;;;###autoload
-(defvar add-log-tex-like-modes
- '(TeX-mode plain-TeX-mode LaTeX-mode tex-mode)
- "*Modes that look like TeX to `add-log-current-defun'.")
-
-(declare-function c-cpp-define-name "cc-cmds" ())
-(declare-function c-defun-name "cc-cmds" ())
-
-;;;###autoload
-(defun add-log-current-defun ()
- "Return name of function definition point is in, or nil.
-
-Understands C, Lisp, LaTeX (\"functions\" are chapters, sections, ...),
-Texinfo (@node titles) and Perl.
-
-Other modes are handled by a heuristic that looks in the 10K before
-point for uppercase headings starting in the first column or
-identifiers followed by `:' or `='. See variables
-`add-log-current-defun-header-regexp' and
-`add-log-current-defun-function'.
-
-Has a preference of looking backwards."
- (condition-case nil
- (save-excursion
- (let ((location (point)))
- (cond (add-log-current-defun-function
- (funcall add-log-current-defun-function))
- ((apply 'derived-mode-p add-log-lisp-like-modes)
- ;; If we are now precisely at the beginning of a defun,
- ;; make sure beginning-of-defun finds that one
- ;; rather than the previous one.
- (or (eobp) (forward-char 1))
- (beginning-of-defun)
- ;; Make sure we are really inside the defun found,
- ;; not after it.
- (when (and (looking-at "\\s(")
- (progn (end-of-defun)
- (< location (point)))
- (progn (forward-sexp -1)
- (>= location (point))))
- (if (looking-at "\\s(")
- (forward-char 1))
- ;; Skip the defining construct name, typically "defun"
- ;; or "defvar".
- (forward-sexp 1)
- ;; The second element is usually a symbol being defined.
- ;; If it is not, use the first symbol in it.
- (skip-chars-forward " \t\n'(")
- (buffer-substring-no-properties (point)
- (progn (forward-sexp 1)
- (point)))))
- ((apply 'derived-mode-p add-log-c-like-modes)
- (or (c-cpp-define-name)
- (c-defun-name)))
- ((memq major-mode add-log-tex-like-modes)
- (if (re-search-backward
- "\\\\\\(sub\\)*\\(section\\|paragraph\\|chapter\\)"
- nil t)
- (progn
- (goto-char (match-beginning 0))
- (buffer-substring-no-properties
- (1+ (point)) ; without initial backslash
- (line-end-position)))))
- ((derived-mode-p 'texinfo-mode)
- (if (re-search-backward "^@node[ \t]+\\([^,\n]+\\)" nil t)
- (match-string-no-properties 1)))
- ((derived-mode-p 'perl-mode 'cperl-mode)
- (if (re-search-backward "^sub[ \t]+\\([^({ \t\n]+\\)" nil t)
- (match-string-no-properties 1)))
- ;; Emacs's autoconf-mode installs its own
- ;; `add-log-current-defun-function'. This applies to
- ;; a different mode apparently for editing .m4
- ;; autoconf source.
- ((derived-mode-p 'autoconf-mode)
- (if (re-search-backward
- "^\\(\\(m4_\\)?define\\|A._DEFUN\\)(\\[?\\([A-Za-z0-9_]+\\)" nil t)
- (match-string-no-properties 3)))
- (t
- ;; If all else fails, try heuristics
- (let (case-fold-search
- result)
- (end-of-line)
- (when (re-search-backward
- add-log-current-defun-header-regexp
- (- (point) 10000)
- t)
- (setq result (or (match-string-no-properties 1)
- (match-string-no-properties 0)))
- ;; Strip whitespace away
- (when (string-match "\\([^ \t\n\r\f].*[^ \t\n\r\f]\\)"
- result)
- (setq result (match-string-no-properties 1 result)))
- result))))))
- (error nil)))
-
-(defvar change-log-get-method-definition-md)
-
-;; Subroutine used within change-log-get-method-definition.
-;; Add the last match in the buffer to the end of `md',
-;; followed by the string END; move to the end of that match.
-(defun change-log-get-method-definition-1 (end)
- (setq change-log-get-method-definition-md
- (concat change-log-get-method-definition-md
- (match-string 1)
- end))
- (goto-char (match-end 0)))
-
-(defun change-log-get-method-definition ()
-"For Objective C, return the method name if we are in a method."
- (let ((change-log-get-method-definition-md "["))
- (save-excursion
- (if (re-search-backward "^@implementation\\s-*\\([A-Za-z_]*\\)" nil t)
- (change-log-get-method-definition-1 " ")))
- (save-excursion
- (cond
- ((re-search-forward "^\\([-+]\\)[ \t\n\f\r]*\\(([^)]*)\\)?\\s-*" nil t)
- (change-log-get-method-definition-1 "")
- (while (not (looking-at "[{;]"))
- (looking-at
- "\\([A-Za-z_]*:?\\)\\s-*\\(([^)]*)\\)?[A-Za-z_]*[ \t\n\f\r]*")
- (change-log-get-method-definition-1 ""))
- (concat change-log-get-method-definition-md "]"))))))
-\f
-(defun change-log-sortable-date-at ()
- "Return date of log entry in a consistent form for sorting.
-Point is assumed to be at the start of the entry."
- (require 'timezone)
- (if (looking-at change-log-start-entry-re)
- (let ((date (match-string-no-properties 0)))
- (if date
- (if (string-match "\\(....\\)-\\(..\\)-\\(..\\)\\s-+" date)
- (concat (match-string 1 date) (match-string 2 date)
- (match-string 3 date))
- (condition-case nil
- (timezone-make-date-sortable date)
- (error nil)))))
- (error "Bad date")))
-
-(defun change-log-resolve-conflict ()
- "Function to be used in `smerge-resolve-function'."
- (save-excursion
- (save-restriction
- (narrow-to-region (match-beginning 0) (match-end 0))
- (let ((mb1 (match-beginning 1))
- (me1 (match-end 1))
- (mb3 (match-beginning 3))
- (me3 (match-end 3))
- (tmp1 (generate-new-buffer " *changelog-resolve-1*"))
- (tmp2 (generate-new-buffer " *changelog-resolve-2*")))
- (unwind-protect
- (let ((buf (current-buffer)))
- (with-current-buffer tmp1
- (change-log-mode)
- (insert-buffer-substring buf mb1 me1))
- (with-current-buffer tmp2
- (change-log-mode)
- (insert-buffer-substring buf mb3 me3)
- ;; Do the merge here instead of inside `buf' so as to be
- ;; more robust in case change-log-merge fails.
- (change-log-merge tmp1))
- (goto-char (point-max))
- (delete-region (point-min)
- (prog1 (point)
- (insert-buffer-substring tmp2))))
- (kill-buffer tmp1)
- (kill-buffer tmp2))))))
-
-;;;###autoload
-(defun change-log-merge (other-log)
- "Merge the contents of change log file OTHER-LOG with this buffer.
-Both must be found in Change Log mode (since the merging depends on
-the appropriate motion commands). OTHER-LOG can be either a file name
-or a buffer.
-
-Entries are inserted in chronological order. Both the current and
-old-style time formats for entries are supported."
- (interactive "*fLog file name to merge: ")
- (if (not (derived-mode-p 'change-log-mode))
- (error "Not in Change Log mode"))
- (let ((other-buf (if (bufferp other-log) other-log
- (find-file-noselect other-log)))
- (buf (current-buffer))
- date1 start end)
- (save-excursion
- (goto-char (point-min))
- (set-buffer other-buf)
- (goto-char (point-min))
- (if (not (derived-mode-p 'change-log-mode))
- (error "%s not found in Change Log mode" other-log))
- ;; Loop through all the entries in OTHER-LOG.
- (while (not (eobp))
- (setq date1 (change-log-sortable-date-at))
- (setq start (point)
- end (progn (forward-page) (point)))
- ;; Look for an entry in original buffer that isn't later.
- (with-current-buffer buf
- (while (and (not (eobp))
- (string< date1 (change-log-sortable-date-at)))
- (forward-page))
- (if (not (eobp))
- (insert-buffer-substring other-buf start end)
- ;; At the end of the original buffer, insert a newline to
- ;; separate entries and then the rest of the file being
- ;; merged.
- (unless (or (bobp)
- (and (= ?\n (char-before))
- (or (<= (1- (point)) (point-min))
- (= ?\n (char-before (1- (point)))))))
- (insert (if use-hard-newlines hard-newline "\n")))
- ;; Move to the end of it to terminate outer loop.
- (with-current-buffer other-buf
- (goto-char (point-max)))
- (insert-buffer-substring other-buf start)))))))
-
-(defun change-log-beginning-of-defun ()
- (re-search-backward change-log-start-entry-re nil 'move))
-
-(defun change-log-end-of-defun ()
- ;; Look back and if there is no entry there it means we are before
- ;; the first ChangeLog entry, so go forward until finding one.
- (unless (save-excursion (re-search-backward change-log-start-entry-re nil t))
- (re-search-forward change-log-start-entry-re nil t))
-
- ;; In case we are at the end of log entry going forward a line will
- ;; make us find the next entry when searching. If we are inside of
- ;; an entry going forward a line will still keep the point inside
- ;; the same entry.
- (forward-line 1)
-
- ;; In case we are at the beginning of an entry, move past it.
- (when (looking-at change-log-start-entry-re)
- (goto-char (match-end 0))
- (forward-line 1))
-
- ;; Search for the start of the next log entry. Go to the end of the
- ;; buffer if we could not find a next entry.
- (when (re-search-forward change-log-start-entry-re nil 'move)
- (goto-char (match-beginning 0))
- (forward-line -1)))
-
-(provide 'add-log)
-
-;; arch-tag: 81eee6fc-088f-4372-a37f-80ad9620e762
-;;; add-log.el ends here
+++ /dev/null
-;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*-
-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: pcl-cvs cvs status tree tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Todo:
-
-;; - Somehow allow cvs-status-tree to work on-the-fly
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'pcvs-util)
-
-;;;
-
-(defgroup cvs-status nil
- "Major mode for browsing `cvs status' output."
- :group 'pcl-cvs
- :prefix "cvs-status-")
-
-(easy-mmode-defmap cvs-status-mode-map
- '(("n" . next-line)
- ("p" . previous-line)
- ("N" . cvs-status-next)
- ("P" . cvs-status-prev)
- ("\M-n" . cvs-status-next)
- ("\M-p" . cvs-status-prev)
- ("t" . cvs-status-cvstrees)
- ("T" . cvs-status-trees)
- (">" . cvs-mode-checkout))
- "CVS-Status' keymap."
- :group 'cvs-status
- :inherit 'cvs-mode-map)
-
-;;(easy-menu-define cvs-status-menu cvs-status-mode-map
-;; "Menu for `cvs-status-mode'."
-;; '("CVS-Status"
-;; ["Show Tag Trees" cvs-status-tree t]
-;; ))
-
-(defvar cvs-status-mode-hook nil
- "Hook run at the end of `cvs-status-mode'.")
-
-(defconst cvs-status-tags-leader-re "^ Existing Tags:$")
-(defconst cvs-status-entry-leader-re
- "^File:\\s-+\\(?:no file \\)?\\(.*\\S-\\)\\s-+Status: \\(.+\\)$")
-(defconst cvs-status-dir-re "^cvs[.ex]* [a-z]+: Examining \\(.+\\)$")
-(defconst cvs-status-rev-re "[0-9][.0-9]*\\.[.0-9]*[0-9]")
-(defconst cvs-status-tag-re "[ \t]\\([a-zA-Z][^ \t\n.]*\\)")
-
-(defconst cvs-status-font-lock-keywords
- `((,cvs-status-entry-leader-re
- (1 'cvs-filename)
- (2 'cvs-need-action))
- (,cvs-status-tags-leader-re
- (,cvs-status-rev-re
- (save-excursion (re-search-forward "^\n" nil 'move) (point))
- (progn (re-search-backward cvs-status-tags-leader-re nil t)
- (forward-line 1))
- (0 font-lock-comment-face))
- (,cvs-status-tag-re
- (save-excursion (re-search-forward "^\n" nil 'move) (point))
- (progn (re-search-backward cvs-status-tags-leader-re nil t)
- (forward-line 1))
- (1 font-lock-function-name-face)))))
-(defconst cvs-status-font-lock-defaults
- '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t)))
-
-(defvar cvs-minor-wrap-function)
-(put 'cvs-status-mode 'mode-class 'special)
-;;;###autoload
-(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
- "Mode used for cvs status output."
- (set (make-local-variable 'font-lock-defaults) cvs-status-font-lock-defaults)
- (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-status-minor-wrap))
-
-;; Define cvs-status-next and cvs-status-prev
-(easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry")
-
-(defun cvs-status-current-file ()
- (save-excursion
- (forward-line 1)
- (or (re-search-backward cvs-status-entry-leader-re nil t)
- (re-search-forward cvs-status-entry-leader-re))
- (let* ((file (match-string 1))
- (cvsdir (and (re-search-backward cvs-status-dir-re nil t)
- (match-string 1)))
- (pcldir (and (if (boundp 'cvs-pcl-cvs-dirchange-re)
- (re-search-backward cvs-pcl-cvs-dirchange-re nil t))
- (match-string 1)))
- (dir ""))
- (let ((default-directory ""))
- (when pcldir (setq dir (expand-file-name pcldir dir)))
- (when cvsdir (setq dir (expand-file-name cvsdir dir)))
- (expand-file-name file dir)))))
-
-(defun cvs-status-current-tag ()
- (save-excursion
- (let ((pt (point))
- (col (current-column))
- (start (progn (re-search-backward cvs-status-tags-leader-re nil t) (point)))
- (end (progn (re-search-forward "^$" nil t) (point))))
- (when (and (< start pt) (> end pt))
- (goto-char pt)
- (end-of-line)
- (let ((tag nil) (dist pt) (end (point)))
- (beginning-of-line)
- (while (re-search-forward cvs-status-tag-re end t)
- (let* ((cole (current-column))
- (colb (save-excursion
- (goto-char (match-beginning 1)) (current-column)))
- (ndist (min (abs (- cole col)) (abs (- colb col)))))
- (when (< ndist dist)
- (setq dist ndist)
- (setq tag (match-string 1)))))
- tag)))))
-
-(defun cvs-status-minor-wrap (buf f)
- (let ((data (with-current-buffer buf
- (cons
- (cons (cvs-status-current-file)
- (cvs-status-current-tag))
- (when mark-active
- (save-excursion
- (goto-char (mark))
- (cons (cvs-status-current-file)
- (cvs-status-current-tag))))))))
- (let ((cvs-branch-prefix (cdar data))
- (cvs-secondary-branch-prefix (and (cdar data) (cddr data)))
- (cvs-minor-current-files
- (cons (caar data)
- (when (and (cadr data) (not (equal (caar data) (cadr data))))
- (list (cadr data)))))
- ;; FIXME: I need to force because the fileinfos are UNKNOWN
- (cvs-force-command "/F"))
- (funcall f))))
-
-;;
-;; Tagelt, tag element
-;;
-
-(defstruct (cvs-tag
- (:constructor nil)
- (:constructor cvs-tag-make
- (vlist &optional name type))
- (:conc-name cvs-tag->))
- vlist
- name
- type)
-
-(defsubst cvs-status-vl-to-str (vl) (mapconcat 'number-to-string vl "."))
-
-(defun cvs-tag->string (tag)
- (if (stringp tag) tag
- (let ((name (cvs-tag->name tag))
- (vl (cvs-tag->vlist tag)))
- (if (null name) (cvs-status-vl-to-str vl)
- (let ((rev (if vl (concat " (" (cvs-status-vl-to-str vl) ")") "")))
- (if (consp name) (mapcar (lambda (name) (concat name rev)) name)
- (concat name rev)))))))
-
-(defun cvs-tag-compare-1 (vl1 vl2)
- (cond
- ((and (null vl1) (null vl2)) 'equal)
- ((null vl1) 'more2)
- ((null vl2) 'more1)
- (t (let ((v1 (car vl1))
- (v2 (car vl2)))
- (cond
- ((> v1 v2) 'more1)
- ((< v1 v2) 'more2)
- (t (cvs-tag-compare-1 (cdr vl1) (cdr vl2))))))))
-
-(defsubst cvs-tag-compare (tag1 tag2)
- (cvs-tag-compare-1 (cvs-tag->vlist tag1) (cvs-tag->vlist tag2)))
-
-(defun cvs-tag-merge (tag1 tag2)
- "Merge TAG1 and TAG2 into one."
- (let ((type1 (cvs-tag->type tag1))
- (type2 (cvs-tag->type tag2))
- (name1 (cvs-tag->name tag1))
- (name2 (cvs-tag->name tag2)))
- (unless (equal (cvs-tag->vlist tag1) (cvs-tag->vlist tag2))
- (setf (cvs-tag->vlist tag1) nil))
- (if type1
- (unless (or (not type2) (equal type1 type2))
- (setf (cvs-tag->type tag1) nil))
- (setf (cvs-tag->type tag1) type2))
- (if name1
- (setf (cvs-tag->name tag1) (cvs-append name1 name2))
- (setf (cvs-tag->name tag1) name2))
- tag1))
-
-(defun cvs-tree-print (tags printer column)
- "Print the tree of TAGS where each tag's string is given by PRINTER.
-PRINTER should accept both a tag (in which case it should return a string)
-or a string (in which case it should simply return its argument).
-A tag cannot be a CONS. The return value can also be a list of strings,
-if several nodes where merged into one.
-The tree will be printed no closer than column COLUMN."
-
- (let* ((eol (save-excursion (end-of-line) (current-column)))
- (column (max (+ eol 2) column)))
- (if (null tags) column
- ;;(move-to-column-force column)
- (let* ((rev (cvs-car tags))
- (name (funcall printer (cvs-car rev)))
- (rest (append (cvs-cdr name) (cvs-cdr tags)))
- (prefix
- (save-excursion
- (or (= (forward-line 1) 0) (insert "\n"))
- (cvs-tree-print rest printer column))))
- (assert (>= prefix column))
- (move-to-column prefix t)
- (assert (eolp))
- (insert (cvs-car name))
- (dolist (br (cvs-cdr rev))
- (let* ((column (current-column))
- (brrev (funcall printer (cvs-car br)))
- (brlength (length (cvs-car brrev)))
- (brfill (concat (make-string (/ brlength 2) ? ) "|"))
- (prefix
- (save-excursion
- (insert " -- ")
- (cvs-tree-print (cvs-append brrev brfill (cvs-cdr br))
- printer (current-column)))))
- (delete-region (save-excursion (move-to-column prefix) (point))
- (point))
- (insert " " (make-string (- prefix column 2) ?-) " ")
- (end-of-line)))
- prefix))))
-
-(defun cvs-tree-merge (tree1 tree2)
- "Merge tags trees TREE1 and TREE2 into one.
-BEWARE: because of stability issues, this is not a symetric operation."
- (assert (and (listp tree1) (listp tree2)))
- (cond
- ((null tree1) tree2)
- ((null tree2) tree1)
- (t
- (let* ((rev1 (car tree1))
- (tag1 (cvs-car rev1))
- (vl1 (cvs-tag->vlist tag1))
- (l1 (length vl1))
- (rev2 (car tree2))
- (tag2 (cvs-car rev2))
- (vl2 (cvs-tag->vlist tag2))
- (l2 (length vl2)))
- (cond
- ((= l1 l2)
- (case (cvs-tag-compare tag1 tag2)
- (more1 (list* rev2 (cvs-tree-merge tree1 (cdr tree2))))
- (more2 (list* rev1 (cvs-tree-merge (cdr tree1) tree2)))
- (equal
- (cons (cons (cvs-tag-merge tag1 tag2)
- (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2)))
- (cvs-tree-merge (cdr tree1) (cdr tree2))))))
- ((> l1 l2)
- (cvs-tree-merge
- (list (cons (cvs-tag-make (butlast vl1)) tree1)) tree2))
- ((< l1 l2)
- (cvs-tree-merge
- tree1 (list (cons (cvs-tag-make (butlast vl2)) tree2)))))))))
-
-(defun cvs-tag-make-tag (tag)
- (let ((vl (mapcar 'string-to-number (split-string (nth 2 tag) "\\."))))
- (cvs-tag-make vl (nth 0 tag) (intern (nth 1 tag)))))
-
-(defun cvs-tags->tree (tags)
- "Make a tree out of a list of TAGS."
- (let ((tags
- (mapcar
- (lambda (tag)
- (let ((tag (cvs-tag-make-tag tag)))
- (list (if (not (eq (cvs-tag->type tag) 'branch)) tag
- (list (cvs-tag-make (butlast (cvs-tag->vlist tag)))
- tag)))))
- tags)))
- (while (cdr tags)
- (let (tl)
- (while tags
- (push (cvs-tree-merge (pop tags) (pop tags)) tl))
- (setq tags (nreverse tl))))
- (car tags)))
-
-(defun cvs-status-get-tags ()
- "Look for a list of tags, read them in and delete them.
-Return nil if there was an empty list of tags and t if there wasn't
-even a list. Else, return the list of tags where each element of
-the list is a three-string list TAG, KIND, REV."
- (let ((tags nil))
- (if (not (re-search-forward cvs-status-tags-leader-re nil t)) t
- (forward-char 1)
- (let ((pt (point))
- (lastrev nil)
- (case-fold-search t))
- (or
- (looking-at "\\s-+no\\s-+tags")
-
- (progn ; normal listing
- (while (looking-at "^[ \t]+\\([^ \t\n]+\\)[ \t]+(\\([a-z]+\\): \\(.+\\))$")
- (push (list (match-string 1) (match-string 2) (match-string 3)) tags)
- (forward-line 1))
- (unless (looking-at "^$") (setq tags nil) (goto-char pt))
- tags)
-
- (progn ; cvstree-style listing
- (while (or (looking-at "^ .+\\(.\\) \\([0-9.]+\\): \\([^\n\t .0-9][^\n\t ]*\\)?$")
- (and lastrev
- (looking-at "^ .+\\(\\) \\(8\\)? \\([^\n\t .0-9][^\n\t ]*\\)$")))
- (setq lastrev (or (match-string 2) lastrev))
- (push (list (match-string 3)
- (if (equal (match-string 1) " ") "branch" "revision")
- lastrev) tags)
- (forward-line 1))
- (unless (looking-at "^$") (setq tags nil) (goto-char pt))
- (setq tags (nreverse tags)))
-
- (progn ; new tree style listing
- (let* ((re-lead "[ \t]*\\(-+\\)?\\(|\n?[ \t]+\\)*")
- (re3 (concat re-lead "\\(\\.\\)?\\(" cvs-status-rev-re "\\)"))
- (re2 (concat re-lead cvs-status-tag-re "\\(\\)"))
- (re1 (concat re-lead cvs-status-tag-re
- " (\\(" cvs-status-rev-re "\\))")))
- (while (or (looking-at re1) (looking-at re2) (looking-at re3))
- (push (list (match-string 3)
- (if (match-string 1) "branch" "revision")
- (match-string 4)) tags)
- (goto-char (match-end 0))
- (when (eolp) (forward-char 1))))
- (unless (looking-at "^$") (setq tags nil) (goto-char pt))
- (setq tags (nreverse tags))))
-
- (delete-region pt (point)))
- tags)))
-
-(defvar font-lock-mode)
-;; (defun cvs-refontify (beg end)
-;; (when (and (boundp 'font-lock-mode)
-;; font-lock-mode
-;; (fboundp 'font-lock-fontify-region))
-;; (font-lock-fontify-region (1- beg) (1+ end))))
-
-(defun cvs-status-trees ()
- "Look for a lists of tags, and replace them with trees."
- (interactive)
- (save-excursion
- (goto-char (point-min))
- (let ((inhibit-read-only t)
- (tags nil))
- (while (listp (setq tags (cvs-status-get-tags)))
- ;;(let ((pt (save-excursion (forward-line -1) (point))))
- (save-restriction
- (narrow-to-region (point) (point))
- ;;(newline)
- (combine-after-change-calls
- (cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3)))
- ;;(cvs-refontify pt (point))
- ;;(sit-for 0)
- ;;)
- ))))
-
-;;;;
-;;;; CVSTree-style trees
-;;;;
-
-(defvar cvs-tree-use-jisx0208 nil) ;Old compat var.
-(defvar cvs-tree-use-charset
- (cond
- (cvs-tree-use-jisx0208 'jisx0208)
- ((char-displayable-p ?━) 'unicode)
- ((char-displayable-p (make-char 'japanese-jisx0208 40 44)) 'jisx0208))
- "*Non-nil if we should use the graphical glyphs from `japanese-jisx0208'.
-Otherwise, default to ASCII chars like +, - and |.")
-
-(defconst cvs-tree-char-space
- (case cvs-tree-use-charset
- (jisx0208 (make-char 'japanese-jisx0208 33 33))
- (unicode " ")
- (t " ")))
-(defconst cvs-tree-char-hbar
- (case cvs-tree-use-charset
- (jisx0208 (make-char 'japanese-jisx0208 40 44))
- (unicode "━")
- (t "--")))
-(defconst cvs-tree-char-vbar
- (case cvs-tree-use-charset
- (jisx0208 (make-char 'japanese-jisx0208 40 45))
- (unicode "┃")
- (t "| ")))
-(defconst cvs-tree-char-branch
- (case cvs-tree-use-charset
- (jisx0208 (make-char 'japanese-jisx0208 40 50))
- (unicode "┣")
- (t "+-")))
-(defconst cvs-tree-char-eob ;end of branch
- (case cvs-tree-use-charset
- (jisx0208 (make-char 'japanese-jisx0208 40 49))
- (unicode "┗")
- (t "`-")))
-(defconst cvs-tree-char-bob ;beginning of branch
- (case cvs-tree-use-charset
- (jisx0208 (make-char 'japanese-jisx0208 40 51))
- (unicode "┳")
- (t "+-")))
-
-(defun cvs-tag-lessp (tag1 tag2)
- (eq (cvs-tag-compare tag1 tag2) 'more2))
-
-(defvar cvs-tree-nomerge nil)
-
-(defun cvs-status-cvstrees (&optional arg)
- "Look for a list of tags, and replace it with a tree.
-Optional prefix ARG chooses between two representations."
- (interactive "P")
- (when (and cvs-tree-use-charset
- (not enable-multibyte-characters))
- ;; We need to convert the buffer from unibyte to multibyte
- ;; since we'll use multibyte chars for the tree.
- (let ((modified (buffer-modified-p))
- (inhibit-read-only t)
- (inhibit-modification-hooks t))
- (unwind-protect
- (progn
- (decode-coding-region (point-min) (point-max) 'undecided)
- (set-buffer-multibyte t))
- (restore-buffer-modified-p modified))))
- (save-excursion
- (goto-char (point-min))
- (let ((inhibit-read-only t)
- (tags nil)
- (cvs-tree-nomerge (if arg (not cvs-tree-nomerge) cvs-tree-nomerge)))
- (while (listp (setq tags (cvs-status-get-tags)))
- (let ((tags (mapcar 'cvs-tag-make-tag tags))
- ;;(pt (save-excursion (forward-line -1) (point)))
- )
- (setq tags (sort tags 'cvs-tag-lessp))
- (let* ((first (car tags))
- (prev (if (cvs-tag-p first)
- (list (car (cvs-tag->vlist first))) nil)))
- (combine-after-change-calls
- (cvs-tree-tags-insert tags prev))
- ;;(cvs-refontify pt (point))
- ;;(sit-for 0)
- ))))))
-
-(defun cvs-tree-tags-insert (tags prev)
- (when tags
- (let* ((tag (car tags))
- (vlist (cvs-tag->vlist tag))
- (nprev ;"next prev"
- (let* ((next (cvs-car (cadr tags)))
- (nprev (if (and cvs-tree-nomerge next
- (equal vlist (cvs-tag->vlist next)))
- prev vlist)))
- (cvs-map (lambda (v p) v) nprev prev)))
- (after (save-excursion
- (newline)
- (cvs-tree-tags-insert (cdr tags) nprev)))
- (pe t) ;"prev equal"
- (nas nil)) ;"next afters" to be returned
- (insert " ")
- (do* ((vs vlist (cdr vs))
- (ps prev (cdr ps))
- (as after (cdr as)))
- ((and (null as) (null vs) (null ps))
- (let ((revname (cvs-status-vl-to-str vlist)))
- (if (cvs-every 'identity (cvs-map 'equal prev vlist))
- (insert (make-string (+ 4 (length revname)) ? )
- (or (cvs-tag->name tag) ""))
- (insert " " revname ": " (or (cvs-tag->name tag) "")))))
- (let* ((eq (and pe (equal (car ps) (car vs))))
- (next-eq (equal (cadr ps) (cadr vs))))
- (let* ((na+char
- (if (car as)
- (if eq
- (if next-eq (cons t cvs-tree-char-vbar)
- (cons t cvs-tree-char-branch))
- (cons nil cvs-tree-char-bob))
- (if eq
- (if next-eq (cons nil cvs-tree-char-space)
- (cons t cvs-tree-char-eob))
- (cons nil (if (and (eq (cvs-tag->type tag) 'branch)
- (cvs-every 'null as))
- cvs-tree-char-space
- cvs-tree-char-hbar))))))
- (insert (cdr na+char))
- (push (car na+char) nas))
- (setq pe eq)))
- (nreverse nas))))
-
-;;;;
-;;;; Merged trees from different files
-;;;;
-
-(defun cvs-tree-fuzzy-merge-1 (trees tree prev)
- )
-
-(defun cvs-tree-fuzzy-merge (trees tree)
- "Do the impossible: merge TREE into TREES."
- ())
-
-(defun cvs-tree ()
- "Get tags from the status output and merge tham all into a big tree."
- (save-excursion
- (goto-char (point-min))
- (let ((inhibit-read-only t)
- (trees (make-vector 31 0)) tree)
- (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
- (cvs-tree-fuzzy-merge trees tree))
- (erase-buffer)
- (let ((cvs-tag-print-rev nil))
- (cvs-tree-print tree 'cvs-tag->string 3)))))
-
-
-(provide 'cvs-status)
-
-;; arch-tag: db8b5094-d02a-473e-a476-544e89ff5ad0
-;;; cvs-status.el ends here
+++ /dev/null
-;;; diff-mode.el --- a mode for viewing/editing context diffs
-
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,2005, 2006,
-;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: convenience patch diff
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Provides support for font-lock, outline, navigation
-;; commands, editing and various conversions as well as jumping
-;; to the corresponding source file.
-
-;; Inspired by Pavel Machek's patch-mode.el (<pavel@@atrey.karlin.mff.cuni.cz>)
-;; Some efforts were spent to have it somewhat compatible with XEmacs'
-;; diff-mode as well as with compilation-minor-mode
-
-;; Bugs:
-
-;; - Reverse doesn't work with normal diffs.
-
-;; Todo:
-
-;; - Improve `diff-add-change-log-entries-other-window',
-;; it is very simplistic now.
-;;
-;; - Add a `delete-after-apply' so C-c C-a automatically deletes hunks.
-;; Also allow C-c C-a to delete already-applied hunks.
-;;
-;; - Try `diff <file> <hunk>' to try and fuzzily discover the source location
-;; of a hunk. Show then the changes between <file> and <hunk> and make it
-;; possible to apply them to <file>, <hunk-src>, or <hunk-dst>.
-;; Or maybe just make it into a ".rej to diff3-markers converter".
-;; Maybe just use `wiggle' (by Neil Brown) to do it for us.
-;;
-;; - in diff-apply-hunk, strip context in replace-match to better
-;; preserve markers and spacing.
-;; - Handle `diff -b' output in context->unified.
-
-;;; Code:
-(eval-when-compile (require 'cl))
-
-(defvar add-log-buffer-file-name-function)
-
-
-(defgroup diff-mode ()
- "Major mode for viewing/editing diffs."
- :version "21.1"
- :group 'tools
- :group 'diff)
-
-(defcustom diff-default-read-only nil
- "If non-nil, `diff-mode' buffers default to being read-only."
- :type 'boolean
- :group 'diff-mode)
-
-(defcustom diff-jump-to-old-file nil
- "Non-nil means `diff-goto-source' jumps to the old file.
-Else, it jumps to the new file."
- :type 'boolean
- :group 'diff-mode)
-
-(defcustom diff-update-on-the-fly t
- "Non-nil means hunk headers are kept up-to-date on-the-fly.
-When editing a diff file, the line numbers in the hunk headers
-need to be kept consistent with the actual diff. This can
-either be done on the fly (but this sometimes interacts poorly with the
-undo mechanism) or whenever the file is written (can be slow
-when editing big diffs)."
- :type 'boolean
- :group 'diff-mode)
-
-(defcustom diff-advance-after-apply-hunk t
- "Non-nil means `diff-apply-hunk' will move to the next hunk after applying."
- :type 'boolean
- :group 'diff-mode)
-
-(defcustom diff-mode-hook nil
- "Run after setting up the `diff-mode' major mode."
- :type 'hook
- :options '(diff-delete-empty-files diff-make-unified)
- :group 'diff-mode)
-
-(defvar diff-outline-regexp
- "\\([*+][*+][*+] [^0-9]\\|@@ ...\\|\\*\\*\\* [0-9].\\|--- [0-9]..\\)")
-
-;;;;
-;;;; keymap, menu, ...
-;;;;
-
-(easy-mmode-defmap diff-mode-shared-map
- '(;; From Pavel Machek's patch-mode.
- ("n" . diff-hunk-next)
- ("N" . diff-file-next)
- ("p" . diff-hunk-prev)
- ("P" . diff-file-prev)
- ("\t" . diff-hunk-next)
- ([backtab] . diff-hunk-prev)
- ("k" . diff-hunk-kill)
- ("K" . diff-file-kill)
- ;; From compilation-minor-mode.
- ("}" . diff-file-next)
- ("{" . diff-file-prev)
- ("\C-m" . diff-goto-source)
- ([mouse-2] . diff-goto-source)
- ;; From XEmacs' diff-mode.
- ;; Standard M-w is useful, so don't change M-W.
- ;;("W" . widen)
- ;;("." . diff-goto-source) ;display-buffer
- ;;("f" . diff-goto-source) ;find-file
- ("o" . diff-goto-source) ;other-window
- ;;("w" . diff-goto-source) ;other-frame
- ;;("N" . diff-narrow)
- ;;("h" . diff-show-header)
- ;;("j" . diff-show-difference) ;jump to Nth diff
- ;;("q" . diff-quit)
- ;; Not useful if you have to metafy them.
- ;;(" " . scroll-up)
- ;;("\177" . scroll-down)
- ;; Standard M-a is useful, so don't change M-A.
- ;;("A" . diff-ediff-patch)
- ;; Standard M-r is useful, so don't change M-r or M-R.
- ;;("r" . diff-restrict-view)
- ;;("R" . diff-reverse-direction)
- ("q" . quit-window))
- "Basic keymap for `diff-mode', bound to various prefix keys.")
-
-(easy-mmode-defmap diff-mode-map
- `(("\e" . ,diff-mode-shared-map)
- ;; From compilation-minor-mode.
- ("\C-c\C-c" . diff-goto-source)
- ;; By analogy with the global C-x 4 a binding.
- ("\C-x4A" . diff-add-change-log-entries-other-window)
- ;; Misc operations.
- ("\C-c\C-a" . diff-apply-hunk)
- ("\C-c\C-e" . diff-ediff-patch)
- ("\C-c\C-n" . diff-restrict-view)
- ("\C-c\C-s" . diff-split-hunk)
- ("\C-c\C-t" . diff-test-hunk)
- ("\C-c\C-r" . diff-reverse-direction)
- ("\C-c\C-u" . diff-context->unified)
- ;; `d' because it duplicates the context :-( --Stef
- ("\C-c\C-d" . diff-unified->context)
- ("\C-c\C-w" . diff-ignore-whitespace-hunk)
- ("\C-c\C-b" . diff-refine-hunk) ;No reason for `b' :-(
- ("\C-c\C-f" . next-error-follow-minor-mode))
- "Keymap for `diff-mode'. See also `diff-mode-shared-map'.")
-
-(easy-menu-define diff-mode-menu diff-mode-map
- "Menu for `diff-mode'."
- '("Diff"
- ["Jump to Source" diff-goto-source
- :help "Jump to the corresponding source line"]
- ["Apply hunk" diff-apply-hunk
- :help "Apply the current hunk to the source file and go to the next"]
- ["Test applying hunk" diff-test-hunk
- :help "See whether it's possible to apply the current hunk"]
- ["Apply diff with Ediff" diff-ediff-patch
- :help "Call `ediff-patch-file' on the current buffer"]
- ["Create Change Log entries" diff-add-change-log-entries-other-window
- :help "Create ChangeLog entries for the changes in the diff buffer"]
- "-----"
- ["Reverse direction" diff-reverse-direction
- :help "Reverse the direction of the diffs"]
- ["Context -> Unified" diff-context->unified
- :help "Convert context diffs to unified diffs"]
- ["Unified -> Context" diff-unified->context
- :help "Convert unified diffs to context diffs"]
- ;;["Fixup Headers" diff-fixup-modifs (not buffer-read-only)]
- ["Show trailing whitespace" whitespace-mode
- :style toggle :selected (bound-and-true-p whitespace-mode)
- :help "Show trailing whitespace in modified lines"]
- "-----"
- ["Split hunk" diff-split-hunk
- :active (diff-splittable-p)
- :help "Split the current (unified diff) hunk at point into two hunks"]
- ["Ignore whitespace changes" diff-ignore-whitespace-hunk
- :help "Re-diff the current hunk, ignoring whitespace differences"]
- ["Highlight fine changes" diff-refine-hunk
- :help "Highlight changes of hunk at point at a finer granularity"]
- ["Kill current hunk" diff-hunk-kill
- :help "Kill current hunk"]
- ["Kill current file's hunks" diff-file-kill
- :help "Kill all current file's hunks"]
- "-----"
- ["Previous Hunk" diff-hunk-prev
- :help "Go to the previous count'th hunk"]
- ["Next Hunk" diff-hunk-next
- :help "Go to the next count'th hunk"]
- ["Previous File" diff-file-prev
- :help "Go to the previous count'th file"]
- ["Next File" diff-file-next
- :help "Go to the next count'th file"]
- ))
-
-(defcustom diff-minor-mode-prefix "\C-c="
- "Prefix key for `diff-minor-mode' commands."
- :type '(choice (string "\e") (string "C-c=") string)
- :group 'diff-mode)
-
-(easy-mmode-defmap diff-minor-mode-map
- `((,diff-minor-mode-prefix . ,diff-mode-shared-map))
- "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'.")
-
-(define-minor-mode diff-auto-refine-mode
- "Automatically highlight changes in detail as the user visits hunks.
-When transitioning from disabled to enabled,
-try to refine the current hunk, as well."
- :group 'diff-mode :init-value t :lighter nil ;; " Auto-Refine"
- (when diff-auto-refine-mode
- (condition-case-no-debug nil (diff-refine-hunk) (error nil))))
-
-;;;;
-;;;; font-lock support
-;;;;
-
-(defface diff-header
- '((((class color) (min-colors 88) (background light))
- :background "grey80")
- (((class color) (min-colors 88) (background dark))
- :background "grey45")
- (((class color) (background light))
- :foreground "blue1" :weight bold)
- (((class color) (background dark))
- :foreground "green" :weight bold)
- (t :weight bold))
- "`diff-mode' face inherited by hunk and index header faces."
- :group 'diff-mode)
-(define-obsolete-face-alias 'diff-header-face 'diff-header "22.1")
-(defvar diff-header-face 'diff-header)
-
-(defface diff-file-header
- '((((class color) (min-colors 88) (background light))
- :background "grey70" :weight bold)
- (((class color) (min-colors 88) (background dark))
- :background "grey60" :weight bold)
- (((class color) (background light))
- :foreground "green" :weight bold)
- (((class color) (background dark))
- :foreground "cyan" :weight bold)
- (t :weight bold)) ; :height 1.3
- "`diff-mode' face used to highlight file header lines."
- :group 'diff-mode)
-(define-obsolete-face-alias 'diff-file-header-face 'diff-file-header "22.1")
-(defvar diff-file-header-face 'diff-file-header)
-
-(defface diff-index
- '((t :inherit diff-file-header))
- "`diff-mode' face used to highlight index header lines."
- :group 'diff-mode)
-(define-obsolete-face-alias 'diff-index-face 'diff-index "22.1")
-(defvar diff-index-face 'diff-index)
-
-(defface diff-hunk-header
- '((t :inherit diff-header))
- "`diff-mode' face used to highlight hunk header lines."
- :group 'diff-mode)
-(define-obsolete-face-alias 'diff-hunk-header-face 'diff-hunk-header "22.1")
-(defvar diff-hunk-header-face 'diff-hunk-header)
-
-(defface diff-removed
- '((t :inherit diff-changed))
- "`diff-mode' face used to highlight removed lines."
- :group 'diff-mode)
-(define-obsolete-face-alias 'diff-removed-face 'diff-removed "22.1")
-(defvar diff-removed-face 'diff-removed)
-
-(defface diff-added
- '((t :inherit diff-changed))
- "`diff-mode' face used to highlight added lines."
- :group 'diff-mode)
-(define-obsolete-face-alias 'diff-added-face 'diff-added "22.1")
-(defvar diff-added-face 'diff-added)
-
-(defface diff-changed
- '((((type tty pc) (class color) (background light))
- :foreground "magenta" :weight bold :slant italic)
- (((type tty pc) (class color) (background dark))
- :foreground "yellow" :weight bold :slant italic))
- "`diff-mode' face used to highlight changed lines."
- :group 'diff-mode)
-(define-obsolete-face-alias 'diff-changed-face 'diff-changed "22.1")
-(defvar diff-changed-face 'diff-changed)
-
-(defface diff-indicator-removed
- '((t :inherit diff-removed))
- "`diff-mode' face used to highlight indicator of removed lines (-, <)."
- :group 'diff-mode
- :version "22.1")
-(defvar diff-indicator-removed-face 'diff-indicator-removed)
-
-(defface diff-indicator-added
- '((t :inherit diff-added))
- "`diff-mode' face used to highlight indicator of added lines (+, >)."
- :group 'diff-mode
- :version "22.1")
-(defvar diff-indicator-added-face 'diff-indicator-added)
-
-(defface diff-indicator-changed
- '((t :inherit diff-changed))
- "`diff-mode' face used to highlight indicator of changed lines."
- :group 'diff-mode
- :version "22.1")
-(defvar diff-indicator-changed-face 'diff-indicator-changed)
-
-(defface diff-function
- '((t :inherit diff-header))
- "`diff-mode' face used to highlight function names produced by \"diff -p\"."
- :group 'diff-mode)
-(define-obsolete-face-alias 'diff-function-face 'diff-function "22.1")
-(defvar diff-function-face 'diff-function)
-
-(defface diff-context
- '((((class color grayscale) (min-colors 88)) :inherit shadow))
- "`diff-mode' face used to highlight context and other side-information."
- :group 'diff-mode)
-(define-obsolete-face-alias 'diff-context-face 'diff-context "22.1")
-(defvar diff-context-face 'diff-context)
-
-(defface diff-nonexistent
- '((t :inherit diff-file-header))
- "`diff-mode' face used to highlight nonexistent files in recursive diffs."
- :group 'diff-mode)
-(define-obsolete-face-alias 'diff-nonexistent-face 'diff-nonexistent "22.1")
-(defvar diff-nonexistent-face 'diff-nonexistent)
-
-(defconst diff-yank-handler '(diff-yank-function))
-(defun diff-yank-function (text)
- ;; FIXME: the yank-handler is now called separately on each piece of text
- ;; with a yank-handler property, so the next-single-property-change call
- ;; below will always return nil :-( --stef
- (let ((mixed (next-single-property-change 0 'yank-handler text))
- (start (point)))
- ;; First insert the text.
- (insert text)
- ;; If the text does not include any diff markers and if we're not
- ;; yanking back into a diff-mode buffer, get rid of the prefixes.
- (unless (or mixed (derived-mode-p 'diff-mode))
- (undo-boundary) ; Just in case the user wanted the prefixes.
- (let ((re (save-excursion
- (if (re-search-backward "^[><!][ \t]" start t)
- (if (eq (char-after) ?!)
- "^[!+- ][ \t]" "^[<>][ \t]")
- "^[ <>!+-]"))))
- (save-excursion
- (while (re-search-backward re start t)
- (replace-match "" t t)))))))
-
-(defconst diff-hunk-header-re-unified
- "^@@ -\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? \\+\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? @@")
-(defconst diff-context-mid-hunk-header-re
- "--- \\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? ----$")
-
-(defvar diff-font-lock-keywords
- `((,(concat "\\(" diff-hunk-header-re-unified "\\)\\(.*\\)$")
- (1 diff-hunk-header-face) (6 diff-function-face))
- ("^\\(\\*\\{15\\}\\)\\(.*\\)$" ;context
- (1 diff-hunk-header-face) (2 diff-function-face))
- ("^\\*\\*\\* .+ \\*\\*\\*\\*". diff-hunk-header-face) ;context
- (,diff-context-mid-hunk-header-re . diff-hunk-header-face) ;context
- ("^[0-9,]+[acd][0-9,]+$" . diff-hunk-header-face) ;normal
- ("^---$" . diff-hunk-header-face) ;normal
- ;; For file headers, accept files with spaces, but be careful to rule
- ;; out false-positives when matching hunk headers.
- ("^\\(---\\|\\+\\+\\+\\|\\*\\*\\*\\) \\([^\t\n]+?\\)\\(?:\t.*\\| \\(\\*\\*\\*\\*\\|----\\)\\)?\n"
- (0 diff-header-face)
- (2 (if (not (match-end 3)) diff-file-header-face) prepend))
- ("^\\([-<]\\)\\(.*\n\\)"
- (1 diff-indicator-removed-face) (2 diff-removed-face))
- ("^\\([+>]\\)\\(.*\n\\)"
- (1 diff-indicator-added-face) (2 diff-added-face))
- ("^\\(!\\)\\(.*\n\\)"
- (1 diff-indicator-changed-face) (2 diff-changed-face))
- ("^Index: \\(.+\\).*\n"
- (0 diff-header-face) (1 diff-index-face prepend))
- ("^Only in .*\n" . diff-nonexistent-face)
- ("^\\(#\\)\\(.*\\)"
- (1 font-lock-comment-delimiter-face)
- (2 font-lock-comment-face))
- ("^[^-=+*!<>#].*\n" (0 diff-context-face))))
-
-(defconst diff-font-lock-defaults
- '(diff-font-lock-keywords t nil nil nil (font-lock-multiline . nil)))
-
-(defvar diff-imenu-generic-expression
- ;; Prefer second name as first is most likely to be a backup or
- ;; version-control name. The [\t\n] at the end of the unidiff pattern
- ;; catches Debian source diff files (which lack the trailing date).
- '((nil "\\+\\+\\+\\ \\([^\t\n]+\\)[\t\n]" 1) ; unidiffs
- (nil "^--- \\([^\t\n]+\\)\t.*\n\\*" 1))) ; context diffs
-
-;;;;
-;;;; Movement
-;;;;
-
-(defvar diff-valid-unified-empty-line t
- "If non-nil, empty lines are valid in unified diffs.
-Some versions of diff replace all-blank context lines in unified format with
-empty lines. This makes the format less robust, but is tolerated.
-See http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01990.html")
-
-(defconst diff-hunk-header-re
- (concat "^\\(?:" diff-hunk-header-re-unified ".*\\|\\*\\{15\\}.*\n\\*\\*\\* .+ \\*\\*\\*\\*\\|[0-9]+\\(,[0-9]+\\)?[acd][0-9]+\\(,[0-9]+\\)?\\)$"))
-(defconst diff-file-header-re (concat "^\\(--- .+\n\\+\\+\\+ \\|\\*\\*\\* .+\n--- \\|[^-+!<>0-9@* \n]\\).+\n" (substring diff-hunk-header-re 1)))
-(defvar diff-narrowed-to nil)
-
-(defun diff-hunk-style (&optional style)
- (when (looking-at diff-hunk-header-re)
- (setq style (cdr (assq (char-after) '((?@ . unified) (?* . context)))))
- (goto-char (match-end 0)))
- style)
-
-(defun diff-end-of-hunk (&optional style donttrustheader)
- (let (end)
- (when (looking-at diff-hunk-header-re)
- ;; Especially important for unified (because headers are ambiguous).
- (setq style (diff-hunk-style style))
- (goto-char (match-end 0))
- (when (and (not donttrustheader) (match-end 2))
- (let* ((nold (string-to-number (or (match-string 2) "1")))
- (nnew (string-to-number (or (match-string 4) "1")))
- (endold
- (save-excursion
- (re-search-forward (if diff-valid-unified-empty-line
- "^[- \n]" "^[- ]")
- nil t nold)
- (line-beginning-position 2)))
- (endnew
- ;; The hunk may end with a bunch of "+" lines, so the `end' is
- ;; then further than computed above.
- (save-excursion
- (re-search-forward (if diff-valid-unified-empty-line
- "^[+ \n]" "^[+ ]")
- nil t nnew)
- (line-beginning-position 2))))
- (setq end (max endold endnew)))))
- ;; We may have a first evaluation of `end' thanks to the hunk header.
- (unless end
- (setq end (and (re-search-forward
- (case style
- (unified (concat (if diff-valid-unified-empty-line
- "^[^-+# \\\n]\\|" "^[^-+# \\]\\|")
- ;; A `unified' header is ambiguous.
- diff-file-header-re))
- (context "^[^-+#! \\]")
- (normal "^[^<>#\\]")
- (t "^[^-+#!<> \\]"))
- nil t)
- (match-beginning 0)))
- (when diff-valid-unified-empty-line
- ;; While empty lines may be valid inside hunks, they are also likely
- ;; to be unrelated to the hunk.
- (goto-char (or end (point-max)))
- (while (eq ?\n (char-before (1- (point))))
- (forward-char -1)
- (setq end (point)))))
- ;; The return value is used by easy-mmode-define-navigation.
- (goto-char (or end (point-max)))))
-
-(defun diff-beginning-of-hunk (&optional try-harder)
- "Move back to beginning of hunk.
-If TRY-HARDER is non-nil, try to cater to the case where we're not in a hunk
-but in the file header instead, in which case move forward to the first hunk."
- (beginning-of-line)
- (unless (looking-at diff-hunk-header-re)
- (forward-line 1)
- (condition-case ()
- (re-search-backward diff-hunk-header-re)
- (error
- (if (not try-harder)
- (error "Can't find the beginning of the hunk")
- (diff-beginning-of-file-and-junk)
- (diff-hunk-next))))))
-
-(defun diff-unified-hunk-p ()
- (save-excursion
- (ignore-errors
- (diff-beginning-of-hunk)
- (looking-at "^@@"))))
-
-(defun diff-beginning-of-file ()
- (beginning-of-line)
- (unless (looking-at diff-file-header-re)
- (let ((start (point))
- res)
- ;; diff-file-header-re may need to match up to 4 lines, so in case
- ;; we're inside the header, we need to move up to 3 lines forward.
- (forward-line 3)
- (if (and (setq res (re-search-backward diff-file-header-re nil t))
- ;; Maybe the 3 lines forward were too much and we matched
- ;; a file header after our starting point :-(
- (or (<= (point) start)
- (setq res (re-search-backward diff-file-header-re nil t))))
- res
- (goto-char start)
- (error "Can't find the beginning of the file")))))
-
-
-(defun diff-end-of-file ()
- (re-search-forward "^[-+#!<>0-9@* \\]" nil t)
- (re-search-forward (concat "^[^-+#!<>0-9@* \\]\\|" diff-file-header-re)
- nil 'move)
- (if (match-beginning 1)
- (goto-char (match-beginning 1))
- (beginning-of-line)))
-
-;; Define diff-{hunk,file}-{prev,next}
-(easy-mmode-define-navigation
- diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view
- (if diff-auto-refine-mode
- (condition-case-no-debug nil (diff-refine-hunk) (error nil))))
-
-(easy-mmode-define-navigation
- diff-file diff-file-header-re "file" diff-end-of-hunk)
-
-(defun diff-restrict-view (&optional arg)
- "Restrict the view to the current hunk.
-If the prefix ARG is given, restrict the view to the current file instead."
- (interactive "P")
- (save-excursion
- (if arg (diff-beginning-of-file) (diff-beginning-of-hunk 'try-harder))
- (narrow-to-region (point)
- (progn (if arg (diff-end-of-file) (diff-end-of-hunk))
- (point)))
- (set (make-local-variable 'diff-narrowed-to) (if arg 'file 'hunk))))
-
-
-(defun diff-hunk-kill ()
- "Kill current hunk."
- (interactive)
- (diff-beginning-of-hunk)
- (let* ((start (point))
- ;; Search the second match, since we're looking at the first.
- (nexthunk (when (re-search-forward diff-hunk-header-re nil t 2)
- (match-beginning 0)))
- (firsthunk (ignore-errors
- (goto-char start)
- (diff-beginning-of-file) (diff-hunk-next) (point)))
- (nextfile (ignore-errors (diff-file-next) (point)))
- (inhibit-read-only t))
- (goto-char start)
- (if (and firsthunk (= firsthunk start)
- (or (null nexthunk)
- (and nextfile (> nexthunk nextfile))))
- ;; It's the only hunk for this file, so kill the file.
- (diff-file-kill)
- (diff-end-of-hunk)
- (kill-region start (point)))))
-
-;; "index ", "old mode", "new mode", "new file mode" and
-;; "deleted file mode" are output by git-diff.
-(defconst diff-file-junk-re
- "diff \\|index \\|\\(?:deleted file\\|new\\(?: file\\)?\\|old\\) mode")
-
-(defun diff-beginning-of-file-and-junk ()
- "Go to the beginning of file-related diff-info.
-This is like `diff-beginning-of-file' except it tries to skip back over leading
-data such as \"Index: ...\" and such."
- (let* ((orig (point))
- ;; Skip forward over what might be "leading junk" so as to get
- ;; closer to the actual diff.
- (_ (progn (beginning-of-line)
- (while (looking-at diff-file-junk-re)
- (forward-line 1))))
- (start (point))
- (prevfile (condition-case err
- (save-excursion (diff-beginning-of-file) (point))
- (error err)))
- (err (if (consp prevfile) prevfile))
- (nextfile (ignore-errors
- (save-excursion
- (goto-char start) (diff-file-next) (point))))
- ;; prevhunk is one of the limits.
- (prevhunk (save-excursion
- (ignore-errors
- (if (numberp prevfile) (goto-char prevfile))
- (diff-hunk-prev) (point))))
- (previndex (save-excursion
- (forward-line 1) ;In case we're looking at "Index:".
- (re-search-backward "^Index: " prevhunk t))))
- ;; If we're in the junk, we should use nextfile instead of prevfile.
- (if (and (numberp nextfile)
- (or (not (numberp prevfile))
- (and previndex (> previndex prevfile))))
- (setq prevfile nextfile))
- (if (and previndex (numberp prevfile) (< previndex prevfile))
- (setq prevfile previndex))
- (if (and (numberp prevfile) (<= prevfile start))
- (progn
- (goto-char prevfile)
- ;; Now skip backward over the leading junk we may have before the
- ;; diff itself.
- (while (save-excursion
- (and (zerop (forward-line -1))
- (looking-at diff-file-junk-re)))
- (forward-line -1)))
- ;; File starts *after* the starting point: we really weren't in
- ;; a file diff but elsewhere.
- (goto-char orig)
- (signal (car err) (cdr err)))))
-
-(defun diff-file-kill ()
- "Kill current file's hunks."
- (interactive)
- (let ((orig (point))
- (start (progn (diff-beginning-of-file-and-junk) (point)))
- (inhibit-read-only t))
- (diff-end-of-file)
- (if (looking-at "^\n") (forward-char 1)) ;`tla' generates such diffs.
- (if (> orig (point)) (error "Not inside a file diff"))
- (kill-region start (point))))
-
-(defun diff-kill-junk ()
- "Kill spurious empty diffs."
- (interactive)
- (save-excursion
- (let ((inhibit-read-only t))
- (goto-char (point-min))
- (while (re-search-forward (concat "^\\(Index: .*\n\\)"
- "\\([^-+!* <>].*\n\\)*?"
- "\\(\\(Index:\\) \\|"
- diff-file-header-re "\\)")
- nil t)
- (delete-region (if (match-end 4) (match-beginning 0) (match-end 1))
- (match-beginning 3))
- (beginning-of-line)))))
-
-(defun diff-count-matches (re start end)
- (save-excursion
- (let ((n 0))
- (goto-char start)
- (while (re-search-forward re end t) (incf n))
- n)))
-
-(defun diff-splittable-p ()
- (save-excursion
- (beginning-of-line)
- (and (looking-at "^[-+ ]")
- (progn (forward-line -1) (looking-at "^[-+ ]"))
- (diff-unified-hunk-p))))
-
-(defun diff-split-hunk ()
- "Split the current (unified diff) hunk at point into two hunks."
- (interactive)
- (beginning-of-line)
- (let ((pos (point))
- (start (progn (diff-beginning-of-hunk) (point))))
- (unless (looking-at diff-hunk-header-re-unified)
- (error "diff-split-hunk only works on unified context diffs"))
- (forward-line 1)
- (let* ((start1 (string-to-number (match-string 1)))
- (start2 (string-to-number (match-string 3)))
- (newstart1 (+ start1 (diff-count-matches "^[- \t]" (point) pos)))
- (newstart2 (+ start2 (diff-count-matches "^[+ \t]" (point) pos)))
- (inhibit-read-only t))
- (goto-char pos)
- ;; Hopefully the after-change-function will not screw us over.
- (insert "@@ -" (number-to-string newstart1) ",1 +"
- (number-to-string newstart2) ",1 @@\n")
- ;; Fix the original hunk-header.
- (diff-fixup-modifs start pos))))
-
-
-;;;;
-;;;; jump to other buffers
-;;;;
-
-(defvar diff-remembered-files-alist nil)
-(defvar diff-remembered-defdir nil)
-
-(defun diff-filename-drop-dir (file)
- (when (string-match "/" file) (substring file (match-end 0))))
-
-(defun diff-merge-strings (ancestor from to)
- "Merge the diff between ANCESTOR and FROM into TO.
-Returns the merged string if successful or nil otherwise.
-The strings are assumed not to contain any \"\\n\" (i.e. end of line).
-If ANCESTOR = FROM, returns TO.
-If ANCESTOR = TO, returns FROM.
-The heuristic is simplistic and only really works for cases
-like \(diff-merge-strings \"b/foo\" \"b/bar\" \"/a/c/foo\")."
- ;; Ideally, we want:
- ;; AMB ANB CMD -> CND
- ;; but that's ambiguous if `foo' or `bar' is empty:
- ;; a/foo a/foo1 b/foo.c -> b/foo1.c but not 1b/foo.c or b/foo.c1
- (let ((str (concat ancestor "\n" from "\n" to)))
- (when (and (string-match (concat
- "\\`\\(.*?\\)\\(.*\\)\\(.*\\)\n"
- "\\1\\(.*\\)\\3\n"
- "\\(.*\\(\\2\\).*\\)\\'") str)
- (equal to (match-string 5 str)))
- (concat (substring str (match-beginning 5) (match-beginning 6))
- (match-string 4 str)
- (substring str (match-end 6) (match-end 5))))))
-
-(defun diff-tell-file-name (old name)
- "Tell Emacs where the find the source file of the current hunk.
-If the OLD prefix arg is passed, tell the file NAME of the old file."
- (interactive
- (let* ((old current-prefix-arg)
- (fs (diff-hunk-file-names current-prefix-arg)))
- (unless fs (error "No file name to look for"))
- (list old (read-file-name (format "File for %s: " (car fs))
- nil (diff-find-file-name old 'noprompt) t))))
- (let ((fs (diff-hunk-file-names old)))
- (unless fs (error "No file name to look for"))
- (push (cons fs name) diff-remembered-files-alist)))
-
-(defun diff-hunk-file-names (&optional old)
- "Give the list of file names textually mentioned for the current hunk."
- (save-excursion
- (unless (looking-at diff-file-header-re)
- (or (ignore-errors (diff-beginning-of-file))
- (re-search-forward diff-file-header-re nil t)))
- (let ((limit (save-excursion
- (condition-case ()
- (progn (diff-hunk-prev) (point))
- (error (point-min)))))
- (header-files
- (if (looking-at "[-*][-*][-*] \\(\\S-+\\)\\(\\s-.*\\)?\n[-+][-+][-+] \\(\\S-+\\)")
- (list (if old (match-string 1) (match-string 3))
- (if old (match-string 3) (match-string 1)))
- (forward-line 1) nil)))
- (delq nil
- (append
- (when (and (not old)
- (save-excursion
- (re-search-backward "^Index: \\(.+\\)" limit t)))
- (list (match-string 1)))
- header-files
- (when (re-search-backward
- "^diff \\(-\\S-+ +\\)*\\(\\S-+\\)\\( +\\(\\S-+\\)\\)?"
- nil t)
- (list (if old (match-string 2) (match-string 4))
- (if old (match-string 4) (match-string 2)))))))))
-
-(defun diff-find-file-name (&optional old noprompt prefix)
- "Return the file corresponding to the current patch.
-Non-nil OLD means that we want the old file.
-Non-nil NOPROMPT means to prefer returning nil than to prompt the user.
-PREFIX is only used internally: don't use it."
- (unless (equal diff-remembered-defdir default-directory)
- ;; Flush diff-remembered-files-alist if the default-directory is changed.
- (set (make-local-variable 'diff-remembered-defdir) default-directory)
- (set (make-local-variable 'diff-remembered-files-alist) nil))
- (save-excursion
- (unless (looking-at diff-file-header-re)
- (or (ignore-errors (diff-beginning-of-file))
- (re-search-forward diff-file-header-re nil t)))
- (let ((fs (diff-hunk-file-names old)))
- (if prefix (setq fs (mapcar (lambda (f) (concat prefix f)) fs)))
- (or
- ;; use any previously used preference
- (cdr (assoc fs diff-remembered-files-alist))
- ;; try to be clever and use previous choices as an inspiration
- (dolist (rf diff-remembered-files-alist)
- (let ((newfile (diff-merge-strings (caar rf) (car fs) (cdr rf))))
- (if (and newfile (file-exists-p newfile)) (return newfile))))
- ;; look for each file in turn. If none found, try again but
- ;; ignoring the first level of directory, ...
- (do* ((files fs (delq nil (mapcar 'diff-filename-drop-dir files)))
- (file nil nil))
- ((or (null files)
- (setq file (do* ((files files (cdr files))
- (file (car files) (car files)))
- ;; Use file-regular-p to avoid
- ;; /dev/null, directories, etc.
- ((or (null file) (file-regular-p file))
- file))))
- file))
- ;; <foo>.rej patches implicitly apply to <foo>
- (and (string-match "\\.rej\\'" (or buffer-file-name ""))
- (let ((file (substring buffer-file-name 0 (match-beginning 0))))
- (when (file-exists-p file) file)))
- ;; If we haven't found the file, maybe it's because we haven't paid
- ;; attention to the PCL-CVS hint.
- (and (not prefix)
- (boundp 'cvs-pcl-cvs-dirchange-re)
- (save-excursion
- (re-search-backward cvs-pcl-cvs-dirchange-re nil t))
- (diff-find-file-name old noprompt (match-string 1)))
- ;; if all else fails, ask the user
- (unless noprompt
- (let ((file (read-file-name (format "Use file %s: "
- (or (first fs) ""))
- nil (first fs) t (first fs))))
- (set (make-local-variable 'diff-remembered-files-alist)
- (cons (cons fs file) diff-remembered-files-alist))
- file))))))
-
-
-(defun diff-ediff-patch ()
- "Call `ediff-patch-file' on the current buffer."
- (interactive)
- (condition-case err
- (ediff-patch-file nil (current-buffer))
- (wrong-number-of-arguments (ediff-patch-file))))
-
-;;;;
-;;;; Conversion functions
-;;;;
-
-;;(defvar diff-inhibit-after-change nil
-;; "Non-nil means inhibit `diff-mode's after-change functions.")
-
-(defun diff-unified->context (start end)
- "Convert unified diffs to context diffs.
-START and END are either taken from the region (if a prefix arg is given) or
-else cover the whole buffer."
- (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active))
- (list (region-beginning) (region-end))
- (list (point-min) (point-max))))
- (unless (markerp end) (setq end (copy-marker end t)))
- (let (;;(diff-inhibit-after-change t)
- (inhibit-read-only t))
- (save-excursion
- (goto-char start)
- (while (and (re-search-forward
- (concat "^\\(\\(---\\) .+\n\\(\\+\\+\\+\\) .+\\|"
- diff-hunk-header-re-unified ".*\\)$")
- nil t)
- (< (point) end))
- (combine-after-change-calls
- (if (match-beginning 2)
- ;; we matched a file header
- (progn
- ;; use reverse order to make sure the indices are kept valid
- (replace-match "---" t t nil 3)
- (replace-match "***" t t nil 2))
- ;; we matched a hunk header
- (let ((line1 (match-string 4))
- (lines1 (or (match-string 5) "1"))
- (line2 (match-string 6))
- (lines2 (or (match-string 7) "1"))
- ;; Variables to use the special undo function.
- (old-undo buffer-undo-list)
- (old-end (marker-position end))
- (start (match-beginning 0))
- (reversible t))
- (replace-match
- (concat "***************\n*** " line1 ","
- (number-to-string (+ (string-to-number line1)
- (string-to-number lines1)
- -1))
- " ****"))
- (save-restriction
- (narrow-to-region (line-beginning-position 2)
- ;; Call diff-end-of-hunk from just before
- ;; the hunk header so it can use the hunk
- ;; header info.
- (progn (diff-end-of-hunk 'unified) (point)))
- (let ((hunk (buffer-string)))
- (goto-char (point-min))
- (if (not (save-excursion (re-search-forward "^-" nil t)))
- (delete-region (point) (point-max))
- (goto-char (point-max))
- (let ((modif nil) last-pt)
- (while (progn (setq last-pt (point))
- (= (forward-line -1) 0))
- (case (char-after)
- (?\s (insert " ") (setq modif nil) (backward-char 1))
- (?+ (delete-region (point) last-pt) (setq modif t))
- (?- (if (not modif)
- (progn (forward-char 1)
- (insert " "))
- (delete-char 1)
- (insert "! "))
- (backward-char 2))
- (?\\ (when (save-excursion (forward-line -1)
- (= (char-after) ?+))
- (delete-region (point) last-pt) (setq modif t)))
- ;; diff-valid-unified-empty-line.
- (?\n (insert " ") (setq modif nil) (backward-char 2))
- (t (setq modif nil))))))
- (goto-char (point-max))
- (save-excursion
- (insert "--- " line2 ","
- (number-to-string (+ (string-to-number line2)
- (string-to-number lines2)
- -1))
- " ----\n" hunk))
- ;;(goto-char (point-min))
- (forward-line 1)
- (if (not (save-excursion (re-search-forward "^+" nil t)))
- (delete-region (point) (point-max))
- (let ((modif nil) (delete nil))
- (if (save-excursion (re-search-forward "^\\+.*\n-" nil t))
- ;; Normally, lines in a substitution come with
- ;; first the removals and then the additions, and
- ;; the context->unified function follows this
- ;; convention, of course. Yet, other alternatives
- ;; are valid as well, but they preclude the use of
- ;; context->unified as an undo command.
- (setq reversible nil))
- (while (not (eobp))
- (case (char-after)
- (?\s (insert " ") (setq modif nil) (backward-char 1))
- (?- (setq delete t) (setq modif t))
- (?+ (if (not modif)
- (progn (forward-char 1)
- (insert " "))
- (delete-char 1)
- (insert "! "))
- (backward-char 2))
- (?\\ (when (save-excursion (forward-line 1)
- (not (eobp)))
- (setq delete t) (setq modif t)))
- ;; diff-valid-unified-empty-line.
- (?\n (insert " ") (setq modif nil) (backward-char 2)
- (setq reversible nil))
- (t (setq modif nil)))
- (let ((last-pt (point)))
- (forward-line 1)
- (when delete
- (delete-region last-pt (point))
- (setq delete nil)))))))
- (unless (or (not reversible) (eq buffer-undo-list t))
- ;; Drop the many undo entries and replace them with
- ;; a single entry that uses diff-context->unified to do
- ;; the work.
- (setq buffer-undo-list
- (cons (list 'apply (- old-end end) start (point-max)
- 'diff-context->unified start (point-max))
- old-undo)))))))))))
-
-(defun diff-context->unified (start end &optional to-context)
- "Convert context diffs to unified diffs.
-START and END are either taken from the region
-\(when it is highlighted) or else cover the whole buffer.
-With a prefix argument, convert unified format to context format."
- (interactive (if (and transient-mark-mode mark-active)
- (list (region-beginning) (region-end) current-prefix-arg)
- (list (point-min) (point-max) current-prefix-arg)))
- (if to-context
- (diff-unified->context start end)
- (unless (markerp end) (setq end (copy-marker end t)))
- (let ( ;;(diff-inhibit-after-change t)
- (inhibit-read-only t))
- (save-excursion
- (goto-char start)
- (while (and (re-search-forward "^\\(\\(\\*\\*\\*\\) .+\n\\(---\\) .+\\|\\*\\{15\\}.*\n\\*\\*\\* \\([0-9]+\\),\\(-?[0-9]+\\) \\*\\*\\*\\*\\)$" nil t)
- (< (point) end))
- (combine-after-change-calls
- (if (match-beginning 2)
- ;; we matched a file header
- (progn
- ;; use reverse order to make sure the indices are kept valid
- (replace-match "+++" t t nil 3)
- (replace-match "---" t t nil 2))
- ;; we matched a hunk header
- (let ((line1s (match-string 4))
- (line1e (match-string 5))
- (pt1 (match-beginning 0))
- ;; Variables to use the special undo function.
- (old-undo buffer-undo-list)
- (old-end (marker-position end))
- (reversible t))
- (replace-match "")
- (unless (re-search-forward
- diff-context-mid-hunk-header-re nil t)
- (error "Can't find matching `--- n1,n2 ----' line"))
- (let ((line2s (match-string 1))
- (line2e (match-string 2))
- (pt2 (progn
- (delete-region (progn (beginning-of-line) (point))
- (progn (forward-line 1) (point)))
- (point-marker))))
- (goto-char pt1)
- (forward-line 1)
- (while (< (point) pt2)
- (case (char-after)
- (?! (delete-char 2) (insert "-") (forward-line 1))
- (?- (forward-char 1) (delete-char 1) (forward-line 1))
- (?\s ;merge with the other half of the chunk
- (let* ((endline2
- (save-excursion
- (goto-char pt2) (forward-line 1) (point))))
- (case (char-after pt2)
- ((?! ?+)
- (insert "+"
- (prog1 (buffer-substring (+ pt2 2) endline2)
- (delete-region pt2 endline2))))
- (?\s
- (unless (= (- endline2 pt2)
- (- (line-beginning-position 2) (point)))
- ;; If the two lines we're merging don't have the
- ;; same length (can happen with "diff -b"), then
- ;; diff-unified->context will not properly undo
- ;; this operation.
- (setq reversible nil))
- (delete-region pt2 endline2)
- (delete-char 1)
- (forward-line 1))
- (?\\ (forward-line 1))
- (t (setq reversible nil)
- (delete-char 1) (forward-line 1)))))
- (t (setq reversible nil) (forward-line 1))))
- (while (looking-at "[+! ] ")
- (if (/= (char-after) ?!) (forward-char 1)
- (delete-char 1) (insert "+"))
- (delete-char 1) (forward-line 1))
- (save-excursion
- (goto-char pt1)
- (insert "@@ -" line1s ","
- (number-to-string (- (string-to-number line1e)
- (string-to-number line1s)
- -1))
- " +" line2s ","
- (number-to-string (- (string-to-number line2e)
- (string-to-number line2s)
- -1)) " @@"))
- (set-marker pt2 nil)
- ;; The whole procedure succeeded, let's replace the myriad
- ;; of undo elements with just a single special one.
- (unless (or (not reversible) (eq buffer-undo-list t))
- (setq buffer-undo-list
- (cons (list 'apply (- old-end end) pt1 (point)
- 'diff-unified->context pt1 (point))
- old-undo)))
- )))))))))
-
-(defun diff-reverse-direction (start end)
- "Reverse the direction of the diffs.
-START and END are either taken from the region (if a prefix arg is given) or
-else cover the whole buffer."
- (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active))
- (list (region-beginning) (region-end))
- (list (point-min) (point-max))))
- (unless (markerp end) (setq end (copy-marker end t)))
- (let (;;(diff-inhibit-after-change t)
- (inhibit-read-only t))
- (save-excursion
- (goto-char start)
- (while (and (re-search-forward "^\\(\\([-*][-*][-*] \\)\\(.+\\)\n\\([-+][-+][-+] \\)\\(.+\\)\\|\\*\\{15\\}.*\n\\*\\*\\* \\(.+\\) \\*\\*\\*\\*\\|@@ -\\([0-9,]+\\) \\+\\([0-9,]+\\) @@.*\\)$" nil t)
- (< (point) end))
- (combine-after-change-calls
- (cond
- ;; a file header
- ((match-beginning 2) (replace-match "\\2\\5\n\\4\\3" nil))
- ;; a context-diff hunk header
- ((match-beginning 6)
- (let ((pt-lines1 (match-beginning 6))
- (lines1 (match-string 6)))
- (replace-match "" nil nil nil 6)
- (forward-line 1)
- (let ((half1s (point)))
- (while (looking-at "[-! \\][ \t]\\|#")
- (when (= (char-after) ?-) (delete-char 1) (insert "+"))
- (forward-line 1))
- (let ((half1 (delete-and-extract-region half1s (point))))
- (unless (looking-at diff-context-mid-hunk-header-re)
- (insert half1)
- (error "Can't find matching `--- n1,n2 ----' line"))
- (let* ((str1end (or (match-end 2) (match-end 1)))
- (str1 (buffer-substring (match-beginning 1) str1end)))
- (goto-char str1end)
- (insert lines1)
- (delete-region (match-beginning 1) str1end)
- (forward-line 1)
- (let ((half2s (point)))
- (while (looking-at "[!+ \\][ \t]\\|#")
- (when (= (char-after) ?+) (delete-char 1) (insert "-"))
- (forward-line 1))
- (let ((half2 (delete-and-extract-region half2s (point))))
- (insert (or half1 ""))
- (goto-char half1s)
- (insert (or half2 ""))))
- (goto-char pt-lines1)
- (insert str1))))))
- ;; a unified-diff hunk header
- ((match-beginning 7)
- (replace-match "@@ -\\8 +\\7 @@" nil)
- (forward-line 1)
- (let ((c (char-after)) first last)
- (while (case (setq c (char-after))
- (?- (setq first (or first (point)))
- (delete-char 1) (insert "+") t)
- (?+ (setq last (or last (point)))
- (delete-char 1) (insert "-") t)
- ((?\\ ?#) t)
- (t (when (and first last (< first last))
- (insert (delete-and-extract-region first last)))
- (setq first nil last nil)
- (memq c (if diff-valid-unified-empty-line
- '(?\s ?\n) '(?\s)))))
- (forward-line 1))))))))))
-
-(defun diff-fixup-modifs (start end)
- "Fixup the hunk headers (in case the buffer was modified).
-START and END are either taken from the region (if a prefix arg is given) or
-else cover the whole buffer."
- (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active))
- (list (region-beginning) (region-end))
- (list (point-min) (point-max))))
- (let ((inhibit-read-only t))
- (save-excursion
- (goto-char end) (diff-end-of-hunk nil 'donttrustheader)
- (let ((plus 0) (minus 0) (space 0) (bang 0))
- (while (and (= (forward-line -1) 0) (<= start (point)))
- (if (not (looking-at
- (concat diff-hunk-header-re-unified
- "\\|[-*][-*][-*] [0-9,]+ [-*][-*][-*][-*]$"
- "\\|--- .+\n\\+\\+\\+ ")))
- (case (char-after)
- (?\s (incf space))
- (?+ (incf plus))
- (?- (incf minus))
- (?! (incf bang))
- ((?\\ ?#) nil)
- (t (setq space 0 plus 0 minus 0 bang 0)))
- (cond
- ((looking-at diff-hunk-header-re-unified)
- (let* ((old1 (match-string 2))
- (old2 (match-string 4))
- (new1 (number-to-string (+ space minus)))
- (new2 (number-to-string (+ space plus))))
- (if old2
- (unless (string= new2 old2) (replace-match new2 t t nil 4))
- (goto-char (match-end 4)) (insert "," new2))
- (if old1
- (unless (string= new1 old1) (replace-match new1 t t nil 2))
- (goto-char (match-end 2)) (insert "," new1))))
- ((looking-at diff-context-mid-hunk-header-re)
- (when (> (+ space bang plus) 0)
- (let* ((old1 (match-string 1))
- (old2 (match-string 2))
- (new (number-to-string
- (+ space bang plus -1 (string-to-number old1)))))
- (unless (string= new old2) (replace-match new t t nil 2)))))
- ((looking-at "\\*\\*\\* \\([0-9]+\\),\\(-?[0-9]*\\) \\*\\*\\*\\*$")
- (when (> (+ space bang minus) 0)
- (let* ((old (match-string 1))
- (new (format
- (concat "%0" (number-to-string (length old)) "d")
- (+ space bang minus -1 (string-to-number old)))))
- (unless (string= new old) (replace-match new t t nil 2))))))
- (setq space 0 plus 0 minus 0 bang 0)))))))
-
-;;;;
-;;;; Hooks
-;;;;
-
-(defun diff-write-contents-hooks ()
- "Fixup hunk headers if necessary."
- (if (buffer-modified-p) (diff-fixup-modifs (point-min) (point-max)))
- nil)
-
-;; It turns out that making changes in the buffer from within an
-;; *-change-function is asking for trouble, whereas making them
-;; from a post-command-hook doesn't pose much problems
-(defvar diff-unhandled-changes nil)
-(defun diff-after-change-function (beg end len)
- "Remember to fixup the hunk header.
-See `after-change-functions' for the meaning of BEG, END and LEN."
- ;; Ignoring changes when inhibit-read-only is set is strictly speaking
- ;; incorrect, but it turns out that inhibit-read-only is normally not set
- ;; inside editing commands, while it tends to be set when the buffer gets
- ;; updated by an async process or by a conversion function, both of which
- ;; would rather not be uselessly slowed down by this hook.
- (when (and (not undo-in-progress) (not inhibit-read-only))
- (if diff-unhandled-changes
- (setq diff-unhandled-changes
- (cons (min beg (car diff-unhandled-changes))
- (max end (cdr diff-unhandled-changes))))
- (setq diff-unhandled-changes (cons beg end)))))
-
-(defun diff-post-command-hook ()
- "Fixup hunk headers if necessary."
- (when (consp diff-unhandled-changes)
- (ignore-errors
- (save-excursion
- (goto-char (car diff-unhandled-changes))
- ;; Maybe we've cut the end of the hunk before point.
- (if (and (bolp) (not (bobp))) (backward-char 1))
- ;; We used to fixup modifs on all the changes, but it turns out that
- ;; it's safer not to do it on big changes, e.g. when yanking a big
- ;; diff, or when the user edits the header, since we might then
- ;; screw up perfectly correct values. --Stef
- (diff-beginning-of-hunk)
- (let* ((style (if (looking-at "\\*\\*\\*") 'context))
- (start (line-beginning-position (if (eq style 'context) 3 2)))
- (mid (if (eq style 'context)
- (save-excursion
- (re-search-forward diff-context-mid-hunk-header-re
- nil t)))))
- (when (and ;; Don't try to fixup changes in the hunk header.
- (> (car diff-unhandled-changes) start)
- ;; Don't try to fixup changes in the mid-hunk header either.
- (or (not mid)
- (< (cdr diff-unhandled-changes) (match-beginning 0))
- (> (car diff-unhandled-changes) (match-end 0)))
- (save-excursion
- (diff-end-of-hunk nil 'donttrustheader)
- ;; Don't try to fixup changes past the end of the hunk.
- (>= (point) (cdr diff-unhandled-changes))))
- (diff-fixup-modifs (point) (cdr diff-unhandled-changes)))))
- (setq diff-unhandled-changes nil))))
-
-(defun diff-next-error (arg reset)
- ;; Select a window that displays the current buffer so that point
- ;; movements are reflected in that window. Otherwise, the user might
- ;; never see the hunk corresponding to the source she's jumping to.
- (pop-to-buffer (current-buffer))
- (if reset (goto-char (point-min)))
- (diff-hunk-next arg)
- (diff-goto-source))
-
-(defvar whitespace-style)
-(defvar whitespace-trailing-regexp)
-
-;;;###autoload
-(define-derived-mode diff-mode fundamental-mode "Diff"
- "Major mode for viewing/editing context diffs.
-Supports unified and context diffs as well as (to a lesser extent)
-normal diffs.
-
-When the buffer is read-only, the ESC prefix is not necessary.
-If you edit the buffer manually, diff-mode will try to update the hunk
-headers for you on-the-fly.
-
-You can also switch between context diff and unified diff with \\[diff-context->unified],
-or vice versa with \\[diff-unified->context] and you can also reverse the direction of
-a diff with \\[diff-reverse-direction].
-
- \\{diff-mode-map}"
-
- (set (make-local-variable 'font-lock-defaults) diff-font-lock-defaults)
- (set (make-local-variable 'outline-regexp) diff-outline-regexp)
- (set (make-local-variable 'imenu-generic-expression)
- diff-imenu-generic-expression)
- ;; These are not perfect. They would be better done separately for
- ;; context diffs and unidiffs.
- ;; (set (make-local-variable 'paragraph-start)
- ;; (concat "@@ " ; unidiff hunk
- ;; "\\|\\*\\*\\* " ; context diff hunk or file start
- ;; "\\|--- [^\t]+\t")) ; context or unidiff file
- ;; ; start (first or second line)
- ;; (set (make-local-variable 'paragraph-separate) paragraph-start)
- ;; (set (make-local-variable 'page-delimiter) "--- [^\t]+\t")
- ;; compile support
- (set (make-local-variable 'next-error-function) 'diff-next-error)
-
- (set (make-local-variable 'beginning-of-defun-function)
- 'diff-beginning-of-file-and-junk)
- (set (make-local-variable 'end-of-defun-function)
- 'diff-end-of-file)
-
- ;; Set up `whitespace-mode' so that turning it on will show trailing
- ;; whitespace problems on the modified lines of the diff.
- (set (make-local-variable 'whitespace-style) '(trailing))
- (set (make-local-variable 'whitespace-trailing-regexp)
- "^[-\+!<>].*?\\([\t ]+\\)$")
-
- (setq buffer-read-only diff-default-read-only)
- ;; setup change hooks
- (if (not diff-update-on-the-fly)
- (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t)
- (make-local-variable 'diff-unhandled-changes)
- (add-hook 'after-change-functions 'diff-after-change-function nil t)
- (add-hook 'post-command-hook 'diff-post-command-hook nil t))
- ;; Neat trick from Dave Love to add more bindings in read-only mode:
- (lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
- (add-to-list 'minor-mode-overriding-map-alist ro-bind)
- ;; Turn off this little trick in case the buffer is put in view-mode.
- (add-hook 'view-mode-hook
- (lambda ()
- (setq minor-mode-overriding-map-alist
- (delq ro-bind minor-mode-overriding-map-alist)))
- nil t))
- ;; add-log support
- (set (make-local-variable 'add-log-current-defun-function)
- 'diff-current-defun)
- (set (make-local-variable 'add-log-buffer-file-name-function)
- (lambda () (diff-find-file-name nil 'noprompt)))
- (unless (buffer-file-name)
- (hack-dir-local-variables-non-file-buffer)))
-
-;;;###autoload
-(define-minor-mode diff-minor-mode
- "Minor mode for viewing/editing context diffs.
-\\{diff-minor-mode-map}"
- :group 'diff-mode :lighter " Diff"
- ;; FIXME: setup font-lock
- ;; setup change hooks
- (if (not diff-update-on-the-fly)
- (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t)
- (make-local-variable 'diff-unhandled-changes)
- (add-hook 'after-change-functions 'diff-after-change-function nil t)
- (add-hook 'post-command-hook 'diff-post-command-hook nil t)))
-
-;;; Handy hook functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun diff-delete-if-empty ()
- ;; An empty diff file means there's no more diffs to integrate, so we
- ;; can just remove the file altogether. Very handy for .rej files if we
- ;; remove hunks as we apply them.
- (when (and buffer-file-name
- (eq 0 (nth 7 (file-attributes buffer-file-name))))
- (delete-file buffer-file-name)))
-
-(defun diff-delete-empty-files ()
- "Arrange for empty diff files to be removed."
- (add-hook 'after-save-hook 'diff-delete-if-empty nil t))
-
-(defun diff-make-unified ()
- "Turn context diffs into unified diffs if applicable."
- (if (save-excursion
- (goto-char (point-min))
- (and (looking-at diff-hunk-header-re) (eq (char-after) ?*)))
- (let ((mod (buffer-modified-p)))
- (unwind-protect
- (diff-context->unified (point-min) (point-max))
- (restore-buffer-modified-p mod)))))
-
-;;;
-;;; Misc operations that have proved useful at some point.
-;;;
-
-(defun diff-next-complex-hunk ()
- "Jump to the next \"complex\" hunk.
-\"Complex\" is approximated by \"the hunk changes the number of lines\".
-Only works for unified diffs."
- (interactive)
- (while
- (and (re-search-forward diff-hunk-header-re-unified nil t)
- (equal (match-string 2) (match-string 4)))))
-
-(defun diff-sanity-check-context-hunk-half (lines)
- (let ((count lines))
- (while
- (cond
- ((and (memq (char-after) '(?\s ?! ?+ ?-))
- (memq (char-after (1+ (point))) '(?\s ?\t)))
- (decf count) t)
- ((or (zerop count) (= count lines)) nil)
- ((memq (char-after) '(?! ?+ ?-))
- (if (not (and (eq (char-after (1+ (point))) ?\n)
- (y-or-n-p "Try to auto-fix whitespace loss damage? ")))
- (error "End of hunk ambiguously marked")
- (forward-char 1) (insert " ") (forward-line -1) t))
- ((< lines 0)
- (error "End of hunk ambiguously marked"))
- ((not (y-or-n-p "Try to auto-fix whitespace loss and word-wrap damage? "))
- (error "Abort!"))
- ((eolp) (insert " ") (forward-line -1) t)
- (t (insert " ") (delete-region (- (point) 2) (- (point) 1)) t))
- (forward-line))))
-
-(defun diff-sanity-check-hunk ()
- (let (;; Every modification is protected by a y-or-n-p, so it's probably
- ;; OK to override a read-only setting.
- (inhibit-read-only t))
- (save-excursion
- (cond
- ((not (looking-at diff-hunk-header-re))
- (error "Not recognizable hunk header"))
-
- ;; A context diff.
- ((eq (char-after) ?*)
- (if (not (looking-at "\\*\\{15\\}\\(?: .*\\)?\n\\*\\*\\* \\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? \\*\\*\\*\\*"))
- (error "Unrecognized context diff first hunk header format")
- (forward-line 2)
- (diff-sanity-check-context-hunk-half
- (if (match-end 2)
- (1+ (- (string-to-number (match-string 2))
- (string-to-number (match-string 1))))
- 1))
- (if (not (looking-at diff-context-mid-hunk-header-re))
- (error "Unrecognized context diff second hunk header format")
- (forward-line)
- (diff-sanity-check-context-hunk-half
- (if (match-end 2)
- (1+ (- (string-to-number (match-string 2))
- (string-to-number (match-string 1))))
- 1)))))
-
- ;; A unified diff.
- ((eq (char-after) ?@)
- (if (not (looking-at diff-hunk-header-re-unified))
- (error "Unrecognized unified diff hunk header format")
- (let ((before (string-to-number (or (match-string 2) "1")))
- (after (string-to-number (or (match-string 4) "1"))))
- (forward-line)
- (while
- (case (char-after)
- (?\s (decf before) (decf after) t)
- (?-
- (if (and (looking-at diff-file-header-re)
- (zerop before) (zerop after))
- ;; No need to query: this is a case where two patches
- ;; are concatenated and only counting the lines will
- ;; give the right result. Let's just add an empty
- ;; line so that our code which doesn't count lines
- ;; will not get confused.
- (progn (save-excursion (insert "\n")) nil)
- (decf before) t))
- (?+ (decf after) t)
- (t
- (cond
- ((and diff-valid-unified-empty-line
- ;; Not just (eolp) so we don't infloop at eob.
- (eq (char-after) ?\n)
- (> before 0) (> after 0))
- (decf before) (decf after) t)
- ((and (zerop before) (zerop after)) nil)
- ((or (< before 0) (< after 0))
- (error (if (or (zerop before) (zerop after))
- "End of hunk ambiguously marked"
- "Hunk seriously messed up")))
- ((not (y-or-n-p (concat "Try to auto-fix " (if (eolp) "whitespace loss" "word-wrap damage") "? ")))
- (error "Abort!"))
- ((eolp) (insert " ") (forward-line -1) t)
- (t (insert " ")
- (delete-region (- (point) 2) (- (point) 1)) t))))
- (forward-line)))))
-
- ;; A plain diff.
- (t
- ;; TODO.
- )))))
-
-(defun diff-hunk-text (hunk destp char-offset)
- "Return the literal source text from HUNK as (TEXT . OFFSET).
-If DESTP is nil, TEXT is the source, otherwise the destination text.
-CHAR-OFFSET is a char-offset in HUNK, and OFFSET is the corresponding
-char-offset in TEXT."
- (with-temp-buffer
- (insert hunk)
- (goto-char (point-min))
- (let ((src-pos nil)
- (dst-pos nil)
- (divider-pos nil)
- (num-pfx-chars 2))
- ;; Set the following variables:
- ;; SRC-POS buffer pos of the source part of the hunk or nil if none
- ;; DST-POS buffer pos of the destination part of the hunk or nil
- ;; DIVIDER-POS buffer pos of any divider line separating the src & dst
- ;; NUM-PFX-CHARS number of line-prefix characters used by this format"
- (cond ((looking-at "^@@")
- ;; unified diff
- (setq num-pfx-chars 1)
- (forward-line 1)
- (setq src-pos (point) dst-pos (point)))
- ((looking-at "^\\*\\*")
- ;; context diff
- (forward-line 2)
- (setq src-pos (point))
- (re-search-forward diff-context-mid-hunk-header-re nil t)
- (forward-line 0)
- (setq divider-pos (point))
- (forward-line 1)
- (setq dst-pos (point)))
- ((looking-at "^[0-9]+a[0-9,]+$")
- ;; normal diff, insert
- (forward-line 1)
- (setq dst-pos (point)))
- ((looking-at "^[0-9,]+d[0-9]+$")
- ;; normal diff, delete
- (forward-line 1)
- (setq src-pos (point)))
- ((looking-at "^[0-9,]+c[0-9,]+$")
- ;; normal diff, change
- (forward-line 1)
- (setq src-pos (point))
- (re-search-forward "^---$" nil t)
- (forward-line 0)
- (setq divider-pos (point))
- (forward-line 1)
- (setq dst-pos (point)))
- (t
- (error "Unknown diff hunk type")))
-
- (if (if destp (null dst-pos) (null src-pos))
- ;; Implied empty text
- (if char-offset '("" . 0) "")
-
- ;; For context diffs, either side can be empty, (if there's only
- ;; added or only removed text). We should then use the other side.
- (cond ((equal src-pos divider-pos) (setq src-pos dst-pos))
- ((equal dst-pos (point-max)) (setq dst-pos src-pos)))
-
- (when char-offset (goto-char (+ (point-min) char-offset)))
-
- ;; Get rid of anything except the desired text.
- (save-excursion
- ;; Delete unused text region
- (let ((keep (if destp dst-pos src-pos)))
- (when (and divider-pos (> divider-pos keep))
- (delete-region divider-pos (point-max)))
- (delete-region (point-min) keep))
- ;; Remove line-prefix characters, and unneeded lines (unified diffs).
- (let ((kill-char (if destp ?- ?+)))
- (goto-char (point-min))
- (while (not (eobp))
- (if (eq (char-after) kill-char)
- (delete-region (point) (progn (forward-line 1) (point)))
- (delete-char num-pfx-chars)
- (forward-line 1)))))
-
- (let ((text (buffer-substring-no-properties (point-min) (point-max))))
- (if char-offset (cons text (- (point) (point-min))) text))))))
-
-
-(defun diff-find-text (text)
- "Return the buffer position (BEG . END) of the nearest occurrence of TEXT.
-If TEXT isn't found, nil is returned."
- (let* ((orig (point))
- (forw (and (search-forward text nil t)
- (cons (match-beginning 0) (match-end 0))))
- (back (and (goto-char (+ orig (length text)))
- (search-backward text nil t)
- (cons (match-beginning 0) (match-end 0)))))
- ;; Choose the closest match.
- (if (and forw back)
- (if (> (- (car forw) orig) (- orig (car back))) back forw)
- (or back forw))))
-
-(defun diff-find-approx-text (text)
- "Return the buffer position (BEG . END) of the nearest occurrence of TEXT.
-Whitespace differences are ignored."
- (let* ((orig (point))
- (re (concat "^[ \t\n\f]*"
- (mapconcat 'regexp-quote (split-string text) "[ \t\n\f]+")
- "[ \t\n\f]*\n"))
- (forw (and (re-search-forward re nil t)
- (cons (match-beginning 0) (match-end 0))))
- (back (and (goto-char (+ orig (length text)))
- (re-search-backward re nil t)
- (cons (match-beginning 0) (match-end 0)))))
- ;; Choose the closest match.
- (if (and forw back)
- (if (> (- (car forw) orig) (- orig (car back))) back forw)
- (or back forw))))
-
-(defsubst diff-xor (a b) (if a (if (not b) a) b))
-
-(defun diff-find-source-location (&optional other-file reverse noprompt)
- "Find out (BUF LINE-OFFSET POS SRC DST SWITCHED).
-BUF is the buffer corresponding to the source file.
-LINE-OFFSET is the offset between the expected and actual positions
- of the text of the hunk or nil if the text was not found.
-POS is a pair (BEG . END) indicating the position of the text in the buffer.
-SRC and DST are the two variants of text as returned by `diff-hunk-text'.
- SRC is the variant that was found in the buffer.
-SWITCHED is non-nil if the patch is already applied.
-NOPROMPT, if non-nil, means not to prompt the user."
- (save-excursion
- (let* ((other (diff-xor other-file diff-jump-to-old-file))
- (char-offset (- (point) (progn (diff-beginning-of-hunk 'try-harder)
- (point))))
- ;; Check that the hunk is well-formed. Otherwise diff-mode and
- ;; the user may disagree on what constitutes the hunk
- ;; (e.g. because an empty line truncates the hunk mid-course),
- ;; leading to potentially nasty surprises for the user.
- ;;
- ;; Suppress check when NOPROMPT is non-nil (Bug#3033).
- (_ (unless noprompt (diff-sanity-check-hunk)))
- (hunk (buffer-substring
- (point) (save-excursion (diff-end-of-hunk) (point))))
- (old (diff-hunk-text hunk reverse char-offset))
- (new (diff-hunk-text hunk (not reverse) char-offset))
- ;; Find the location specification.
- (line (if (not (looking-at "\\(?:\\*\\{15\\}.*\n\\)?[-@* ]*\\([0-9,]+\\)\\([ acd+]+\\([0-9,]+\\)\\)?"))
- (error "Can't find the hunk header")
- (if other (match-string 1)
- (if (match-end 3) (match-string 3)
- (unless (re-search-forward
- diff-context-mid-hunk-header-re nil t)
- (error "Can't find the hunk separator"))
- (match-string 1)))))
- (file (or (diff-find-file-name other noprompt)
- (error "Can't find the file")))
- (buf (find-file-noselect file)))
- ;; Update the user preference if he so wished.
- (when (> (prefix-numeric-value other-file) 8)
- (setq diff-jump-to-old-file other))
- (with-current-buffer buf
- (goto-char (point-min)) (forward-line (1- (string-to-number line)))
- (let* ((orig-pos (point))
- (switched nil)
- ;; FIXME: Check for case where both OLD and NEW are found.
- (pos (or (diff-find-text (car old))
- (progn (setq switched t) (diff-find-text (car new)))
- (progn (setq switched nil)
- (condition-case nil
- (diff-find-approx-text (car old))
- (invalid-regexp nil))) ;Regex too big.
- (progn (setq switched t)
- (condition-case nil
- (diff-find-approx-text (car new))
- (invalid-regexp nil))) ;Regex too big.
- (progn (setq switched nil) nil))))
- (nconc
- (list buf)
- (if pos
- (list (count-lines orig-pos (car pos)) pos)
- (list nil (cons orig-pos (+ orig-pos (length (car old))))))
- (if switched (list new old t) (list old new))))))))
-
-
-(defun diff-hunk-status-msg (line-offset reversed dry-run)
- (let ((msg (if dry-run
- (if reversed "already applied" "not yet applied")
- (if reversed "undone" "applied"))))
- (message (cond ((null line-offset) "Hunk text not found")
- ((= line-offset 0) "Hunk %s")
- ((= line-offset 1) "Hunk %s at offset %d line")
- (t "Hunk %s at offset %d lines"))
- msg line-offset)))
-
-(defvar diff-apply-hunk-to-backup-file nil)
-
-(defun diff-apply-hunk (&optional reverse)
- "Apply the current hunk to the source file and go to the next.
-By default, the new source file is patched, but if the variable
-`diff-jump-to-old-file' is non-nil, then the old source file is
-patched instead (some commands, such as `diff-goto-source' can change
-the value of this variable when given an appropriate prefix argument).
-
-With a prefix argument, REVERSE the hunk."
- (interactive "P")
- (destructuring-bind (buf line-offset pos old new &optional switched)
- ;; Sometimes we'd like to have the following behavior: if REVERSE go
- ;; to the new file, otherwise go to the old. But that means that by
- ;; default we use the old file, which is the opposite of the default
- ;; for diff-goto-source, and is thus confusing. Also when you don't
- ;; know about it it's pretty surprising.
- ;; TODO: make it possible to ask explicitly for this behavior.
- ;;
- ;; This is duplicated in diff-test-hunk.
- (diff-find-source-location nil reverse)
- (cond
- ((null line-offset)
- (error "Can't find the text to patch"))
- ((with-current-buffer buf
- (and buffer-file-name
- (backup-file-name-p buffer-file-name)
- (not diff-apply-hunk-to-backup-file)
- (not (set (make-local-variable 'diff-apply-hunk-to-backup-file)
- (yes-or-no-p (format "Really apply this hunk to %s? "
- (file-name-nondirectory
- buffer-file-name)))))))
- (error "%s"
- (substitute-command-keys
- (format "Use %s\\[diff-apply-hunk] to apply it to the other file"
- (if (not reverse) "\\[universal-argument] ")))))
- ((and switched
- ;; A reversed patch was detected, perhaps apply it in reverse.
- (not (save-window-excursion
- (pop-to-buffer buf)
- (goto-char (+ (car pos) (cdr old)))
- (y-or-n-p
- (if reverse
- "Hunk hasn't been applied yet; apply it now? "
- "Hunk has already been applied; undo it? ")))))
- (message "(Nothing done)"))
- (t
- ;; Apply the hunk
- (with-current-buffer buf
- (goto-char (car pos))
- (delete-region (car pos) (cdr pos))
- (insert (car new)))
- ;; Display BUF in a window
- (set-window-point (display-buffer buf) (+ (car pos) (cdr new)))
- (diff-hunk-status-msg line-offset (diff-xor switched reverse) nil)
- (when diff-advance-after-apply-hunk
- (diff-hunk-next))))))
-
-
-(defun diff-test-hunk (&optional reverse)
- "See whether it's possible to apply the current hunk.
-With a prefix argument, try to REVERSE the hunk."
- (interactive "P")
- (destructuring-bind (buf line-offset pos src dst &optional switched)
- (diff-find-source-location nil reverse)
- (set-window-point (display-buffer buf) (+ (car pos) (cdr src)))
- (diff-hunk-status-msg line-offset (diff-xor reverse switched) t)))
-
-
-(defalias 'diff-mouse-goto-source 'diff-goto-source)
-
-(defun diff-goto-source (&optional other-file event)
- "Jump to the corresponding source line.
-`diff-jump-to-old-file' (or its opposite if the OTHER-FILE prefix arg
-is given) determines whether to jump to the old or the new file.
-If the prefix arg is bigger than 8 (for example with \\[universal-argument] \\[universal-argument])
-then `diff-jump-to-old-file' is also set, for the next invocations."
- (interactive (list current-prefix-arg last-input-event))
- ;; When pointing at a removal line, we probably want to jump to
- ;; the old location, and else to the new (i.e. as if reverting).
- ;; This is a convenient detail when using smerge-diff.
- (if event (posn-set-point (event-end event)))
- (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]")))))
- (destructuring-bind (buf line-offset pos src dst &optional switched)
- (diff-find-source-location other-file rev)
- (pop-to-buffer buf)
- (goto-char (+ (car pos) (cdr src)))
- (diff-hunk-status-msg line-offset (diff-xor rev switched) t))))
-
-
-(defun diff-current-defun ()
- "Find the name of function at point.
-For use in `add-log-current-defun-function'."
- ;; Kill change-log-default-name so it gets recomputed each time, since
- ;; each hunk may belong to another file which may belong to another
- ;; directory and hence have a different ChangeLog file.
- (kill-local-variable 'change-log-default-name)
- (save-excursion
- (when (looking-at diff-hunk-header-re)
- (forward-line 1)
- (re-search-forward "^[^ ]" nil t))
- (destructuring-bind (&optional buf line-offset pos src dst switched)
- ;; Use `noprompt' since this is used in which-func-mode and such.
- (ignore-errors ;Signals errors in place of prompting.
- (diff-find-source-location nil nil 'noprompt))
- (when buf
- (beginning-of-line)
- (or (when (memq (char-after) '(?< ?-))
- ;; Cursor is pointing at removed text. This could be a removed
- ;; function, in which case, going to the source buffer will
- ;; not help since the function is now removed. Instead,
- ;; try to figure out the function name just from the
- ;; code-fragment.
- (let ((old (if switched dst src)))
- (with-temp-buffer
- (insert (car old))
- (funcall (buffer-local-value 'major-mode buf))
- (goto-char (+ (point-min) (cdr old)))
- (add-log-current-defun))))
- (with-current-buffer buf
- (goto-char (+ (car pos) (cdr src)))
- (add-log-current-defun)))))))
-
-(defun diff-ignore-whitespace-hunk ()
- "Re-diff the current hunk, ignoring whitespace differences."
- (interactive)
- (let* ((char-offset (- (point) (progn (diff-beginning-of-hunk 'try-harder)
- (point))))
- (opts (case (char-after) (?@ "-bu") (?* "-bc") (t "-b")))
- (line-nb (and (or (looking-at "[^0-9]+\\([0-9]+\\)")
- (error "Can't find line number"))
- (string-to-number (match-string 1))))
- (inhibit-read-only t)
- (hunk (delete-and-extract-region
- (point) (save-excursion (diff-end-of-hunk) (point))))
- (lead (make-string (1- line-nb) ?\n)) ;Line nums start at 1.
- (file1 (make-temp-file "diff1"))
- (file2 (make-temp-file "diff2"))
- (coding-system-for-read buffer-file-coding-system)
- old new)
- (unwind-protect
- (save-excursion
- (setq old (diff-hunk-text hunk nil char-offset))
- (setq new (diff-hunk-text hunk t char-offset))
- (write-region (concat lead (car old)) nil file1 nil 'nomessage)
- (write-region (concat lead (car new)) nil file2 nil 'nomessage)
- (with-temp-buffer
- (let ((status
- (call-process diff-command nil t nil
- opts file1 file2)))
- (case status
- (0 nil) ;Nothing to reformat.
- (1 (goto-char (point-min))
- ;; Remove the file-header.
- (when (re-search-forward diff-hunk-header-re nil t)
- (delete-region (point-min) (match-beginning 0))))
- (t (goto-char (point-max))
- (unless (bolp) (insert "\n"))
- (insert hunk)))
- (setq hunk (buffer-string))
- (unless (memq status '(0 1))
- (error "Diff returned: %s" status)))))
- ;; Whatever happens, put back some equivalent text: either the new
- ;; one or the original one in case some error happened.
- (insert hunk)
- (delete-file file1)
- (delete-file file2))))
-
-;;; Fine change highlighting.
-
-(defface diff-refine-change
- '((((class color) (min-colors 88) (background light))
- :background "grey85")
- (((class color) (min-colors 88) (background dark))
- :background "grey60")
- (((class color) (background light))
- :background "yellow")
- (((class color) (background dark))
- :background "green")
- (t :weight bold))
- "Face used for char-based changes shown by `diff-refine-hunk'."
- :group 'diff-mode)
-
-(defun diff-refine-preproc ()
- (while (re-search-forward "^[+>]" nil t)
- ;; Remove spurious changes due to the fact that one side of the hunk is
- ;; marked with leading + or > and the other with leading - or <.
- ;; We used to replace all the prefix chars with " " but this only worked
- ;; when we did char-based refinement (or when using
- ;; smerge-refine-weight-hack) since otherwise, the `forward' motion done
- ;; in chopup do not necessarily do the same as the ones in highlight
- ;; since the "_" is not treated the same as " ".
- (replace-match (cdr (assq (char-before) '((?+ . "-") (?> . "<"))))))
- )
-
-(defun diff-refine-hunk ()
- "Highlight changes of hunk at point at a finer granularity."
- (interactive)
- (eval-and-compile (require 'smerge-mode))
- (save-excursion
- (diff-beginning-of-hunk 'try-harder)
- (let* ((style (diff-hunk-style)) ;Skips the hunk header as well.
- (beg (point))
- (props '((diff-mode . fine) (face diff-refine-change)))
- (end (progn (diff-end-of-hunk) (point))))
-
- (remove-overlays beg end 'diff-mode 'fine)
-
- (goto-char beg)
- (case style
- (unified
- (while (re-search-forward "^\\(?:-.*\n\\)+\\(\\)\\(?:\\+.*\n\\)+"
- end t)
- (smerge-refine-subst (match-beginning 0) (match-end 1)
- (match-end 1) (match-end 0)
- props 'diff-refine-preproc)))
- (context
- (let* ((middle (save-excursion (re-search-forward "^---")))
- (other middle))
- (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
- (smerge-refine-subst (match-beginning 0) (match-end 0)
- (save-excursion
- (goto-char other)
- (re-search-forward "^\\(?:!.*\n\\)+" end)
- (setq other (match-end 0))
- (match-beginning 0))
- other
- props 'diff-refine-preproc))))
- (t ;; Normal diffs.
- (let ((beg1 (1+ (point))))
- (when (re-search-forward "^---.*\n" end t)
- ;; It's a combined add&remove, so there's something to do.
- (smerge-refine-subst beg1 (match-beginning 0)
- (match-end 0) end
- props 'diff-refine-preproc))))))))
-
-
-(defun diff-add-change-log-entries-other-window ()
- "Iterate through the current diff and create ChangeLog entries.
-I.e. like `add-change-log-entry-other-window' but applied to all hunks."
- (interactive)
- ;; XXX: Currently add-change-log-entry-other-window is only called
- ;; once per hunk. Some hunks have multiple changes, it would be
- ;; good to call it for each change.
- (save-excursion
- (goto-char (point-min))
- (let ((orig-buffer (current-buffer)))
- (condition-case nil
- ;; Call add-change-log-entry-other-window for each hunk in
- ;; the diff buffer.
- (while (progn
- (diff-hunk-next)
- ;; Move to where the changes are,
- ;; `add-change-log-entry-other-window' works better in
- ;; that case.
- (re-search-forward
- (concat "\n[!+-<>]"
- ;; If the hunk is a context hunk with an empty first
- ;; half, recognize the "--- NNN,MMM ----" line
- "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n"
- ;; and skip to the next non-context line.
- "\\( .*\n\\)*[+]\\)?")
- nil t))
- (save-excursion
- ;; FIXME: this pops up windows of all the buffers.
- (add-change-log-entry nil nil t nil t)))
- ;; When there's no more hunks, diff-hunk-next signals an error.
- (error nil)))))
-
-;; provide the package
-(provide 'diff-mode)
-
-;;; Old Change Log from when diff-mode wasn't part of Emacs:
-;; Revision 1.11 1999/10/09 23:38:29 monnier
-;; (diff-mode-load-hook): dropped.
-;; (auto-mode-alist): also catch *.diffs.
-;; (diff-find-file-name, diff-mode): add smarts to find the right file
-;; for *.rej files (that lack any file name indication).
-;;
-;; Revision 1.10 1999/09/30 15:32:11 monnier
-;; added support for "\ No newline at end of file".
-;;
-;; Revision 1.9 1999/09/15 00:01:13 monnier
-;; - added basic `compile' support.
-;; - have diff-kill-hunk call diff-kill-file if it's the only hunk.
-;; - diff-kill-file now tries to kill the leading garbage as well.
-;;
-;; Revision 1.8 1999/09/13 21:10:09 monnier
-;; - don't use CL in the autoloaded code
-;; - accept diffs using -T
-;;
-;; Revision 1.7 1999/09/05 20:53:03 monnier
-;; interface to ediff-patch
-;;
-;; Revision 1.6 1999/09/01 20:55:13 monnier
-;; (ediff=patch-file): add bindings to call ediff-patch.
-;; (diff-find-file-name): taken out of diff-goto-source.
-;; (diff-unified->context, diff-context->unified, diff-reverse-direction,
-;; diff-fixup-modifs): only use the region if a prefix arg is given.
-;;
-;; Revision 1.5 1999/08/31 19:18:52 monnier
-;; (diff-beginning-of-file, diff-prev-file): fixed wrong parenthesis.
-;;
-;; Revision 1.4 1999/08/31 13:01:44 monnier
-;; use `combine-after-change-calls' to minimize the slowdown of font-lock.
-;;
-
-;; arch-tag: 2571d7ff-bc28-4cf9-8585-42e21890be66
-;;; diff-mode.el ends here
+++ /dev/null
-;;; diff.el --- run `diff' in compilation-mode
-
-;; Copyright (C) 1992, 1994, 1996, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Frank Bresz
-;; (according to authors.el)
-;; Maintainer: FSF
-;; Keywords: unix, tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package helps you explore differences between files, using the
-;; UNIX command diff(1). The commands are `diff' and `diff-backup'.
-;; You can specify options with `diff-switches'.
-
-;;; Code:
-
-(defgroup diff nil
- "Comparing files with `diff'."
- :group 'tools)
-
-;;;###autoload
-(defcustom diff-switches (purecopy "-c")
- "A string or list of strings specifying switches to be passed to diff."
- :type '(choice string (repeat string))
- :group 'diff)
-
-;;;###autoload
-(defcustom diff-command (purecopy "diff")
- "The command to use to run diff."
- :type 'string
- :group 'diff)
-
-(defvar diff-old-temp-file nil
- "This is the name of a temp file to be deleted after diff finishes.")
-(defvar diff-new-temp-file nil
- "This is the name of a temp file to be deleted after diff finishes.")
-
-;; prompt if prefix arg present
-(defun diff-switches ()
- (if current-prefix-arg
- (read-string "Diff switches: "
- (if (stringp diff-switches)
- diff-switches
- (mapconcat 'identity diff-switches " ")))))
-
-(defun diff-sentinel (code)
- "Code run when the diff process exits.
-CODE is the exit code of the process. It should be 0 only if no diffs
-were found."
- (if diff-old-temp-file (delete-file diff-old-temp-file))
- (if diff-new-temp-file (delete-file diff-new-temp-file))
- (save-excursion
- (goto-char (point-max))
- (let ((inhibit-read-only t))
- (insert (format "\nDiff finished%s. %s\n"
- (cond ((equal 0 code) " (no differences)")
- ((equal 2 code) " (diff error)")
- (t ""))
- (current-time-string))))))
-
-(defvar diff-old-file nil)
-(defvar diff-new-file nil)
-(defvar diff-extra-args nil)
-
-;;;###autoload
-(defun diff (old new &optional switches no-async)
- "Find and display the differences between OLD and NEW files.
-When called interactively, read OLD and NEW using the minibuffer;
-the default for NEW is the current buffer's file name, and the
-default for OLD is a backup file for NEW, if one exists.
-If NO-ASYNC is non-nil, call diff synchronously.
-
-When called interactively with a prefix argument, prompt
-interactively for diff switches. Otherwise, the switches
-specified in `diff-switches' are passed to the diff command."
- (interactive
- (let (oldf newf)
- (setq newf (buffer-file-name)
- newf (if (and newf (file-exists-p newf))
- (read-file-name
- (concat "Diff new file (default "
- (file-name-nondirectory newf) "): ")
- nil newf t)
- (read-file-name "Diff new file: " nil nil t)))
- (setq oldf (file-newest-backup newf)
- oldf (if (and oldf (file-exists-p oldf))
- (read-file-name
- (concat "Diff original file (default "
- (file-name-nondirectory oldf) "): ")
- (file-name-directory oldf) oldf t)
- (read-file-name "Diff original file: "
- (file-name-directory newf) nil t)))
- (list oldf newf (diff-switches))))
- (setq new (expand-file-name new)
- old (expand-file-name old))
- (or switches (setq switches diff-switches)) ; If not specified, use default.
- (let* ((old-alt (file-local-copy old))
- (new-alt (file-local-copy new))
- (command
- (mapconcat 'identity
- `(,diff-command
- ;; Use explicitly specified switches
- ,@(if (listp switches) switches (list switches))
- ,@(if (or old-alt new-alt)
- (list "-L" old "-L" new))
- ,(shell-quote-argument (or old-alt old))
- ,(shell-quote-argument (or new-alt new)))
- " "))
- (buf (get-buffer-create "*Diff*"))
- (thisdir default-directory)
- proc)
- (save-excursion
- (display-buffer buf)
- (set-buffer buf)
- (setq buffer-read-only nil)
- (buffer-disable-undo (current-buffer))
- (let ((inhibit-read-only t))
- (erase-buffer))
- (buffer-enable-undo (current-buffer))
- (diff-mode)
- ;; Use below 2 vars for backward-compatibility.
- (set (make-local-variable 'diff-old-file) old)
- (set (make-local-variable 'diff-new-file) new)
- (set (make-local-variable 'diff-extra-args) (list switches no-async))
- (set (make-local-variable 'revert-buffer-function)
- (lambda (ignore-auto noconfirm)
- (apply 'diff diff-old-file diff-new-file diff-extra-args)))
- (set (make-local-variable 'diff-old-temp-file) old-alt)
- (set (make-local-variable 'diff-new-temp-file) new-alt)
- (setq default-directory thisdir)
- (let ((inhibit-read-only t))
- (insert command "\n"))
- (if (and (not no-async) (fboundp 'start-process))
- (progn
- (setq proc (start-process "Diff" buf shell-file-name
- shell-command-switch command))
- (set-process-filter proc 'diff-process-filter)
- (set-process-sentinel
- proc (lambda (proc msg)
- (with-current-buffer (process-buffer proc)
- (diff-sentinel (process-exit-status proc))))))
- ;; Async processes aren't available.
- (let ((inhibit-read-only t))
- (diff-sentinel
- (call-process shell-file-name nil buf nil
- shell-command-switch command)))))
- buf))
-
-(defun diff-process-filter (proc string)
- (with-current-buffer (process-buffer proc)
- (let ((moving (= (point) (process-mark proc))))
- (save-excursion
- ;; Insert the text, advancing the process marker.
- (goto-char (process-mark proc))
- (let ((inhibit-read-only t))
- (insert string))
- (set-marker (process-mark proc) (point)))
- (if moving (goto-char (process-mark proc))))))
-
-;;;###autoload
-(defun diff-backup (file &optional switches)
- "Diff this file with its backup file or vice versa.
-Uses the latest backup, if there are several numerical backups.
-If this file is a backup, diff it with its original.
-The backup file is the first file given to `diff'.
-With prefix arg, prompt for diff switches."
- (interactive (list (read-file-name "Diff (file with backup): ")
- (diff-switches)))
- (let (bak ori)
- (if (backup-file-name-p file)
- (setq bak file
- ori (file-name-sans-versions file))
- (setq bak (or (diff-latest-backup-file file)
- (error "No backup found for %s" file))
- ori file))
- (diff bak ori switches)))
-
-(defun diff-latest-backup-file (fn) ; actually belongs into files.el
- "Return the latest existing backup of FILE, or nil."
- (let ((handler (find-file-name-handler fn 'diff-latest-backup-file)))
- (if handler
- (funcall handler 'diff-latest-backup-file fn)
- (file-newest-backup fn))))
-
-(provide 'diff)
-
-;; arch-tag: 7de2c29b-7ea5-4b85-9b9d-72dd860de2bd
-;;; diff.el ends here
+++ /dev/null
-;;; ediff-diff.el --- diff-related utilities
-
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-
-(provide 'ediff-diff)
-
-(eval-when-compile
- (require 'ediff-util))
-
-(require 'ediff-init)
-
-(defgroup ediff-diff nil
- "Diff related utilities."
- :prefix "ediff-"
- :group 'ediff)
-
-(defcustom ediff-diff-program "diff"
- "Program to use for generating the differential of the two files."
- :type 'string
- :group 'ediff-diff)
-(defcustom ediff-diff3-program "diff3"
- "Program to be used for three-way comparison.
-Must produce output compatible with Unix's diff3 program."
- :type 'string
- :group 'ediff-diff)
-
-
-;; The following functions must precede all defcustom-defined variables.
-
-(fset 'ediff-set-actual-diff-options '(lambda () nil))
-
-(defcustom ediff-shell
- (cond ((eq system-type 'emx) "cmd") ; OS/2
- ((memq system-type '(ms-dos windows-nt windows-95))
- shell-file-name) ; no standard name on MS-DOS
- (t "sh")) ; UNIX
- "The shell used to run diff and patch.
-If user's .profile or .cshrc files are set up correctly, any shell
-will do. However, some people set $prompt or other things
-incorrectly, which leads to undesirable output messages. These may
-cause Ediff to fail. In such a case, set `ediff-shell' to a shell that
-you are not using or, better, fix your shell's startup file."
- :type 'string
- :group 'ediff-diff)
-
-(defcustom ediff-cmp-program "cmp"
- "Utility to use to determine if two files are identical.
-It must return code 0, if its arguments are identical files."
- :type 'string
- :group 'ediff-diff)
-
-(defcustom ediff-cmp-options nil
- "Options to pass to `ediff-cmp-program'.
-If GNU diff is used as `ediff-cmp-program', then the most useful options
-are `-I REGEXP', to ignore changes whose lines match the REGEXP."
- :type '(repeat string)
- :group 'ediff-diff)
-
-(defun ediff-set-diff-options (symbol value)
- (set symbol value)
- (ediff-set-actual-diff-options))
-
-(defcustom ediff-diff-options
- (if (memq system-type '(ms-dos windows-nt windows-95)) "--binary" "")
- "Options to pass to `ediff-diff-program'.
-If Unix diff is used as `ediff-diff-program',
-then a useful option is `-w', to ignore space.
-Options `-c', `-u', and `-i' are not allowed. Case sensitivity can be
-toggled interactively using \\[ediff-toggle-ignore-case].
-
-Do not remove the default options. If you need to change this variable, add new
-options after the default ones.
-
-This variable is not for customizing the look of the differences produced by
-the command \\[ediff-show-diff-output]. Use the variable
-`ediff-custom-diff-options' for that."
- :set 'ediff-set-diff-options
- :type 'string
- :group 'ediff-diff)
-
-(ediff-defvar-local ediff-ignore-case nil
- "*If t, skip over difference regions that differ only in letter case.
-This variable can be set either in .emacs or toggled interactively.
-Use `setq-default' if setting it in .emacs")
-
-(defcustom ediff-ignore-case-option "-i"
- "Option that causes the diff program to ignore case of letters."
- :type 'string
- :group 'ediff-diff)
-
-(defcustom ediff-ignore-case-option3 ""
- "Option that causes the diff3 program to ignore case of letters.
-GNU diff3 doesn't have such an option."
- :type 'string
- :group 'ediff-diff)
-
-;; the actual options used in comparison
-(ediff-defvar-local ediff-actual-diff-options ediff-diff-options "")
-
-(defcustom ediff-custom-diff-program ediff-diff-program
- "Program to use for generating custom diff output for saving it in a file.
-This output is not used by Ediff internally."
- :type 'string
- :group 'ediff-diff)
-(defcustom ediff-custom-diff-options "-c"
- "Options to pass to `ediff-custom-diff-program'."
- :type 'string
- :group 'ediff-diff)
-
-;;; Support for diff3
-
-(defvar ediff-match-diff3-line "^====\\(.?\\)\C-m?$"
- "Pattern to match lines produced by diff3 that describe differences.")
-(defcustom ediff-diff3-options ""
- "Options to pass to `ediff-diff3-program'."
- :set 'ediff-set-diff-options
- :type 'string
- :group 'ediff-diff)
-
-;; the actual options used in comparison
-(ediff-defvar-local ediff-actual-diff3-options ediff-diff3-options "")
-
-(defcustom ediff-diff3-ok-lines-regexp
- "^\\([1-3]:\\|====\\| \\|.*Warning *:\\|.*No newline\\|.*missing newline\\|^\C-m$\\)"
- "Regexp that matches normal output lines from `ediff-diff3-program'.
-Lines that do not match are assumed to be error messages."
- :type 'regexp
- :group 'ediff-diff)
-
-;; keeps the status of the current diff in 3-way jobs.
-;; the status can be =diff(A), =diff(B), or =diff(A+B)
-(ediff-defvar-local ediff-diff-status "" "")
-
-
-;;; Fine differences
-
-(ediff-defvar-local ediff-auto-refine (if (ediff-has-face-support-p) 'on 'nix)
- "If `on', Ediff auto-highlights fine diffs for the current diff region.
-If `off', auto-highlighting is not used. If `nix', no fine diffs are shown
-at all, unless the user force-refines the region by hitting `*'.
-
-This variable can be set either in .emacs or toggled interactively.
-Use `setq-default' if setting it in .emacs")
-
-(ediff-defvar-local ediff-ignore-similar-regions nil
- "*If t, skip over difference regions that differ only in the white space and line breaks.
-This variable can be set either in .emacs or toggled interactively.
-Use `setq-default' if setting it in .emacs")
-
-(ediff-defvar-local ediff-auto-refine-limit 14000
- "*Auto-refine only the regions of this size \(in bytes\) or less.")
-
-;;; General
-
-(defvar ediff-diff-ok-lines-regexp
- (concat
- "^\\("
- "[0-9,]+[acd][0-9,]+\C-m?$"
- "\\|[<>] "
- "\\|---"
- "\\|.*Warning *:"
- "\\|.*No +newline"
- "\\|.*missing +newline"
- "\\|^\C-m?$"
- "\\)")
- "Regexp that matches normal output lines from `ediff-diff-program'.
-This is mostly lifted from Emerge, except that Ediff also considers
-warnings and `Missing newline'-type messages to be normal output.
-Lines that do not match are assumed to be error messages.")
-
-(defvar ediff-match-diff-line
- (let ((x "\\([0-9]+\\)\\(\\|,\\([0-9]+\\)\\)"))
- (concat "^" x "\\([acd]\\)" x "\C-m?$"))
- "Pattern to match lines produced by diff that describe differences.")
-
-(ediff-defvar-local ediff-setup-diff-regions-function nil
- "value is a function symbol depending on the kind of job is to be done.
-For 2-way jobs and for ediff-merge, it should be `ediff-setup-diff-regions'.
-For jobs requiring diff3, it should be `ediff-setup-diff-regions3'.
-
-The function should take three mandatory arguments, file-A, file-B, and
-file-C. It may ignore file C for diff2 jobs. It should also take
-one optional arguments, diff-number to refine.")
-
-
-;;; Functions
-
-;; Generate the difference vector and overlays for the two files
-;; With optional arg REG-TO-REFINE, refine this region.
-;; File-C argument is not used here. It is there just because
-;; ediff-setup-diff-regions is called via a funcall to
-;; ediff-setup-diff-regions-function, which can also have the value
-;; ediff-setup-diff-regions3, which takes 4 arguments.
-(defun ediff-setup-diff-regions (file-A file-B file-C)
- ;; looking for '-c', '-i', '-u', or 'c', 'i', 'u' among clustered non-long options
- (if (string-match "^-[ciu]\\| -[ciu]\\|\\(^\\| \\)-[^- ]+[ciu]"
- ediff-diff-options)
- (error "Options `-c', `-u', and `-i' are not allowed in `ediff-diff-options'"))
-
- ;; create, if it doesn't exist
- (or (ediff-buffer-live-p ediff-diff-buffer)
- (setq ediff-diff-buffer
- (get-buffer-create (ediff-unique-buffer-name "*ediff-diff" "*"))))
- (ediff-make-diff2-buffer ediff-diff-buffer file-A file-B)
- (ediff-prepare-error-list ediff-diff-ok-lines-regexp ediff-diff-buffer)
- (ediff-convert-diffs-to-overlays
- (ediff-extract-diffs
- ediff-diff-buffer ediff-word-mode ediff-narrow-bounds)))
-
-;; Run the diff program on FILE1 and FILE2 and put the output in DIFF-BUFFER
-;; Return the size of DIFF-BUFFER
-;; The return code isn't used in the program at present.
-(defun ediff-make-diff2-buffer (diff-buffer file1 file2)
- (let ((file1-size (ediff-file-size file1))
- (file2-size (ediff-file-size file2)))
- (cond ((not (numberp file1-size))
- (message "Can't find file: %s"
- (ediff-abbreviate-file-name file1))
- (sit-for 2)
- ;; 1 is an error exit code
- 1)
- ((not (numberp file2-size))
- (message "Can't find file: %s"
- (ediff-abbreviate-file-name file2))
- (sit-for 2)
- ;; 1 is an error exit code
- 1)
- (t (message "Computing differences between %s and %s ..."
- (file-name-nondirectory file1)
- (file-name-nondirectory file2))
- ;; this erases the diff buffer automatically
- (ediff-exec-process ediff-diff-program
- diff-buffer
- 'synchronize
- ediff-actual-diff-options file1 file2)
- (message "")
- (ediff-with-current-buffer diff-buffer
- (buffer-size))))))
-
-
-
-;; If file-A/B/C is nil, do 2-way comparison with the non-nil buffers
-;; This function works for diff3 and diff2 jobs
-(defun ediff-setup-fine-diff-regions (file-A file-B file-C reg-num)
- (or (ediff-buffer-live-p ediff-fine-diff-buffer)
- (setq ediff-fine-diff-buffer
- (get-buffer-create
- (ediff-unique-buffer-name "*ediff-fine-diff" "*"))))
-
- (let (diff3-job diff-program diff-options ok-regexp diff-list)
- (setq diff3-job ediff-3way-job
- diff-program (if diff3-job ediff-diff3-program ediff-diff-program)
- diff-options (if diff3-job
- ediff-actual-diff3-options
- ediff-actual-diff-options)
- ok-regexp (if diff3-job
- ediff-diff3-ok-lines-regexp
- ediff-diff-ok-lines-regexp))
-
- (ediff-message-if-verbose "Refining difference region %d ..." (1+ reg-num))
- (ediff-exec-process diff-program ediff-fine-diff-buffer 'synchronize
- diff-options
- ;; The shuffle below is because we can compare 3-way
- ;; or in several 2-way fashions, like fA fC, fA fB,
- ;; or fB fC.
- (if file-A file-A file-B)
- (if file-B file-B file-A)
- (if diff3-job
- (if file-C file-C file-B))
- ) ; exec process
-
- (ediff-prepare-error-list ok-regexp ediff-fine-diff-buffer)
- (ediff-message-if-verbose
- "")
- ;; "Refining difference region %d ... done" (1+ reg-num))
-
- (setq diff-list
- (if diff3-job
- (ediff-extract-diffs3
- ediff-fine-diff-buffer '3way-comparison 'word-mode)
- (ediff-extract-diffs ediff-fine-diff-buffer 'word-mode)))
- ;; fixup diff-list
- (if diff3-job
- (cond ((not file-A)
- (mapc (lambda (elt)
- (aset elt 0 nil)
- (aset elt 1 nil))
- (cdr diff-list)))
- ((not file-B)
- (mapc (lambda (elt)
- (aset elt 2 nil)
- (aset elt 3 nil))
- (cdr diff-list)))
- ((not file-C)
- (mapc (lambda (elt)
- (aset elt 4 nil)
- (aset elt 5 nil))
- (cdr diff-list)))
- ))
-
- (ediff-convert-fine-diffs-to-overlays diff-list reg-num)
- ))
-
-
-(defun ediff-prepare-error-list (ok-regexp diff-buff)
- (or (ediff-buffer-live-p ediff-error-buffer)
- (setq ediff-error-buffer
- (get-buffer-create (ediff-unique-buffer-name
- "*ediff-errors" "*"))))
- (ediff-with-current-buffer ediff-error-buffer
- (setq buffer-undo-list t)
- (erase-buffer)
- (insert (ediff-with-current-buffer diff-buff (buffer-string)))
- (goto-char (point-min))
- (delete-matching-lines ok-regexp))
- ;; If diff reports errors, show them then quit.
- (if (/= 0 (ediff-with-current-buffer ediff-error-buffer (buffer-size)))
- (let ((ctl-buf ediff-control-buffer)
- (error-buf ediff-error-buffer))
- (ediff-skip-unsuitable-frames)
- (switch-to-buffer error-buf)
- (ediff-kill-buffer-carefully ctl-buf)
- (error "Errors in diff output. Diff output is in %S" diff-buff))))
-
-;; BOUNDS specifies visibility bounds to use.
-;; WORD-MODE tells whether we are in the word-mode or not.
-;; If WORD-MODE, also construct vector of diffs using word numbers.
-;; Else, use point values.
-;; This function handles diff-2 jobs including the case of
-;; merging buffers and files without ancestor.
-(defun ediff-extract-diffs (diff-buffer word-mode &optional bounds)
- (let ((A-buffer ediff-buffer-A)
- (B-buffer ediff-buffer-B)
- (C-buffer ediff-buffer-C)
- (a-prev 1) ; this is needed to set the first diff line correctly
- (a-prev-pt nil)
- (b-prev 1)
- (b-prev-pt nil)
- (c-prev 1)
- (c-prev-pt nil)
- diff-list shift-A shift-B
- )
-
- ;; diff list contains word numbers, unless changed later
- (setq diff-list (cons (if word-mode 'words 'points)
- diff-list))
- ;; we don't use visibility bounds for buffer C when merging
- (if bounds
- (setq shift-A
- (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type 'A bounds))
- shift-B
- (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type 'B bounds))))
-
- ;; reset point in buffers A/B/C
- (ediff-with-current-buffer A-buffer
- (goto-char (if shift-A shift-A (point-min))))
- (ediff-with-current-buffer B-buffer
- (goto-char (if shift-B shift-B (point-min))))
- (if (ediff-buffer-live-p C-buffer)
- (ediff-with-current-buffer C-buffer
- (goto-char (point-min))))
-
- (ediff-with-current-buffer diff-buffer
- (goto-char (point-min))
- (while (re-search-forward ediff-match-diff-line nil t)
- (let* ((a-begin (string-to-number (buffer-substring (match-beginning 1)
- (match-end 1))))
- (a-end (let ((b (match-beginning 3))
- (e (match-end 3)))
- (if b
- (string-to-number (buffer-substring b e))
- a-begin)))
- (diff-type (buffer-substring (match-beginning 4) (match-end 4)))
- (b-begin (string-to-number (buffer-substring (match-beginning 5)
- (match-end 5))))
- (b-end (let ((b (match-beginning 7))
- (e (match-end 7)))
- (if b
- (string-to-number (buffer-substring b e))
- b-begin)))
- a-begin-pt a-end-pt b-begin-pt b-end-pt
- c-begin c-end c-begin-pt c-end-pt)
- ;; fix the beginning and end numbers, because diff is somewhat
- ;; strange about how it numbers lines
- (if (string-equal diff-type "a")
- (setq b-end (1+ b-end)
- a-begin (1+ a-begin)
- a-end a-begin)
- (if (string-equal diff-type "d")
- (setq a-end (1+ a-end)
- b-begin (1+ b-begin)
- b-end b-begin)
- ;; (string-equal diff-type "c")
- (setq a-end (1+ a-end)
- b-end (1+ b-end))))
-
- (if (eq ediff-default-variant 'default-B)
- (setq c-begin b-begin
- c-end b-end)
- (setq c-begin a-begin
- c-end a-end))
-
- ;; compute main diff vector
- (if word-mode
- ;; make diff-list contain word numbers
- (setq diff-list
- (nconc diff-list
- (list
- (if (ediff-buffer-live-p C-buffer)
- (vector (- a-begin a-prev) (- a-end a-begin)
- (- b-begin b-prev) (- b-end b-begin)
- (- c-begin c-prev) (- c-end c-begin)
- nil nil ; dummy ancestor
- nil ; state of diff
- nil ; state of merge
- nil ; state of ancestor
- )
- (vector (- a-begin a-prev) (- a-end a-begin)
- (- b-begin b-prev) (- b-end b-begin)
- nil nil ; dummy buf C
- nil nil ; dummy ancestor
- nil ; state of diff
- nil ; state of merge
- nil ; state of ancestor
- ))
- ))
- a-prev a-end
- b-prev b-end
- c-prev c-end)
- ;; else convert lines to points
- (ediff-with-current-buffer A-buffer
- (let ((longlines-mode-val
- (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
- ;; we must disable and then restore longlines-mode
- (if (eq longlines-mode-val 1)
- (longlines-mode 0))
- (goto-char (or a-prev-pt shift-A (point-min)))
- (forward-line (- a-begin a-prev))
- (setq a-begin-pt (point))
- (forward-line (- a-end a-begin))
- (setq a-end-pt (point)
- a-prev a-end
- a-prev-pt a-end-pt)
- (if (eq longlines-mode-val 1)
- (longlines-mode longlines-mode-val))
- ))
- (ediff-with-current-buffer B-buffer
- (let ((longlines-mode-val
- (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
- (if (eq longlines-mode-val 1)
- (longlines-mode 0))
- (goto-char (or b-prev-pt shift-B (point-min)))
- (forward-line (- b-begin b-prev))
- (setq b-begin-pt (point))
- (forward-line (- b-end b-begin))
- (setq b-end-pt (point)
- b-prev b-end
- b-prev-pt b-end-pt)
- (if (eq longlines-mode-val 1)
- (longlines-mode longlines-mode-val))
- ))
- (if (ediff-buffer-live-p C-buffer)
- (ediff-with-current-buffer C-buffer
- (let ((longlines-mode-val
- (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
- (if (eq longlines-mode-val 1)
- (longlines-mode 0))
- (goto-char (or c-prev-pt (point-min)))
- (forward-line (- c-begin c-prev))
- (setq c-begin-pt (point))
- (forward-line (- c-end c-begin))
- (setq c-end-pt (point)
- c-prev c-end
- c-prev-pt c-end-pt)
- (if (eq longlines-mode-val 1)
- (longlines-mode longlines-mode-val))
- )))
- (setq diff-list
- (nconc
- diff-list
- (list
- (if (ediff-buffer-live-p C-buffer)
- (vector
- a-begin-pt a-end-pt b-begin-pt b-end-pt
- c-begin-pt c-end-pt
- nil nil ; dummy ancestor
- ;; state of diff
- ;; shows which buff is different from the other two
- (if (eq ediff-default-variant 'default-B) 'A 'B)
- ediff-default-variant ; state of merge
- nil ; state of ancestor
- )
- (vector a-begin-pt a-end-pt
- b-begin-pt b-end-pt
- nil nil ; dummy buf C
- nil nil ; dummy ancestor
- nil nil ; dummy state of diff & merge
- nil ; dummy state of ancestor
- )))
- )))
-
- ))) ; end ediff-with-current-buffer
- diff-list
- ))
-
-
-(defun ediff-convert-diffs-to-overlays (diff-list)
- (ediff-set-diff-overlays-in-one-buffer 'A diff-list)
- (ediff-set-diff-overlays-in-one-buffer 'B diff-list)
- (if ediff-3way-job
- (ediff-set-diff-overlays-in-one-buffer 'C diff-list))
- (if ediff-merge-with-ancestor-job
- (ediff-set-diff-overlays-in-one-buffer 'Ancestor diff-list))
- ;; set up vector showing the status of merge regions
- (if ediff-merge-job
- (setq ediff-state-of-merge
- (vconcat
- (mapcar (lambda (elt)
- (let ((state-of-merge (aref elt 9))
- (state-of-ancestor (aref elt 10)))
- (vector
- ;; state of merge: prefers/default-A/B or combined
- (if state-of-merge (format "%S" state-of-merge))
- ;; whether the ancestor region is empty
- state-of-ancestor)))
- ;; the first elt designates type of list
- (cdr diff-list))
- )))
- (message "Processing difference regions ... done"))
-
-
-(defun ediff-set-diff-overlays-in-one-buffer (buf-type diff-list)
- (let* ((current-diff -1)
- (buff (ediff-get-buffer buf-type))
- (ctl-buf ediff-control-buffer)
- ;; ediff-extract-diffs puts the type of diff-list as the first elt
- ;; of this list. The type is either 'points or 'words
- (diff-list-type (car diff-list))
- (shift (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type
- buf-type ediff-narrow-bounds)))
- (limit (ediff-overlay-end
- (ediff-get-value-according-to-buffer-type
- buf-type ediff-narrow-bounds)))
- diff-overlay-list list-element total-diffs
- begin end pt-saved overlay state-of-diff)
-
- (setq diff-list (cdr diff-list)) ; discard diff list type
- (setq total-diffs (length diff-list))
-
- ;; shift, if necessary
- (ediff-with-current-buffer buff (setq pt-saved shift))
-
- (while diff-list
- (setq current-diff (1+ current-diff)
- list-element (car diff-list)
- begin (aref list-element (cond ((eq buf-type 'A) 0)
- ((eq buf-type 'B) 2)
- ((eq buf-type 'C) 4)
- (t 6))) ; Ancestor
- end (aref list-element (cond ((eq buf-type 'A) 1)
- ((eq buf-type 'B) 3)
- ((eq buf-type 'C) 5)
- (t 7))) ; Ancestor
- state-of-diff (aref list-element 8)
- )
-
- (cond ((and (not (eq buf-type state-of-diff))
- (not (eq buf-type 'Ancestor))
- (memq state-of-diff '(A B C)))
- (setq state-of-diff
- (car (delq buf-type (delq state-of-diff (list 'A 'B 'C)))))
- (setq state-of-diff (format "=diff(%S)" state-of-diff))
- )
- (t (setq state-of-diff nil)))
-
- ;; Put overlays at appropriate places in buffer
- ;; convert word numbers to points, if necessary
- (if (eq diff-list-type 'words)
- (progn
- (ediff-with-current-buffer buff (goto-char pt-saved))
- (ediff-with-current-buffer ctl-buf
- (setq begin (ediff-goto-word (1+ begin) buff)
- end (ediff-goto-word end buff 'end)))
- (if (> end limit) (setq end limit))
- (if (> begin end) (setq begin end))
- (setq pt-saved (ediff-with-current-buffer buff (point)))))
- (setq overlay (ediff-make-bullet-proof-overlay begin end buff))
-
- (ediff-overlay-put overlay 'priority ediff-shadow-overlay-priority)
- (ediff-overlay-put overlay 'ediff-diff-num current-diff)
- (if (and (ediff-has-face-support-p)
- ediff-use-faces ediff-highlight-all-diffs)
- (ediff-set-overlay-face
- overlay (ediff-background-face buf-type current-diff)))
-
- (if (= 0 (mod current-diff 10))
- (message "Buffer %S: Processing difference region %d of %d"
- buf-type current-diff total-diffs))
- ;; Record all overlays for this difference.
- ;; The 2-d elt, nil, is a place holder for the fine diff vector.
- ;; The 3-d elt, nil, is a place holder for no-fine-diffs flag.
- ;; The 4-th elt says which diff region is different from the other two
- ;; (3-way jobs only).
- (setq diff-overlay-list
- (nconc
- diff-overlay-list
- (list (vector overlay nil nil state-of-diff)))
- diff-list
- (cdr diff-list))
- ) ; while
-
- (set (ediff-get-symbol-from-alist buf-type ediff-difference-vector-alist)
- (vconcat diff-overlay-list))
- ))
-
-;; `n' is the diff region to work on. Default is ediff-current-difference.
-;; if `flag' is 'noforce then make fine-diffs only if this region's fine
-;; diffs have not been computed before.
-;; if `flag' is 'skip then don't compute fine diffs for this region.
-(defun ediff-make-fine-diffs (&optional n flag)
- (or n (setq n ediff-current-difference))
-
- (if (< ediff-number-of-differences 1)
- (error ediff-NO-DIFFERENCES))
-
- (if ediff-word-mode
- (setq flag 'skip
- ediff-auto-refine 'nix))
-
- (or (< n 0)
- (>= n ediff-number-of-differences)
- ;; n is within the range
- (let ((tmp-buffer (get-buffer-create ediff-tmp-buffer))
- (file-A ediff-temp-file-A)
- (file-B ediff-temp-file-B)
- (file-C ediff-temp-file-C)
- (empty-A (ediff-empty-diff-region-p n 'A))
- (empty-B (ediff-empty-diff-region-p n 'B))
- (empty-C (ediff-empty-diff-region-p n 'C))
- (whitespace-A (ediff-whitespace-diff-region-p n 'A))
- (whitespace-B (ediff-whitespace-diff-region-p n 'B))
- (whitespace-C (ediff-whitespace-diff-region-p n 'C))
- cumulative-fine-diff-length)
-
- (cond ;; If one of the regions is empty (or 2 in 3way comparison)
- ;; then don't refine.
- ;; If the region happens to be entirely whitespace or empty then
- ;; mark as such.
- ((> (length (delq nil (list empty-A empty-B empty-C))) 1)
- (if (and (ediff-looks-like-combined-merge n)
- ediff-merge-job)
- (ediff-set-fine-overlays-in-one-buffer 'C nil n))
- (if ediff-3way-comparison-job
- (ediff-message-if-verbose
- "Region %d is empty in all buffers but %S"
- (1+ n)
- (cond ((not empty-A) 'A)
- ((not empty-B) 'B)
- ((not empty-C) 'C)))
- (ediff-message-if-verbose
- "Region %d in buffer %S is empty"
- (1+ n)
- (cond (empty-A 'A)
- (empty-B 'B)
- (empty-C 'C)))
- )
- ;; if all regions happen to be whitespace
- (if (and whitespace-A whitespace-B whitespace-C)
- ;; mark as space only
- (ediff-mark-diff-as-space-only n t)
- ;; if some regions are white and others don't, then mark as
- ;; non-white-space-only
- (ediff-mark-diff-as-space-only n nil)))
-
- ;; don't compute fine diffs if diff vector exists
- ((and (eq flag 'noforce) (ediff-get-fine-diff-vector n 'A))
- (if (ediff-no-fine-diffs-p n)
- (message
- "Only white-space differences in region %d %s"
- (1+ n)
- (cond ((eq (ediff-no-fine-diffs-p n) 'A)
- "in buffers B & C")
- ((eq (ediff-no-fine-diffs-p n) 'B)
- "in buffers A & C")
- ((eq (ediff-no-fine-diffs-p n) 'C)
- "in buffers A & B")
- (t "")))))
- ;; don't compute fine diffs for this region
- ((eq flag 'skip)
- (or (ediff-get-fine-diff-vector n 'A)
- (memq ediff-auto-refine '(off nix))
- (ediff-message-if-verbose
- "Region %d exceeds the auto-refinement limit. Type `%s' to refine"
- (1+ n)
- (substitute-command-keys
- "\\[ediff-make-or-kill-fine-diffs]")
- )))
- (t
- ;; recompute fine diffs
- (ediff-wordify
- (ediff-get-diff-posn 'A 'beg n)
- (ediff-get-diff-posn 'A 'end n)
- ediff-buffer-A
- tmp-buffer
- ediff-control-buffer)
- (setq file-A
- (ediff-make-temp-file tmp-buffer "fineDiffA" file-A))
-
- (ediff-wordify
- (ediff-get-diff-posn 'B 'beg n)
- (ediff-get-diff-posn 'B 'end n)
- ediff-buffer-B
- tmp-buffer
- ediff-control-buffer)
- (setq file-B
- (ediff-make-temp-file tmp-buffer "fineDiffB" file-B))
-
- (if ediff-3way-job
- (progn
- (ediff-wordify
- (ediff-get-diff-posn 'C 'beg n)
- (ediff-get-diff-posn 'C 'end n)
- ediff-buffer-C
- tmp-buffer
- ediff-control-buffer)
- (setq file-C
- (ediff-make-temp-file
- tmp-buffer "fineDiffC" file-C))))
-
- ;; save temp file names.
- (setq ediff-temp-file-A file-A
- ediff-temp-file-B file-B
- ediff-temp-file-C file-C)
-
- ;; set the new vector of fine diffs, if none exists
- (cond ((and ediff-3way-job whitespace-A)
- (ediff-setup-fine-diff-regions nil file-B file-C n))
- ((and ediff-3way-job whitespace-B)
- (ediff-setup-fine-diff-regions file-A nil file-C n))
- ((and ediff-3way-job
- ;; In merge-jobs, whitespace-C is t, since
- ;; ediff-empty-diff-region-p returns t in this case
- whitespace-C)
- (ediff-setup-fine-diff-regions file-A file-B nil n))
- (t
- (ediff-setup-fine-diff-regions file-A file-B file-C n)))
-
- (setq cumulative-fine-diff-length
- (+ (length (ediff-get-fine-diff-vector n 'A))
- (length (ediff-get-fine-diff-vector n 'B))
- ;; in merge jobs, the merge buffer is never refined
- (if (and file-C (not ediff-merge-job))
- (length (ediff-get-fine-diff-vector n 'C))
- 0)))
-
- (cond ((or
- ;; all regions are white space
- (and whitespace-A whitespace-B whitespace-C)
- ;; none is white space and no fine diffs detected
- (and (not whitespace-A)
- (not whitespace-B)
- (not (and ediff-3way-job whitespace-C))
- (eq cumulative-fine-diff-length 0)))
- (ediff-mark-diff-as-space-only n t)
- (ediff-message-if-verbose
- "Only white-space differences in region %d" (1+ n)))
- ((eq cumulative-fine-diff-length 0)
- (ediff-message-if-verbose
- "Only white-space differences in region %d %s"
- (1+ n)
- (cond (whitespace-A (ediff-mark-diff-as-space-only n 'A)
- "in buffers B & C")
- (whitespace-B (ediff-mark-diff-as-space-only n 'B)
- "in buffers A & C")
- (whitespace-C (ediff-mark-diff-as-space-only n 'C)
- "in buffers A & B"))))
- (t
- (ediff-mark-diff-as-space-only n nil)))
- )
- ) ; end cond
- (ediff-set-fine-diff-properties n)
- )))
-
-;; Interface to ediff-make-fine-diffs. Checks for auto-refine limit, etc.
-(defun ediff-install-fine-diff-if-necessary (n)
- (cond ((and (eq ediff-auto-refine 'on)
- ediff-use-faces
- (not (eq ediff-highlighting-style 'off))
- (not (eq ediff-highlighting-style 'ascii)))
- (if (and
- (> ediff-auto-refine-limit
- (- (ediff-get-diff-posn 'A 'end n)
- (ediff-get-diff-posn 'A 'beg n)))
- (> ediff-auto-refine-limit
- (- (ediff-get-diff-posn 'B 'end n)
- (ediff-get-diff-posn 'B 'beg n))))
- (ediff-make-fine-diffs n 'noforce)
- (ediff-make-fine-diffs n 'skip)))
-
- ;; highlight if fine diffs already exist
- ((eq ediff-auto-refine 'off)
- (ediff-make-fine-diffs n 'skip))))
-
-
-;; if fine diff vector is not set for diff N, then do nothing
-(defun ediff-set-fine-diff-properties (n &optional default)
- (or (not (ediff-has-face-support-p))
- (< n 0)
- (>= n ediff-number-of-differences)
- ;; when faces are supported, set faces and priorities of fine overlays
- (progn
- (ediff-set-fine-diff-properties-in-one-buffer 'A n default)
- (ediff-set-fine-diff-properties-in-one-buffer 'B n default)
- (if ediff-3way-job
- (ediff-set-fine-diff-properties-in-one-buffer 'C n default)))))
-
-(defun ediff-set-fine-diff-properties-in-one-buffer (buf-type
- n &optional default)
- (let ((fine-diff-vector (ediff-get-fine-diff-vector n buf-type))
- (face (if default
- 'default
- (ediff-get-symbol-from-alist
- buf-type ediff-fine-diff-face-alist)
- ))
- (priority (if default
- 0
- (1+ (or (ediff-overlay-get
- (symbol-value
- (ediff-get-symbol-from-alist
- buf-type
- ediff-current-diff-overlay-alist))
- 'priority)
- 0)))))
- (mapcar (lambda (overl)
- (ediff-set-overlay-face overl face)
- (ediff-overlay-put overl 'priority priority))
- fine-diff-vector)))
-
-;; Set overlays over the regions that denote delimiters
-(defun ediff-set-fine-overlays-for-combined-merge (diff-list reg-num)
- (let (overlay overlay-list)
- (while diff-list
- (condition-case nil
- (setq overlay
- (ediff-make-bullet-proof-overlay
- (nth 0 diff-list) (nth 1 diff-list) ediff-buffer-C))
- (error ""))
- (setq overlay-list (cons overlay overlay-list))
- (if (> (length diff-list) 1)
- (setq diff-list (cdr (cdr diff-list)))
- (error "ediff-set-fine-overlays-for-combined-merge: corrupt list of
-delimiter regions"))
- )
- (setq overlay-list (reverse overlay-list))
- (ediff-set-fine-diff-vector
- reg-num 'C (apply 'vector overlay-list))
- ))
-
-
-;; Convert diff list to overlays for a given DIFF-REGION
-;; in buffer of type BUF-TYPE
-(defun ediff-set-fine-overlays-in-one-buffer (buf-type diff-list region-num)
- (let* ((current-diff -1)
- (reg-start (ediff-get-diff-posn buf-type 'beg region-num))
- (buff (ediff-get-buffer buf-type))
- (ctl-buf ediff-control-buffer)
- combined-merge-diff-list
- diff-overlay-list list-element
- begin end overlay)
-
- (ediff-clear-fine-differences-in-one-buffer region-num buf-type)
- (setq diff-list (cdr diff-list)) ; discard list type (words or points)
- (ediff-with-current-buffer buff (goto-char reg-start))
-
- ;; if it is a combined merge then set overlays in buff C specially
- (if (and ediff-merge-job (eq buf-type 'C)
- (setq combined-merge-diff-list
- (ediff-looks-like-combined-merge region-num)))
- (ediff-set-fine-overlays-for-combined-merge
- combined-merge-diff-list region-num)
- ;; regular fine diff
- (while diff-list
- (setq current-diff (1+ current-diff)
- list-element (car diff-list)
- begin (aref list-element (cond ((eq buf-type 'A) 0)
- ((eq buf-type 'B) 2)
- (t 4))) ; buf C
- end (aref list-element (cond ((eq buf-type 'A) 1)
- ((eq buf-type 'B) 3)
- (t 5)))) ; buf C
- (if (not (or begin end))
- () ; skip this diff
- ;; Put overlays at appropriate places in buffers
- ;; convert lines to points, if necessary
- (ediff-with-current-buffer ctl-buf
- (setq begin (ediff-goto-word (1+ begin) buff)
- end (ediff-goto-word end buff 'end)))
- (setq overlay (ediff-make-bullet-proof-overlay begin end buff))
- ;; record all overlays for this difference region
- (setq diff-overlay-list (nconc diff-overlay-list (list overlay))))
-
- (setq diff-list (cdr diff-list))
- ) ; while
- ;; convert the list of difference information into a vector
- ;; for fast access
- (ediff-set-fine-diff-vector
- region-num buf-type (vconcat diff-overlay-list))
- )))
-
-
-(defun ediff-convert-fine-diffs-to-overlays (diff-list region-num)
- (ediff-set-fine-overlays-in-one-buffer 'A diff-list region-num)
- (ediff-set-fine-overlays-in-one-buffer 'B diff-list region-num)
- (if ediff-3way-job
- (ediff-set-fine-overlays-in-one-buffer 'C diff-list region-num)
- ))
-
-
-;; Stolen from emerge.el
-(defun ediff-get-diff3-group (file)
- ;; This save-excursion allows ediff-get-diff3-group to be called for the
- ;; various groups of lines (1, 2, 3) in any order, and for the lines to
- ;; appear in any order. The reason this is necessary is that Gnu diff3
- ;; can produce the groups in the order 1, 2, 3 or 1, 3, 2.
- (save-excursion
- (re-search-forward
- (concat "^" file ":\\([0-9]+\\)\\(,\\([0-9]+\\)\\)?\\([ac]\\)\C-m?$"))
- (beginning-of-line 2)
- ;; treatment depends on whether it is an "a" group or a "c" group
- (if (string-equal (buffer-substring (match-beginning 4) (match-end 4)) "c")
- ;; it is a "c" group
- (if (match-beginning 2)
- ;; it has two numbers
- (list (string-to-number
- (buffer-substring (match-beginning 1) (match-end 1)))
- (1+ (string-to-number
- (buffer-substring (match-beginning 3) (match-end 3)))))
- ;; it has one number
- (let ((x (string-to-number
- (buffer-substring (match-beginning 1) (match-end 1)))))
- (list x (1+ x))))
- ;; it is an "a" group
- (let ((x (1+ (string-to-number
- (buffer-substring (match-beginning 1) (match-end 1))))))
- (list x x)))))
-
-
-;; If WORD-MODE, construct vector of diffs using word numbers.
-;; Else, use point values.
-;; WORD-MODE also tells if we are in the word-mode or not.
-;; If THREE-WAY-COMP, then it is a 3-way comparison. Else, it is merging
-;; with ancestor, in which case buffer-C contents is identical to buffer-A/B,
-;; contents (unless buffer-A is narrowed) depending on ediff-default-variant's
-;; value.
-;; BOUNDS specifies visibility bounds to use.
-(defun ediff-extract-diffs3 (diff-buffer word-mode three-way-comp
- &optional bounds)
- (let ((A-buffer ediff-buffer-A)
- (B-buffer ediff-buffer-B)
- (C-buffer ediff-buffer-C)
- (anc-buffer ediff-ancestor-buffer)
- (a-prev 1) ; needed to set the first diff line correctly
- (a-prev-pt nil)
- (b-prev 1)
- (b-prev-pt nil)
- (c-prev 1)
- (c-prev-pt nil)
- (anc-prev 1)
- diff-list shift-A shift-B shift-C
- )
-
- ;; diff list contains word numbers or points, depending on word-mode
- (setq diff-list (cons (if word-mode 'words 'points)
- diff-list))
- (if bounds
- (setq shift-A
- (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type 'A bounds))
- shift-B
- (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type 'B bounds))
- shift-C
- (if three-way-comp
- (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type 'C bounds)))))
-
- ;; reset point in buffers A, B, C
- (ediff-with-current-buffer A-buffer
- (goto-char (if shift-A shift-A (point-min))))
- (ediff-with-current-buffer B-buffer
- (goto-char (if shift-B shift-B (point-min))))
- (if three-way-comp
- (ediff-with-current-buffer C-buffer
- (goto-char (if shift-C shift-C (point-min)))))
- (if (ediff-buffer-live-p anc-buffer)
- (ediff-with-current-buffer anc-buffer
- (goto-char (point-min))))
-
- (ediff-with-current-buffer diff-buffer
- (goto-char (point-min))
- (while (re-search-forward ediff-match-diff3-line nil t)
- ;; leave point after matched line
- (beginning-of-line 2)
- (let ((agreement (buffer-substring (match-beginning 1) (match-end 1))))
- ;; if the files A and B are the same and not 3way-comparison,
- ;; ignore the difference
- (if (or three-way-comp (not (string-equal agreement "3")))
- (let* ((a-begin (car (ediff-get-diff3-group "1")))
- (a-end (nth 1 (ediff-get-diff3-group "1")))
- (b-begin (car (ediff-get-diff3-group "2")))
- (b-end (nth 1 (ediff-get-diff3-group "2")))
- (c-or-anc-begin (car (ediff-get-diff3-group "3")))
- (c-or-anc-end (nth 1 (ediff-get-diff3-group "3")))
- (state-of-merge
- (cond ((string-equal agreement "1") 'prefer-A)
- ((string-equal agreement "2") 'prefer-B)
- (t ediff-default-variant)))
- (state-of-diff-merge
- (if (memq state-of-merge '(default-A prefer-A)) 'B 'A))
- (state-of-diff-comparison
- (cond ((string-equal agreement "1") 'A)
- ((string-equal agreement "2") 'B)
- ((string-equal agreement "3") 'C)))
- state-of-ancestor
- c-begin c-end
- a-begin-pt a-end-pt
- b-begin-pt b-end-pt
- c-begin-pt c-end-pt
- anc-begin-pt anc-end-pt)
-
- (setq state-of-ancestor
- (= c-or-anc-begin c-or-anc-end))
-
- (cond (three-way-comp
- (setq c-begin c-or-anc-begin
- c-end c-or-anc-end))
- ((eq ediff-default-variant 'default-B)
- (setq c-begin b-begin
- c-end b-end))
- (t
- (setq c-begin a-begin
- c-end a-end)))
-
- ;; compute main diff vector
- (if word-mode
- ;; make diff-list contain word numbers
- (setq diff-list
- (nconc diff-list
- (list (vector
- (- a-begin a-prev) (- a-end a-begin)
- (- b-begin b-prev) (- b-end b-begin)
- (- c-begin c-prev) (- c-end c-begin)
- nil nil ; dummy ancestor
- nil ; state of diff
- nil ; state of merge
- nil ; state of ancestor
- )))
- a-prev a-end
- b-prev b-end
- c-prev c-end)
- ;; else convert lines to points
- (ediff-with-current-buffer A-buffer
- (let ((longlines-mode-val
- (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
- ;; we must disable and then restore longlines-mode
- (if (eq longlines-mode-val 1)
- (longlines-mode 0))
- (goto-char (or a-prev-pt shift-A (point-min)))
- (forward-line (- a-begin a-prev))
- (setq a-begin-pt (point))
- (forward-line (- a-end a-begin))
- (setq a-end-pt (point)
- a-prev a-end
- a-prev-pt a-end-pt)
- (if (eq longlines-mode-val 1)
- (longlines-mode longlines-mode-val))
- ))
- (ediff-with-current-buffer B-buffer
- (let ((longlines-mode-val
- (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
- (if (eq longlines-mode-val 1)
- (longlines-mode 0))
- (goto-char (or b-prev-pt shift-B (point-min)))
- (forward-line (- b-begin b-prev))
- (setq b-begin-pt (point))
- (forward-line (- b-end b-begin))
- (setq b-end-pt (point)
- b-prev b-end
- b-prev-pt b-end-pt)
- (if (eq longlines-mode-val 1)
- (longlines-mode longlines-mode-val))
- ))
- (ediff-with-current-buffer C-buffer
- (let ((longlines-mode-val
- (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
- (if (eq longlines-mode-val 1)
- (longlines-mode 0))
- (goto-char (or c-prev-pt shift-C (point-min)))
- (forward-line (- c-begin c-prev))
- (setq c-begin-pt (point))
- (forward-line (- c-end c-begin))
- (setq c-end-pt (point)
- c-prev c-end
- c-prev-pt c-end-pt)
- (if (eq longlines-mode-val 1)
- (longlines-mode longlines-mode-val))
- ))
- (if (ediff-buffer-live-p anc-buffer)
- (ediff-with-current-buffer anc-buffer
- (let ((longlines-mode-val
- (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
- (if (eq longlines-mode-val 1)
- (longlines-mode 0))
- (forward-line (- c-or-anc-begin anc-prev))
- (setq anc-begin-pt (point))
- (forward-line (- c-or-anc-end c-or-anc-begin))
- (setq anc-end-pt (point)
- anc-prev c-or-anc-end)
- (if (eq longlines-mode-val 1)
- (longlines-mode longlines-mode-val))
- )))
- (setq diff-list
- (nconc
- diff-list
- ;; if comparing with ancestor, then there also is a
- ;; state-of-difference marker
- (if three-way-comp
- (list (vector
- a-begin-pt a-end-pt
- b-begin-pt b-end-pt
- c-begin-pt c-end-pt
- nil nil ; ancestor begin/end
- state-of-diff-comparison
- nil ; state of merge
- nil ; state of ancestor
- ))
- (list (vector a-begin-pt a-end-pt
- b-begin-pt b-end-pt
- c-begin-pt c-end-pt
- anc-begin-pt anc-end-pt
- state-of-diff-merge
- state-of-merge
- state-of-ancestor
- )))
- )))
- ))
-
- ))) ; end ediff-with-current-buffer
- diff-list
- ))
-
-;; Generate the difference vector and overlays for three files
-;; File-C is either the third file to compare (in case of 3-way comparison)
-;; or it is the ancestor file.
-(defun ediff-setup-diff-regions3 (file-A file-B file-C)
- ;; looking for '-i' or a 'i' among clustered non-long options
- (if (string-match "^-i\\| -i\\|\\(^\\| \\)-[^- ]+i" ediff-diff-options)
- (error "Option `-i' is not allowed in `ediff-diff3-options'"))
-
- (or (ediff-buffer-live-p ediff-diff-buffer)
- (setq ediff-diff-buffer
- (get-buffer-create (ediff-unique-buffer-name "*ediff-diff" "*"))))
-
- (message "Computing differences ...")
- (ediff-exec-process ediff-diff3-program ediff-diff-buffer 'synchronize
- ediff-actual-diff3-options file-A file-B file-C)
-
- (ediff-prepare-error-list ediff-diff3-ok-lines-regexp ediff-diff-buffer)
- ;;(message "Computing differences ... done")
- (ediff-convert-diffs-to-overlays
- (ediff-extract-diffs3
- ediff-diff-buffer
- ediff-word-mode ediff-3way-comparison-job ediff-narrow-bounds)
- ))
-
-
-;; Execute PROGRAM asynchronously, unless OS/2, Windows-*, or DOS, or unless
-;; SYNCH is non-nil. BUFFER must be a buffer object, and must be alive. The
-;; OPTIONS arg is a list of options to pass to PROGRAM. It may be a blank
-;; string. All elements in FILES must be strings. We also delete nil from
-;; args.
-(defun ediff-exec-process (program buffer synch options &rest files)
- (let ((data (match-data))
- ;; If this is a buffer job, we are diffing temporary files
- ;; produced by Emacs with ediff-coding-system-for-write, so
- ;; use the same encoding to read the results.
- (coding-system-for-read
- (if (string-match "buffer" (symbol-name ediff-job-name))
- ediff-coding-system-for-write
- ediff-coding-system-for-read))
- args)
- (setq args (append (split-string options) files))
- (setq args (delete "" (delq nil args))) ; delete nil and "" from arguments
- ;; the --binary option, if present, should be used only for buffer jobs
- ;; or for refining the differences
- (or (string-match "buffer" (symbol-name ediff-job-name))
- (eq buffer ediff-fine-diff-buffer)
- (setq args (delete "--binary" args)))
- (unwind-protect
- (let ((directory default-directory)
- proc)
- (with-current-buffer buffer
- (erase-buffer)
- (setq default-directory directory)
- (if (or (memq system-type '(emx ms-dos windows-nt windows-95))
- synch)
- ;; In OS/2 (emx) do it synchronously, since OS/2 doesn't let us
- ;; delete files used by other processes. Thus, in ediff-buffers
- ;; and similar functions, we can't delete temp files because
- ;; they might be used by the asynch process that computes
- ;; custom diffs. So, we have to wait till custom diff
- ;; subprocess is done.
- ;; Similarly for Windows-*
- ;; In DOS, must synchronize because DOS doesn't have
- ;; asynchronous processes.
- (apply 'call-process program nil buffer nil args)
- ;; On other systems, do it asynchronously.
- (setq proc (get-buffer-process buffer))
- (if proc (kill-process proc))
- (setq proc
- (apply 'start-process "Custom Diff" buffer program args))
- (setq mode-line-process '(":%s"))
- (set-process-sentinel proc 'ediff-process-sentinel)
- (set-process-filter proc 'ediff-process-filter)
- )))
- (store-match-data data))))
-
-;; This is shell-command-filter from simple.el in Emacs.
-;; Copied here because XEmacs doesn't have it.
-(defun ediff-process-filter (proc string)
- ;; Do save-excursion by hand so that we can leave point numerically unchanged
- ;; despite an insertion immediately after it.
- (let* ((obuf (current-buffer))
- (buffer (process-buffer proc))
- opoint
- (window (get-buffer-window buffer))
- (pos (window-start window)))
- (unwind-protect
- (progn
- (set-buffer buffer)
- (or (= (point) (point-max))
- (setq opoint (point)))
- (goto-char (point-max))
- (insert-before-markers string))
- ;; insert-before-markers moved this marker: set it back.
- (set-window-start window pos)
- ;; Finish our save-excursion.
- (if opoint
- (goto-char opoint))
- (set-buffer obuf))))
-
-;; like shell-command-sentinel but doesn't print an exit status message
-;; we do this because diff always exits with status 1, if diffs are found
-;; so shell-command-sentinel displays a confusing message to the user
-(defun ediff-process-sentinel (process signal)
- (if (and (memq (process-status process) '(exit signal))
- (buffer-name (process-buffer process)))
- (progn
- (with-current-buffer (process-buffer process)
- (setq mode-line-process nil))
- (delete-process process))))
-
-
-;;; Word functions used to refine the current diff
-
-(defvar ediff-forward-word-function 'ediff-forward-word
- "*Function to call to move to the next word.
-Used for splitting difference regions into individual words.")
-(make-variable-buffer-local 'ediff-forward-word-function)
-
-;; \240 is unicode symbol for nonbreakable whitespace
-(defvar ediff-whitespace " \n\t\f\r\240"
- "*Characters constituting white space.
-These characters are ignored when differing regions are split into words.")
-(make-variable-buffer-local 'ediff-whitespace)
-
-(defvar ediff-word-1
- (if (featurep 'xemacs) "a-zA-Z---_" "-[:word:]_")
- "*Characters that constitute words of type 1.
-More precisely, [ediff-word-1] is a regexp that matches type 1 words.
-See `ediff-forward-word' for more details.")
-(make-variable-buffer-local 'ediff-word-1)
-
-(defvar ediff-word-2 "0-9.,"
- "*Characters that constitute words of type 2.
-More precisely, [ediff-word-2] is a regexp that matches type 2 words.
-See `ediff-forward-word' for more details.")
-(make-variable-buffer-local 'ediff-word-2)
-
-(defvar ediff-word-3 "`'?!:;\"{}[]()"
- "*Characters that constitute words of type 3.
-More precisely, [ediff-word-3] is a regexp that matches type 3 words.
-See `ediff-forward-word' for more details.")
-(make-variable-buffer-local 'ediff-word-3)
-
-(defvar ediff-word-4
- (concat "^" ediff-word-1 ediff-word-2 ediff-word-3 ediff-whitespace)
- "*Characters that constitute words of type 4.
-More precisely, [ediff-word-4] is a regexp that matches type 4 words.
-See `ediff-forward-word' for more details.")
-(make-variable-buffer-local 'ediff-word-4)
-
-;; Split region along word boundaries. Each word will be on its own line.
-;; Output to buffer out-buffer.
-(defun ediff-forward-word ()
- "Move point one word forward.
-There are four types of words, each of which consists entirely of
-characters in `ediff-word-1', `ediff-word-2', `ediff-word-3', or
-`ediff-word-4'. Words are recognized by passing these one after another as
-arguments to `skip-chars-forward'."
- (or (> (+ (skip-chars-forward ediff-word-1)
- (skip-syntax-forward "w"))
- 0)
- (> (skip-chars-forward ediff-word-2) 0)
- (> (skip-chars-forward ediff-word-3) 0)
- (> (skip-chars-forward ediff-word-4) 0)
- ))
-
-
-(defun ediff-wordify (beg end in-buffer out-buffer &optional control-buf)
- (let ((forward-word-function
- ;; eval in control buf to let user create local versions for
- ;; different invocations
- (if control-buf
- (ediff-with-current-buffer control-buf
- ediff-forward-word-function)
- ediff-forward-word-function))
- inbuf-syntax-tbl sv-point diff-string)
- (with-current-buffer in-buffer
- (setq inbuf-syntax-tbl
- (if control-buf
- (ediff-with-current-buffer control-buf
- ediff-syntax-table)
- (syntax-table)))
- (setq diff-string (buffer-substring-no-properties beg end))
-
- (set-buffer out-buffer)
- ;; Make sure that temp buff syntax table is the same as the original buf
- ;; syntax tbl, because we use ediff-forward-word in both and
- ;; ediff-forward-word depends on the syntax classes of characters.
- (set-syntax-table inbuf-syntax-tbl)
- (erase-buffer)
- (insert diff-string)
- (goto-char (point-min))
- (skip-chars-forward ediff-whitespace)
- (delete-region (point-min) (point))
-
- (while (not (eobp))
- (funcall forward-word-function)
- (setq sv-point (point))
- (skip-chars-forward ediff-whitespace)
- (delete-region sv-point (point))
- (insert "\n")))))
-
-;; copy string specified as BEG END from IN-BUF to OUT-BUF
-(defun ediff-copy-to-buffer (beg end in-buffer out-buffer)
- (with-current-buffer out-buffer
- (erase-buffer)
- (insert-buffer-substring in-buffer beg end)
- (goto-char (point-min))))
-
-
-;; goto word #n starting at current position in buffer `buf'
-;; For ediff, a word is determined by ediff-forward-word-function
-;; If `flag' is non-nil, goto the end of the n-th word.
-(defun ediff-goto-word (n buf &optional flag)
- ;; remember val ediff-forward-word-function has in ctl buf
- (let ((fwd-word-fun ediff-forward-word-function)
- (syntax-tbl ediff-syntax-table))
- (ediff-with-current-buffer buf
- (skip-chars-forward ediff-whitespace)
- (ediff-with-syntax-table syntax-tbl
- (while (> n 1)
- (funcall fwd-word-fun)
- (skip-chars-forward ediff-whitespace)
- (setq n (1- n)))
- (if (and flag (> n 0))
- (funcall fwd-word-fun)))
- (point))))
-
-(defun ediff-same-file-contents (f1 f2)
- "Return t if files F1 and F2 have identical contents."
- (if (and (not (file-directory-p f1))
- (not (file-directory-p f2)))
- (let ((res
- (apply 'call-process ediff-cmp-program nil nil nil
- (append ediff-cmp-options (list (expand-file-name f1)
- (expand-file-name f2))))
- ))
- (and (numberp res) (eq res 0)))
- ))
-
-
-(defun ediff-same-contents (d1 d2 &optional filter-re)
- "Return t if D1 and D2 have the same content.
-D1 and D2 can either be both directories or both regular files.
-Symlinks and the likes are not handled.
-If FILTER-RE is non-nil, recursive checking in directories
-affects only files whose names match the expression."
- ;; Normalize empty filter RE to nil.
- (unless (> (length filter-re) 0) (setq filter-re nil))
- ;; Indicate progress
- (message "Comparing '%s' and '%s' modulo '%s'" d1 d2 filter-re)
- (cond
- ;; D1 & D2 directories => recurse
- ((and (file-directory-p d1)
- (file-directory-p d2))
- (if (null ediff-recurse-to-subdirectories)
- (if (y-or-n-p "Compare subdirectories recursively? ")
- (setq ediff-recurse-to-subdirectories 'yes)
- (setq ediff-recurse-to-subdirectories 'no)))
- (if (eq ediff-recurse-to-subdirectories 'yes)
- (let* ((all-entries-1 (directory-files d1 t filter-re))
- (all-entries-2 (directory-files d2 t filter-re))
- (entries-1 (ediff-delete-all-matches "^\\.\\.?$" all-entries-1))
- (entries-2 (ediff-delete-all-matches "^\\.\\.?$" all-entries-2))
- )
-
- (ediff-same-file-contents-lists entries-1 entries-2 filter-re)
- ))
- ) ; end of the directories case
- ;; D1 & D2 are both files => compare directly
- ((and (file-regular-p d1)
- (file-regular-p d2))
- (ediff-same-file-contents d1 d2))
- ;; Otherwise => false: unequal contents
- )
- )
-
-;; If lists have the same length and names of files are pairwise equal
-;; (removing the directories) then compare contents pairwise.
-;; True if all contents are the same; false otherwise
-(defun ediff-same-file-contents-lists (entries-1 entries-2 filter-re)
- ;; First, check only the names (works quickly and ensures a
- ;; precondition for subsequent code)
- (if (and (= (length entries-1) (length entries-2))
- (equal (mapcar 'file-name-nondirectory entries-1)
- (mapcar 'file-name-nondirectory entries-2)))
- ;; With name equality established, compare the entries
- ;; through recursion.
- (let ((continue t))
- (while (and entries-1 continue)
- (if (ediff-same-contents
- (car entries-1) (car entries-2) filter-re)
- (setq entries-1 (cdr entries-1)
- entries-2 (cdr entries-2))
- (setq continue nil))
- )
- ;; if reached the end then lists are equal
- (null entries-1))
- )
- )
-
-
-;; ARG1 is a regexp, ARG2 is a list of full-filenames
-;; Delete all entries that match the regexp
-(defun ediff-delete-all-matches (regex file-list-list)
- (let (result elt)
- (while file-list-list
- (setq elt (car file-list-list))
- (or (string-match regex (file-name-nondirectory elt))
- (setq result (cons elt result)))
- (setq file-list-list (cdr file-list-list)))
- (reverse result)))
-
-
-(defun ediff-set-actual-diff-options ()
- (if ediff-ignore-case
- (setq ediff-actual-diff-options
- (concat ediff-diff-options " " ediff-ignore-case-option)
- ediff-actual-diff3-options
- (concat ediff-diff3-options " " ediff-ignore-case-option3))
- (setq ediff-actual-diff-options ediff-diff-options
- ediff-actual-diff3-options ediff-diff3-options)
- )
- (setq-default ediff-actual-diff-options ediff-actual-diff-options
- ediff-actual-diff3-options ediff-actual-diff3-options)
- )
-
-
-;; Ignore case handling - some ideas from drew.adams@@oracle.com
-(defun ediff-toggle-ignore-case ()
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (setq ediff-ignore-case (not ediff-ignore-case))
- (ediff-set-actual-diff-options)
- (if ediff-ignore-case
- (message "Ignoring regions that differ only in case")
- (message "Ignoring case differences turned OFF"))
- (cond (ediff-merge-job
- (message "Ignoring letter case is too dangerous in merge jobs"))
- ((and ediff-diff3-job (string= ediff-ignore-case-option3 ""))
- (message "Ignoring letter case is not supported by this diff3 program"))
- ((and (not ediff-3way-job) (string= ediff-ignore-case-option ""))
- (message "Ignoring letter case is not supported by this diff program"))
- (t
- (sit-for 1)
- (ediff-update-diffs)))
- )
-
-
-
-;; Local Variables:
-;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
-;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
-;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
-;; End:
-
-;; arch-tag: a86d448e-58d7-4572-a1d9-fdedfa22f648
-;;; ediff-diff.el ends here
+++ /dev/null
-;;; ediff-help.el --- Code related to the contents of Ediff help buffers
-
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-
-;; Compiler pacifier start
-(defvar ediff-multiframe)
-;; end pacifier
-
-(require 'ediff-init)
-
-;; Help messages
-
-(defconst ediff-long-help-message-head
- " Move around | Toggle features | Manipulate
-=====================|===========================|============================="
- "The head of the full help message.")
-(defconst ediff-long-help-message-tail
- "=====================|===========================|=============================
- R -show registry | = -compare regions | M -show session group
- D -diff output | E -browse Ediff manual| G -send bug report
- i -status info | ? -help off | z/q -suspend/quit
--------------------------------------------------------------------------------
-For help on a specific command: Click Button 2 over it; or
- Put the cursor over it and type RET."
- "The tail of the full-help message.")
-
-(defconst ediff-long-help-message-compare3
- "
-p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y
-n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
- j -jump to diff | @ -auto-refinement | * -refine current region
- gx -goto X's point| ## -ignore whitespace | ! -update diff regions
- C-l -recenter | #c -ignore case |
- v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
- </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
- ~ -rotate buffers| m -wide display |
-"
- "Help message usually used for 3-way comparison.
-Normally, not a user option. See `ediff-help-message' for details.")
-
-(defconst ediff-long-help-message-compare2
- "
-p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A
-n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
- j -jump to diff | @ -auto-refinement | * -refine current region
- gx -goto X's point| ## -ignore whitespace | ! -update diff regions
- C-l -recenter | #c -ignore case |
- v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
- </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
- ~ -swap variants | m -wide display |
-"
- "Help message usually used for 2-way comparison.
-Normally, not a user option. See `ediff-help-message' for details.")
-
-(defconst ediff-long-help-message-narrow2
- "
-p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A
-n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
- j -jump to diff | @ -auto-refinement | * -refine current region
- gx -goto X's point| ## -ignore whitespace | ! -update diff regions
- C-l -recenter | #c -ignore case | % -narrow/widen buffs
- v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
- </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
- ~ -swap variants | m -wide display |
-"
- "Help message when comparing windows or regions line-by-line.
-Normally, not a user option. See `ediff-help-message' for details.")
-
-(defconst ediff-long-help-message-word-mode
- "
-p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y
-n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
- j -jump to diff | |
- gx -goto X's point| % -narrow/widen buffs | ! -recompute diffs
- C-l -recenter | #c -ignore case |
- v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
- </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
- ~ -swap variants | m -wide display |
-"
- "Help message when comparing windows or regions word-by-word.
-Normally, not a user option. See `ediff-help-message' for details.")
-
-(defconst ediff-long-help-message-merge
- "
-p,DEL -previous diff | | -vert/horiz split | x -copy buf X's region to C
-n,SPC -next diff | h -hilighting | r -restore buf C's old diff
- j -jump to diff | @ -auto-refinement | * -refine current region
- gx -goto X's point| ## -ignore whitespace | ! -update diff regions
- C-l -recenter | #f/#h -focus/hide regions | + -combine diff regions
- v/V -scroll up/dn | X -read-only in buf X | wx -save buf X
- </> -scroll lt/rt | m -wide display | wd -save diff output
- ~ -swap variants | s -shrink window C | / -show ancestor buff
- | $$ -show clashes only | & -merge w/new default
- | $* -skip changed regions |
-"
- "Help message for merge sessions.
-Normally, not a user option. See `ediff-help-message' for details.")
-
-;; The actual long help message.
-(ediff-defvar-local ediff-long-help-message ""
- "Normally, not a user option. See `ediff-help-message' for details.")
-
-(defconst ediff-brief-message-string
- " Type ? for help"
- "Contents of the brief help message.")
-;; The actual brief help message
-(ediff-defvar-local ediff-brief-help-message ""
- "Normally, not a user option. See `ediff-help-message' for details.")
-
-(ediff-defvar-local ediff-brief-help-message-function nil
- "The brief help message that the user can customize.
-If the user sets this to a parameter-less function, Ediff will use it to
-produce the brief help message. This function must return a string.")
-(ediff-defvar-local ediff-long-help-message-function nil
- "The long help message that the user can customize.
-See `ediff-brief-help-message-function' for more.")
-
-(defcustom ediff-use-long-help-message nil
- "If t, Ediff displays a long help message. Short help message otherwise."
- :type 'boolean
- :group 'ediff-window)
-
-;; The actual help message.
-(ediff-defvar-local ediff-help-message ""
- "The actual help message.
-Normally, the user shouldn't touch this. However, if you want Ediff to
-start up with different help messages for different jobs, you can change
-the value of this variable and the variables `ediff-help-message-*' in
-`ediff-startup-hook'.")
-
-
-;; the keymap that defines clicks over the quick help regions
-(defvar ediff-help-region-map (make-sparse-keymap))
-
-(define-key
- ediff-help-region-map
- (if (featurep 'emacs) [mouse-2] [button2])
- 'ediff-help-for-quick-help)
-
-;; runs in the control buffer
-(defun ediff-set-help-overlays ()
- (goto-char (point-min))
- (let (overl beg end cmd)
- (while (re-search-forward " *\\([^ \t\n|]+\\||\\) +-[^|\n]+" nil 'noerror)
- (setq beg (match-beginning 0)
- end (match-end 0)
- cmd (buffer-substring (match-beginning 1) (match-end 1)))
- (setq overl (ediff-make-overlay beg end))
- (if (featurep 'emacs)
- (ediff-overlay-put overl 'mouse-face 'highlight)
- (ediff-overlay-put overl 'highlight t))
- (ediff-overlay-put overl 'ediff-help-info cmd))))
-
-
-(defun ediff-help-for-quick-help ()
- "Explain Ediff commands in more detail."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (let ((pos (ediff-event-point last-command-event))
- overl cmd)
-
- (if (featurep 'xemacs)
- (setq overl (extent-at pos (current-buffer) 'ediff-help-info)
- cmd (ediff-overlay-get overl 'ediff-help-info))
- (setq cmd (car (mapcar (lambda (elt)
- (overlay-get elt 'ediff-help-info))
- (overlays-at pos)))))
-
- (if (not (stringp cmd))
- (error "Hmm... I don't see an Ediff command around here..."))
-
- (ediff-documentation "Quick Help Commands")
-
- (let (case-fold-search)
- (cond ((string= cmd "?") (re-search-forward "^`\\?'"))
- ((string= cmd "G") (re-search-forward "^`G'"))
- ((string= cmd "E") (re-search-forward "^`E'"))
- ((string= cmd "wd") (re-search-forward "^`wd'"))
- ((string= cmd "wx") (re-search-forward "^`wa'"))
- ((string= cmd "a/b") (re-search-forward "^`a'"))
- ((string= cmd "x") (re-search-forward "^`a'"))
- ((string= cmd "xy") (re-search-forward "^`ab'"))
- ((string= cmd "p,DEL") (re-search-forward "^`p'"))
- ((string= cmd "n,SPC") (re-search-forward "^`n'"))
- ((string= cmd "j") (re-search-forward "^`j'"))
- ((string= cmd "gx") (re-search-forward "^`ga'"))
- ((string= cmd "!") (re-search-forward "^`!'"))
- ((string= cmd "*") (re-search-forward "^`\\*'"))
- ((string= cmd "m") (re-search-forward "^`m'"))
- ((string= cmd "|") (re-search-forward "^`|'"))
- ((string= cmd "@") (re-search-forward "^`@'"))
- ((string= cmd "h") (re-search-forward "^`h'"))
- ((string= cmd "r") (re-search-forward "^`r'"))
- ((string= cmd "rx") (re-search-forward "^`ra'"))
- ((string= cmd "##") (re-search-forward "^`##'"))
- ((string= cmd "#c") (re-search-forward "^`#c'"))
- ((string= cmd "#f/#h") (re-search-forward "^`#f'"))
- ((string= cmd "X") (re-search-forward "^`A'"))
- ((string= cmd "v/V") (re-search-forward "^`v'"))
- ((string= cmd "</>") (re-search-forward "^`<'"))
- ((string= cmd "~") (re-search-forward "^`~'"))
- ((string= cmd "i") (re-search-forward "^`i'"))
- ((string= cmd "D") (re-search-forward "^`D'"))
- ((string= cmd "R") (re-search-forward "^`R'"))
- ((string= cmd "M") (re-search-forward "^`M'"))
- ((string= cmd "z/q") (re-search-forward "^`z'"))
- ((string= cmd "%") (re-search-forward "^`%'"))
- ((string= cmd "C-l") (re-search-forward "^`C-l'"))
- ((string= cmd "$$") (re-search-forward "^`\\$\\$'"))
- ((string= cmd "$*") (re-search-forward "^`\\$\\*'"))
- ((string= cmd "/") (re-search-forward "^`/'"))
- ((string= cmd "&") (re-search-forward "^`&'"))
- ((string= cmd "s") (re-search-forward "^`s'"))
- ((string= cmd "+") (re-search-forward "^`\\+'"))
- ((string= cmd "=") (re-search-forward "^`='"))
- (t (error "Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer")))
- ) ; let case-fold-search
- ))
-
-
-;; assuming we are in control window, calculate length of the first line in
-;; help message
-(defun ediff-help-message-line-length ()
- (save-excursion
- (goto-char (point-min))
- (if ediff-use-long-help-message
- (forward-line 1))
- (end-of-line)
- (current-column)))
-
-
-(defun ediff-indent-help-message ()
- (let* ((shift (/ (max 0 (- (window-width (selected-window))
- (ediff-help-message-line-length)))
- 2))
- (str (make-string shift ?\ )))
- (save-excursion
- (goto-char (point-min))
- (while (< (point) (point-max))
- (insert str)
- (beginning-of-line)
- (forward-line 1)))))
-
-
-;; compose the help message as a string
-(defun ediff-set-help-message ()
- (setq ediff-long-help-message
- (cond ((and ediff-long-help-message-function
- (or (symbolp ediff-long-help-message-function)
- (consp ediff-long-help-message-function)))
- (funcall ediff-long-help-message-function))
- (ediff-word-mode
- (concat ediff-long-help-message-head
- ediff-long-help-message-word-mode
- ediff-long-help-message-tail))
- (ediff-narrow-job
- (concat ediff-long-help-message-head
- ediff-long-help-message-narrow2
- ediff-long-help-message-tail))
- (ediff-merge-job
- (concat ediff-long-help-message-head
- ediff-long-help-message-merge
- ediff-long-help-message-tail))
- (ediff-diff3-job
- (concat ediff-long-help-message-head
- ediff-long-help-message-compare3
- ediff-long-help-message-tail))
- (t
- (concat ediff-long-help-message-head
- ediff-long-help-message-compare2
- ediff-long-help-message-tail))))
- (setq ediff-brief-help-message
- (cond ((and ediff-brief-help-message-function
- (or (symbolp ediff-brief-help-message-function)
- (consp ediff-brief-help-message-function)))
- (funcall ediff-brief-help-message-function))
- ((stringp ediff-brief-help-message-function)
- ediff-brief-help-message-function)
- ((ediff-multiframe-setup-p) ediff-brief-message-string)
- (t ; long brief msg, not multiframe --- put in the middle
- ediff-brief-message-string)
- ))
- (setq ediff-help-message (if ediff-use-long-help-message
- ediff-long-help-message
- ediff-brief-help-message))
- (run-hooks 'ediff-display-help-hook))
-
-;;;###autoload
-(defun ediff-customize ()
- (interactive)
- (customize-group "ediff"))
-
-
-(provide 'ediff-help)
-
-
-;; arch-tag: 05659813-7fcf-4274-964f-d2f577431a9d
-;;; ediff-help.el ends here
+++ /dev/null
-;;; ediff-hook.el --- setup for Ediff's menus and autoloads
-
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-;;; These must be placed in menu-bar.el in Emacs
-;;
-;; (define-key menu-bar-tools-menu [ediff-misc]
-;; '("Ediff Miscellanea" . menu-bar-ediff-misc-menu))
-;; (define-key menu-bar-tools-menu [epatch]
-;; '("Apply Patch" . menu-bar-epatch-menu))
-;; (define-key menu-bar-tools-menu [ediff-merge]
-;; '("Merge" . menu-bar-ediff-merge-menu))
-;; (define-key menu-bar-tools-menu [ediff]
-;; '("Compare" . menu-bar-ediff-menu))
-
-;; Compiler pacifier
-(defvar ediff-menu)
-(defvar ediff-merge-menu)
-(defvar epatch-menu)
-(defvar ediff-misc-menu)
-;; end pacifier
-
-;; allow menus to be set up without ediff-wind.el being loaded
-(defvar ediff-window-setup-function)
-
-;; This autoload is useless in Emacs because ediff-hook.el is dumped with
-;; emacs, but it is needed in XEmacs
-;;;###autoload
-(if (featurep 'xemacs)
- (progn
- (defun ediff-xemacs-init-menus ()
- (when (featurep 'menubar)
- (add-submenu
- '("Tools") ediff-menu "OO-Browser...")
- (add-submenu
- '("Tools") ediff-merge-menu "OO-Browser...")
- (add-submenu
- '("Tools") epatch-menu "OO-Browser...")
- (add-submenu
- '("Tools") ediff-misc-menu "OO-Browser...")
- (add-menu-button
- '("Tools") "-------" "OO-Browser...")
- ))
- (defvar ediff-menu
- '("Compare"
- ["Two Files..." ediff-files t]
- ["Two Buffers..." ediff-buffers t]
- ["Three Files..." ediff-files3 t]
- ["Three Buffers..." ediff-buffers3 t]
- "---"
- ["Two Directories..." ediff-directories t]
- ["Three Directories..." ediff-directories3 t]
- "---"
- ["File with Revision..." ediff-revision t]
- ["Directory Revisions..." ediff-directory-revisions t]
- "---"
- ["Windows Word-by-word..." ediff-windows-wordwise t]
- ["Windows Line-by-line..." ediff-windows-linewise t]
- "---"
- ["Regions Word-by-word..." ediff-regions-wordwise t]
- ["Regions Line-by-line..." ediff-regions-linewise t]
- ))
- (defvar ediff-merge-menu
- '("Merge"
- ["Files..." ediff-merge-files t]
- ["Files with Ancestor..." ediff-merge-files-with-ancestor t]
- ["Buffers..." ediff-merge-buffers t]
- ["Buffers with Ancestor..."
- ediff-merge-buffers-with-ancestor t]
- "---"
- ["Directories..." ediff-merge-directories t]
- ["Directories with Ancestor..."
- ediff-merge-directories-with-ancestor t]
- "---"
- ["Revisions..." ediff-merge-revisions t]
- ["Revisions with Ancestor..."
- ediff-merge-revisions-with-ancestor t]
- ["Directory Revisions..." ediff-merge-directory-revisions t]
- ["Directory Revisions with Ancestor..."
- ediff-merge-directory-revisions-with-ancestor t]
- ))
- (defvar epatch-menu
- '("Apply Patch"
- ["To a file..." ediff-patch-file t]
- ["To a buffer..." ediff-patch-buffer t]
- ))
- (defvar ediff-misc-menu
- '("Ediff Miscellanea"
- ["Ediff Manual" ediff-documentation t]
- ["Customize Ediff" ediff-customize t]
- ["List Ediff Sessions" ediff-show-registry t]
- ["Use separate frame for Ediff control buffer"
- ediff-toggle-multiframe
- :style toggle
- :selected (if (and (featurep 'ediff-util)
- (boundp 'ediff-window-setup-function))
- (eq ediff-window-setup-function
- 'ediff-setup-windows-multiframe))]
- ["Use a toolbar with Ediff control buffer"
- ediff-toggle-use-toolbar
- :style toggle
- :selected (if (featurep 'ediff-tbar)
- (ediff-use-toolbar-p))]))
-
- ;; put these menus before Object-Oriented-Browser in Tools menu
- (if (and (featurep 'menubar) (not (featurep 'infodock))
- (not (featurep 'ediff-hook)))
- (ediff-xemacs-init-menus)))
- ;; Emacs
- ;; initialize menu bar keymaps
- (defvar menu-bar-ediff-misc-menu
- (make-sparse-keymap "Ediff Miscellanea"))
- (fset 'menu-bar-ediff-misc-menu
- (symbol-value 'menu-bar-ediff-misc-menu))
- (defvar menu-bar-epatch-menu (make-sparse-keymap "Apply Patch"))
- (fset 'menu-bar-epatch-menu (symbol-value 'menu-bar-epatch-menu))
- (defvar menu-bar-ediff-merge-menu (make-sparse-keymap "Merge"))
- (fset 'menu-bar-ediff-merge-menu
- (symbol-value 'menu-bar-ediff-merge-menu))
- (defvar menu-bar-ediff-menu (make-sparse-keymap "Compare"))
- (fset 'menu-bar-ediff-menu (symbol-value 'menu-bar-ediff-menu))
-
- ;; define ediff compare menu
- (define-key menu-bar-ediff-menu [ediff-misc]
- `(menu-item ,(purecopy "Ediff Miscellanea") menu-bar-ediff-misc-menu))
- (define-key menu-bar-ediff-menu [separator-ediff-misc] menu-bar-separator)
- (define-key menu-bar-ediff-menu [window]
- `(menu-item ,(purecopy "This Window and Next Window") compare-windows
- :help ,(purecopy "Compare the current window and the next window")))
- (define-key menu-bar-ediff-menu [ediff-windows-linewise]
- `(menu-item ,(purecopy "Windows Line-by-line...") ediff-windows-linewise
- :help ,(purecopy "Compare windows line-wise")))
- (define-key menu-bar-ediff-menu [ediff-windows-wordwise]
- `(menu-item ,(purecopy "Windows Word-by-word...") ediff-windows-wordwise
- :help ,(purecopy "Compare windows word-wise")))
- (define-key menu-bar-ediff-menu [separator-ediff-windows] menu-bar-separator)
- (define-key menu-bar-ediff-menu [ediff-regions-linewise]
- `(menu-item ,(purecopy "Regions Line-by-line...") ediff-regions-linewise
- :help ,(purecopy "Compare regions line-wise")))
- (define-key menu-bar-ediff-menu [ediff-regions-wordwise]
- `(menu-item ,(purecopy "Regions Word-by-word...") ediff-regions-wordwise
- :help ,(purecopy "Compare regions word-wise")))
- (define-key menu-bar-ediff-menu [separator-ediff-regions] menu-bar-separator)
- (define-key menu-bar-ediff-menu [ediff-dir-revision]
- `(menu-item ,(purecopy "Directory Revisions...") ediff-directory-revisions
- :help ,(purecopy "Compare directory files with their older versions")))
- (define-key menu-bar-ediff-menu [ediff-revision]
- `(menu-item ,(purecopy "File with Revision...") ediff-revision
- :help ,(purecopy "Compare file with its older versions")))
- (define-key menu-bar-ediff-menu [separator-ediff-directories] menu-bar-separator)
- (define-key menu-bar-ediff-menu [ediff-directories3]
- `(menu-item ,(purecopy "Three Directories...") ediff-directories3
- :help ,(purecopy "Compare files common to three directories simultaneously")))
- (define-key menu-bar-ediff-menu [ediff-directories]
- `(menu-item ,(purecopy "Two Directories...") ediff-directories
- :help ,(purecopy "Compare files common to two directories simultaneously")))
- (define-key menu-bar-ediff-menu [separator-ediff-files] menu-bar-separator)
- (define-key menu-bar-ediff-menu [ediff-buffers3]
- `(menu-item ,(purecopy "Three Buffers...") ediff-buffers3
- :help ,(purecopy "Compare three buffers simultaneously")))
- (define-key menu-bar-ediff-menu [ediff-files3]
- `(menu-item ,(purecopy "Three Files...") ediff-files3
- :help ,(purecopy "Compare three files simultaneously")))
- (define-key menu-bar-ediff-menu [ediff-buffers]
- `(menu-item ,(purecopy "Two Buffers...") ediff-buffers
- :help ,(purecopy "Compare two buffers simultaneously")))
- (define-key menu-bar-ediff-menu [ediff-files]
- `(menu-item ,(purecopy "Two Files...") ediff-files
- :help ,(purecopy "Compare two files simultaneously")))
-
- ;; define ediff merge menu
- (define-key
- menu-bar-ediff-merge-menu [ediff-merge-dir-revisions-with-ancestor]
- `(menu-item ,(purecopy "Directory Revisions with Ancestor...")
- ediff-merge-directory-revisions-with-ancestor
- :help ,(purecopy "Merge versions of the files in the same directory by comparing the files with common ancestors")))
- (define-key
- menu-bar-ediff-merge-menu [ediff-merge-dir-revisions]
- `(menu-item ,(purecopy "Directory Revisions...") ediff-merge-directory-revisions
- :help ,(purecopy "Merge versions of the files in the same directory (without using ancestor information)")))
- (define-key
- menu-bar-ediff-merge-menu [ediff-merge-revisions-with-ancestor]
- `(menu-item ,(purecopy "Revisions with Ancestor...")
- ediff-merge-revisions-with-ancestor
- :help ,(purecopy "Merge versions of the same file by comparing them with a common ancestor")))
- (define-key menu-bar-ediff-merge-menu [ediff-merge-revisions]
- `(menu-item ,(purecopy "Revisions...") ediff-merge-revisions
- :help ,(purecopy "Merge versions of the same file (without using ancestor information)")))
- (define-key menu-bar-ediff-merge-menu [separator-ediff-merge] menu-bar-separator)
- (define-key
- menu-bar-ediff-merge-menu [ediff-merge-directories-with-ancestor]
- `(menu-item ,(purecopy "Directories with Ancestor...")
- ediff-merge-directories-with-ancestor
- :help ,(purecopy "Merge files common to a pair of directories by comparing the files with common ancestors")))
- (define-key menu-bar-ediff-merge-menu [ediff-merge-directories]
- `(menu-item ,(purecopy "Directories...") ediff-merge-directories
- :help ,(purecopy "Merge files common to a pair of directories")))
- (define-key
- menu-bar-ediff-merge-menu [separator-ediff-merge-dirs] menu-bar-separator)
- (define-key
- menu-bar-ediff-merge-menu [ediff-merge-buffers-with-ancestor]
- `(menu-item ,(purecopy "Buffers with Ancestor...") ediff-merge-buffers-with-ancestor
- :help ,(purecopy "Merge buffers by comparing their contents with a common ancestor")))
- (define-key menu-bar-ediff-merge-menu [ediff-merge-buffers]
- `(menu-item ,(purecopy "Buffers...") ediff-merge-buffers
- :help ,(purecopy "Merge buffers (without using ancestor information)")))
- (define-key menu-bar-ediff-merge-menu [ediff-merge-files-with-ancestor]
- `(menu-item ,(purecopy "Files with Ancestor...") ediff-merge-files-with-ancestor
- :help ,(purecopy "Merge files by comparing them with a common ancestor")))
- (define-key menu-bar-ediff-merge-menu [ediff-merge-files]
- `(menu-item ,(purecopy "Files...") ediff-merge-files
- :help ,(purecopy "Merge files (without using ancestor information)")))
-
- ;; define epatch menu
- (define-key menu-bar-epatch-menu [ediff-patch-buffer]
- `(menu-item ,(purecopy "To a Buffer...") ediff-patch-buffer
- :help ,(purecopy "Apply a patch to the contents of a buffer")))
- (define-key menu-bar-epatch-menu [ediff-patch-file]
- `(menu-item ,(purecopy "To a File...") ediff-patch-file
- :help ,(purecopy "Apply a patch to a file")))
-
- ;; define ediff miscellanea
- (define-key menu-bar-ediff-misc-menu [emultiframe]
- `(menu-item ,(purecopy "Use separate control buffer frame")
- ediff-toggle-multiframe
- :help ,(purecopy "Switch between the single-frame presentation mode and the multi-frame mode")))
- (define-key menu-bar-ediff-misc-menu [eregistry]
- `(menu-item ,(purecopy "List Ediff Sessions") ediff-show-registry
- :help ,(purecopy "List all active Ediff sessions; it is a convenient way to find and resume such a session")))
- (define-key menu-bar-ediff-misc-menu [ediff-cust]
- `(menu-item ,(purecopy "Customize Ediff") ediff-customize
- :help ,(purecopy "Change some of the parameters that govern the behavior of Ediff")))
- (define-key menu-bar-ediff-misc-menu [ediff-doc]
- `(menu-item ,(purecopy "Ediff Manual") ediff-documentation
- :help ,(purecopy "Bring up the Ediff manual"))))
-
-(provide 'ediff-hook)
-
-
-;; arch-tag: 512f8656-8a4b-4789-af5d-5c6144498df3
-;;; ediff-hook.el ends here
+++ /dev/null
-;;; ediff-init.el --- Macros, variables, and defsubsts used by Ediff
-
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-;; Start compiler pacifier
-(defvar ediff-metajob-name)
-(defvar ediff-meta-buffer)
-(defvar ediff-grab-mouse)
-(defvar ediff-mouse-pixel-position)
-(defvar ediff-mouse-pixel-threshold)
-(defvar ediff-whitespace)
-(defvar ediff-multiframe)
-(defvar ediff-use-toolbar-p)
-(defvar mswindowsx-bitmap-file-path)
-;; end pacifier
-
-(defvar ediff-force-faces nil
- "If t, Ediff will think that it is running on a display that supports faces.
-This is provided as a temporary relief for users of face-capable displays
-that Ediff doesn't know about.")
-
-;; Are we running as a window application or on a TTY?
-(defsubst ediff-device-type ()
- (if (featurep 'xemacs)
- (device-type (selected-device))
- window-system))
-
-;; in XEmacs: device-type is tty on tty and stream in batch.
-(defun ediff-window-display-p ()
- (and (ediff-device-type) (not (memq (ediff-device-type) '(tty pc stream)))))
-
-;; test if supports faces
-(defun ediff-has-face-support-p ()
- (cond ((ediff-window-display-p))
- (ediff-force-faces)
- ((ediff-color-display-p))
- ((featurep 'emacs) (memq (ediff-device-type) '(pc)))
- ((featurep 'xemacs) (memq (ediff-device-type) '(tty pc)))
- ))
-
-;; toolbar support for emacs hasn't been implemented in ediff
-(defun ediff-has-toolbar-support-p ()
- (if (featurep 'xemacs)
- (if (featurep 'toolbar) (console-on-window-system-p))))
-
-
-(defun ediff-has-gutter-support-p ()
- (if (featurep 'xemacs)
- (if (featurep 'gutter) (console-on-window-system-p))))
-
-(defun ediff-use-toolbar-p ()
- (and (ediff-has-toolbar-support-p) ;Can it do it ?
- (boundp 'ediff-use-toolbar-p)
- ediff-use-toolbar-p)) ;Does the user want it ?
-
-;; Defines VAR as an advertised local variable.
-;; Performs a defvar, then executes `make-variable-buffer-local' on
-;; the variable. Also sets the `permanent-local' property,
-;; so that `kill-all-local-variables' (called by major-mode setting
-;; commands) won't destroy Ediff control variables.
-;;
-;; Plagiarised from `emerge-defvar-local' for XEmacs.
-(defmacro ediff-defvar-local (var value doc)
- "Defines VAR as a local variable."
- (declare (indent defun))
- `(progn
- (defvar ,var ,value ,doc)
- (make-variable-buffer-local ',var)
- (put ',var 'permanent-local t)))
-
-
-
-;; Variables that control each Ediff session---local to the control buffer.
-
-;; Mode variables
-;; The buffer in which the A variant is stored.
-(ediff-defvar-local ediff-buffer-A nil "")
-;; The buffer in which the B variant is stored.
-(ediff-defvar-local ediff-buffer-B nil "")
-;; The buffer in which the C variant is stored or where the merge buffer lives.
-(ediff-defvar-local ediff-buffer-C nil "")
-;; Ancestor buffer
-(ediff-defvar-local ediff-ancestor-buffer nil "")
-;; The Ediff control buffer
-(ediff-defvar-local ediff-control-buffer nil "")
-
-(ediff-defvar-local ediff-temp-indirect-buffer nil
- "If t, the buffer is a temporary indirect buffer.
-It needs to be killed when we quit the session.")
-
-
-;; Association between buff-type and ediff-buffer-*
-(defconst ediff-buffer-alist
- '((?A . ediff-buffer-A)
- (?B . ediff-buffer-B)
- (?C . ediff-buffer-C)))
-
-;;; Macros
-(defmacro ediff-odd-p (arg)
- `(eq (logand ,arg 1) 1))
-
-(defmacro ediff-buffer-live-p (buf)
- `(and ,buf (get-buffer ,buf) (buffer-name (get-buffer ,buf))))
-
-(defmacro ediff-get-buffer (arg)
- `(cond ((eq ,arg 'A) ediff-buffer-A)
- ((eq ,arg 'B) ediff-buffer-B)
- ((eq ,arg 'C) ediff-buffer-C)
- ((eq ,arg 'Ancestor) ediff-ancestor-buffer)
- ))
-
-(defmacro ediff-get-value-according-to-buffer-type (buf-type list)
- `(cond ((eq ,buf-type 'A) (nth 0 ,list))
- ((eq ,buf-type 'B) (nth 1 ,list))
- ((eq ,buf-type 'C) (nth 2 ,list))
- ))
-
-(defmacro ediff-char-to-buftype (arg)
- `(cond ((memq ,arg '(?a ?A)) 'A)
- ((memq ,arg '(?b ?B)) 'B)
- ((memq ,arg '(?c ?C)) 'C)
- ))
-
-
-;; A-list is supposed to be of the form (A . symb) (B . symb)...)
-;; where the first part of any association is a buffer type and the second is
-;; an appropriate symbol. Given buffer-type, this function returns the
-;; symbol. This is used to avoid using `intern'
-(defsubst ediff-get-symbol-from-alist (buf-type alist)
- (cdr (assoc buf-type alist)))
-
-(defconst ediff-difference-vector-alist
- '((A . ediff-difference-vector-A)
- (B . ediff-difference-vector-B)
- (C . ediff-difference-vector-C)
- (Ancestor . ediff-difference-vector-Ancestor)))
-
-(defmacro ediff-get-difference (n buf-type)
- `(aref
- (symbol-value
- (ediff-get-symbol-from-alist
- ,buf-type ediff-difference-vector-alist))
- ,n))
-
-;; Tell if it has been previously determined that the region has
-;; no diffs other than the white space and newlines
-;; The argument, N, is the diff region number used by Ediff to index the
-;; diff vector. It is 1 less than the number seen by the user.
-;; Returns:
-;; t if the diffs are whitespace in all buffers
-;; 'A (in 3-buf comparison only) if there are only whitespace
-;; diffs in bufs B and C
-;; 'B (in 3-buf comparison only) if there are only whitespace
-;; diffs in bufs A and C
-;; 'C (in 3-buf comparison only) if there are only whitespace
-;; diffs in bufs A and B
-;;
-;; A Difference Vector has the form:
-;; [diff diff diff ...]
-;; where each diff has the form:
-;; [overlay fine-diff-vector no-fine-diffs-flag state-of-difference]
-;; fine-diff-vector is a vector [fine-diff fine-diff fine-diff ...]
-;; no-fine-diffs-flag says if there are fine differences.
-;; state-of-difference is A, B, C, or nil, indicating which buffer is
-;; different from the other two (used only in 3-way jobs).
-(defmacro ediff-no-fine-diffs-p (n)
- `(aref (ediff-get-difference ,n 'A) 2))
-
-(defmacro ediff-get-diff-overlay-from-diff-record (diff-rec)
- `(aref ,diff-rec 0))
-
-(defmacro ediff-get-diff-overlay (n buf-type)
- `(ediff-get-diff-overlay-from-diff-record
- (ediff-get-difference ,n ,buf-type)))
-
-(defmacro ediff-get-fine-diff-vector-from-diff-record (diff-rec)
- `(aref ,diff-rec 1))
-
-(defmacro ediff-set-fine-diff-vector (n buf-type fine-vec)
- `(aset (ediff-get-difference ,n ,buf-type) 1 ,fine-vec))
-
-(defmacro ediff-get-state-of-diff (n buf-type)
- `(if (ediff-buffer-live-p ediff-buffer-C)
- (aref (ediff-get-difference ,n ,buf-type) 3)))
-(defmacro ediff-set-state-of-diff (n buf-type val)
- `(aset (ediff-get-difference ,n ,buf-type) 3 ,val))
-
-(defmacro ediff-get-state-of-merge (n)
- `(if ediff-state-of-merge
- (aref (aref ediff-state-of-merge ,n) 0)))
-(defmacro ediff-set-state-of-merge (n val)
- `(if ediff-state-of-merge
- (aset (aref ediff-state-of-merge ,n) 0 ,val)))
-
-(defmacro ediff-get-state-of-ancestor (n)
- `(if ediff-state-of-merge
- (aref (aref ediff-state-of-merge ,n) 1)))
-
-;; if flag is t, puts a mark on diff region saying that
-;; the differences are in white space only. If flag is nil,
-;; the region is marked as essential (i.e., differences are
-;; not just in the white space and newlines.)
-(defmacro ediff-mark-diff-as-space-only (n flag)
- `(aset (ediff-get-difference ,n 'A) 2 ,flag))
-
-(defmacro ediff-get-fine-diff-vector (n buf-type)
- `(ediff-get-fine-diff-vector-from-diff-record
- (ediff-get-difference ,n ,buf-type)))
-
-;; Macro to switch to BUFFER, evaluate BODY, returns to original buffer.
-;; Doesn't save the point and mark.
-;; This is `with-current-buffer' with the added test for live buffers."
-(defmacro ediff-with-current-buffer (buffer &rest body)
- "Evaluates BODY in BUFFER."
- (declare (indent 1) (debug (form body)))
- `(if (ediff-buffer-live-p ,buffer)
- (save-current-buffer
- (set-buffer ,buffer)
- ,@body)
- (or (eq this-command 'ediff-quit)
- (error ediff-KILLED-VITAL-BUFFER))
- ))
-
-
-(defsubst ediff-multiframe-setup-p ()
- (and (ediff-window-display-p) ediff-multiframe))
-
-(defmacro ediff-narrow-control-frame-p ()
- `(and (ediff-multiframe-setup-p)
- (equal ediff-help-message ediff-brief-message-string)))
-
-(defmacro ediff-3way-comparison-job ()
- `(memq
- ediff-job-name
- '(ediff-files3 ediff-buffers3)))
-(ediff-defvar-local ediff-3way-comparison-job nil "")
-
-(defmacro ediff-merge-job ()
- `(memq
- ediff-job-name
- '(ediff-merge-files
- ediff-merge-buffers
- ediff-merge-files-with-ancestor
- ediff-merge-buffers-with-ancestor
- ediff-merge-revisions
- ediff-merge-revisions-with-ancestor)))
-(ediff-defvar-local ediff-merge-job nil "")
-
-(defmacro ediff-patch-job ()
- `(eq ediff-job-name 'epatch))
-
-(defmacro ediff-merge-with-ancestor-job ()
- `(memq
- ediff-job-name
- '(ediff-merge-files-with-ancestor
- ediff-merge-buffers-with-ancestor
- ediff-merge-revisions-with-ancestor)))
-(ediff-defvar-local ediff-merge-with-ancestor-job nil "")
-
-(defmacro ediff-3way-job ()
- `(or ediff-3way-comparison-job ediff-merge-job))
-(ediff-defvar-local ediff-3way-job nil "")
-
-;; A diff3 job is like a 3way job, but ediff-merge doesn't require the use
-;; of diff3.
-(defmacro ediff-diff3-job ()
- `(or ediff-3way-comparison-job
- ediff-merge-with-ancestor-job))
-(ediff-defvar-local ediff-diff3-job nil "")
-
-(defmacro ediff-windows-job ()
- `(memq ediff-job-name '(ediff-windows-wordwise ediff-windows-linewise)))
-(ediff-defvar-local ediff-windows-job nil "")
-
-(defmacro ediff-word-mode-job ()
- `(memq ediff-job-name '(ediff-windows-wordwise ediff-regions-wordwise)))
-(ediff-defvar-local ediff-word-mode-job nil "")
-
-(defmacro ediff-narrow-job ()
- `(memq ediff-job-name '(ediff-windows-wordwise
- ediff-regions-wordwise
- ediff-windows-linewise
- ediff-regions-linewise)))
-(ediff-defvar-local ediff-narrow-job nil "")
-
-;; Note: ediff-merge-directory-revisions-with-ancestor is not treated as an
-;; ancestor metajob, since it behaves differently.
-(defsubst ediff-ancestor-metajob (&optional metajob)
- (memq (or metajob ediff-metajob-name)
- '(ediff-merge-directories-with-ancestor
- ediff-merge-filegroups-with-ancestor)))
-(defsubst ediff-revision-metajob (&optional metajob)
- (memq (or metajob ediff-metajob-name)
- '(ediff-directory-revisions
- ediff-merge-directory-revisions
- ediff-merge-directory-revisions-with-ancestor)))
-(defsubst ediff-patch-metajob (&optional metajob)
- (memq (or metajob ediff-metajob-name)
- '(ediff-multifile-patch)))
-;; metajob involving only one group of files, such as multipatch or directory
-;; revision
-(defsubst ediff-one-filegroup-metajob (&optional metajob)
- (or (ediff-revision-metajob metajob)
- (ediff-patch-metajob metajob)
- ;; add more here
- ))
-;; jobs suitable for the operation of collecting diffs into a multifile patch
-(defsubst ediff-collect-diffs-metajob (&optional metajob)
- (memq (or metajob ediff-metajob-name)
- '(ediff-directories
- ediff-merge-directories
- ediff-merge-directories-with-ancestor
- ediff-directory-revisions
- ediff-merge-directory-revisions
- ediff-merge-directory-revisions-with-ancestor
- ;; add more here
- )))
-(defsubst ediff-merge-metajob (&optional metajob)
- (memq (or metajob ediff-metajob-name)
- '(ediff-merge-directories
- ediff-merge-directories-with-ancestor
- ediff-merge-directory-revisions
- ediff-merge-directory-revisions-with-ancestor
- ediff-merge-filegroups-with-ancestor
- ;; add more here
- )))
-
-(defsubst ediff-metajob3 (&optional metajob)
- (memq (or metajob ediff-metajob-name)
- '(ediff-merge-directories-with-ancestor
- ediff-merge-filegroups-with-ancestor
- ediff-directories3
- ediff-filegroups3)))
-(defsubst ediff-comparison-metajob3 (&optional metajob)
- (memq (or metajob ediff-metajob-name)
- '(ediff-directories3 ediff-filegroups3)))
-
-;; with no argument, checks if we are in ediff-control-buffer
-;; with argument, checks if we are in ediff-meta-buffer
-(defun ediff-in-control-buffer-p (&optional meta-buf-p)
- (and (boundp 'ediff-control-buffer)
- (eq (if meta-buf-p ediff-meta-buffer ediff-control-buffer)
- (current-buffer))))
-
-(defsubst ediff-barf-if-not-control-buffer (&optional meta-buf-p)
- (or (ediff-in-control-buffer-p meta-buf-p)
- (error "%S: This command runs in Ediff Control Buffer only!"
- this-command)))
-
-(defgroup ediff-highlighting nil
- "Hilighting of difference regions in Ediff."
- :prefix "ediff-"
- :group 'ediff)
-
-(defgroup ediff-merge nil
- "Merging utilities."
- :prefix "ediff-"
- :group 'ediff)
-
-(defgroup ediff-hook nil
- "Hooks run by Ediff."
- :prefix "ediff-"
- :group 'ediff)
-
-;; Hook variables
-
-(defcustom ediff-before-setup-hook nil
- "Hooks to run before Ediff begins to set up windows and buffers.
-This hook can be used to save the previous window config, which can be restored
-on ediff-quit or ediff-suspend."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-before-setup-windows-hook nil
- "Hooks to run before Ediff sets its window configuration.
-This hook is run every time when Ediff arranges its windows.
-This happens each time Ediff detects that the windows were messed up by the
-user."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-after-setup-windows-hook nil
- "Hooks to run after Ediff sets its window configuration.
-This can be used to set up control window or icon in a desired place."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-before-setup-control-frame-hook nil
- "Hooks run before setting up the frame to display Ediff Control Panel.
-Can be used to change control frame parameters to position it where it
-is desirable."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-after-setup-control-frame-hook nil
- "Hooks run after setting up the frame to display Ediff Control Panel.
-Can be used to move the frame where it is desired."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-startup-hook nil
- "Hooks to run in the control buffer after Ediff has been set up and is ready for the job."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-select-hook nil
- "Hooks to run after a difference has been selected."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-unselect-hook nil
- "Hooks to run after a difference has been unselected."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-prepare-buffer-hook nil
- "Hooks run after buffers A, B, and C are set up.
-For each buffer, the hooks are run with that buffer made current."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-load-hook nil
- "Hook run after Ediff is loaded. Can be used to change defaults."
- :type 'hook
- :group 'ediff-hook)
-
-(defcustom ediff-mode-hook nil
- "Hook run just after ediff-mode is set up in the control buffer.
-This is done before any windows or frames are created. One can use it to
-set local variables that determine how the display looks like."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-keymap-setup-hook nil
- "Hook run just after the default bindings in Ediff keymap are set up."
- :type 'hook
- :group 'ediff-hook)
-
-(defcustom ediff-display-help-hook nil
- "Hooks run after preparing the help message."
- :type 'hook
- :group 'ediff-hook)
-
-(defcustom ediff-suspend-hook nil
- "Hooks to run in the Ediff control buffer when Ediff is suspended."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-quit-hook nil
- "Hooks to run in the Ediff control buffer after finishing Ediff."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-cleanup-hook nil
- "Hooks to run on exiting Ediff but before killing the control and variant buffers."
- :type 'hook
- :group 'ediff-hook)
-
-;; Error messages
-(defconst ediff-KILLED-VITAL-BUFFER
- "You have killed a vital Ediff buffer---you must leave Ediff now!")
-(defconst ediff-NO-DIFFERENCES
- "Sorry, comparison of identical variants is not what I am made for...")
-(defconst ediff-BAD-DIFF-NUMBER
- ;; %S stands for this-command, %d - diff number, %d - max diff
- "%S: Bad diff region number, %d. Valid numbers are 1 to %d")
-(defconst ediff-BAD-INFO (format "
-*** The Info file for Ediff, a part of the standard distribution
-*** of %sEmacs, does not seem to be properly installed.
-***
-*** Please contact your system administrator. "
- (if (featurep 'xemacs) "X" "")))
-
-;; Selective browsing
-
-(ediff-defvar-local ediff-skip-diff-region-function 'ediff-show-all-diffs
- "Function that determines the next/previous diff region to show.
-Should return t for regions to be ignored and nil otherwise.
-This function gets a region number as an argument. The region number
-is the one used internally by Ediff. It is 1 less than the number seen
-by the user.")
-
-(ediff-defvar-local ediff-hide-regexp-matches-function
- 'ediff-hide-regexp-matches
- "Function to use in determining which regions to hide.
-See the documentation string of `ediff-hide-regexp-matches' for details.")
-(ediff-defvar-local ediff-focus-on-regexp-matches-function
- 'ediff-focus-on-regexp-matches
- "Function to use in determining which regions to focus on.
-See the documentation string of `ediff-focus-on-regexp-matches' for details.")
-
-;; Regexp that determines buf A regions to focus on when skipping to diff
-(ediff-defvar-local ediff-regexp-focus-A "" "")
-;; Regexp that determines buf B regions to focus on when skipping to diff
-(ediff-defvar-local ediff-regexp-focus-B "" "")
-;; Regexp that determines buf C regions to focus on when skipping to diff
-(ediff-defvar-local ediff-regexp-focus-C "" "")
-;; connective that determines whether to focus regions that match both or
-;; one of the regexps
-(ediff-defvar-local ediff-focus-regexp-connective 'and "")
-
-;; Regexp that determines buf A regions to ignore when skipping to diff
-(ediff-defvar-local ediff-regexp-hide-A "" "")
-;; Regexp that determines buf B regions to ignore when skipping to diff
-(ediff-defvar-local ediff-regexp-hide-B "" "")
-;; Regexp that determines buf C regions to ignore when skipping to diff
-(ediff-defvar-local ediff-regexp-hide-C "" "")
-;; connective that determines whether to hide regions that match both or
-;; one of the regexps
-(ediff-defvar-local ediff-hide-regexp-connective 'and "")
-
-
-;;; Copying difference regions between buffers.
-
-;; A list of killed diffs.
-;; A diff is saved here if it is replaced by a diff
-;; from another buffer. This alist has the form:
-;; \((num (buff-object . diff) (buff-object . diff) (buff-object . diff)) ...),
-;; where some buffer-objects may be missing.
-(ediff-defvar-local ediff-killed-diffs-alist nil "")
-
-;; Syntax table to use in ediff-forward-word-function
-;; This is chosen by a heuristic. The important thing is for all buffers to
-;; have the same syntax table. Which is not too important.
-(ediff-defvar-local ediff-syntax-table nil "")
-
-
-;; Highlighting
-(defcustom ediff-before-flag-bol (if (featurep 'xemacs) (make-glyph "->>") "->>")
- "Flag placed before a highlighted block of differences, if block starts at beginning of a line."
- :type 'string
- :tag "Region before-flag at beginning of line"
- :group 'ediff)
-
-(defcustom ediff-after-flag-eol (if (featurep 'xemacs) (make-glyph "<<-") "<<-")
- "Flag placed after a highlighted block of differences, if block ends at end of a line."
- :type 'string
- :tag "Region after-flag at end of line"
- :group 'ediff)
-
-(defcustom ediff-before-flag-mol (if (featurep 'xemacs) (make-glyph "->>") "->>")
- "Flag placed before a highlighted block of differences, if block starts in mid-line."
- :type 'string
- :tag "Region before-flag in the middle of line"
- :group 'ediff)
-(defcustom ediff-after-flag-mol (if (featurep 'xemacs) (make-glyph "<<-") "<<-")
- "Flag placed after a highlighted block of differences, if block ends in mid-line."
- :type 'string
- :tag "Region after-flag in the middle of line"
- :group 'ediff)
-
-
-(ediff-defvar-local ediff-use-faces t "")
-(defcustom ediff-use-faces t
- "If t, differences are highlighted using faces, if device supports faces.
-If nil, differences are highlighted using ASCII flags, ediff-before-flag
-and ediff-after-flag. On a non-window system, differences are always
-highlighted using ASCII flags."
- :type 'boolean
- :group 'ediff-highlighting)
-
-;; this indicates that diff regions are word-size, so fine diffs are
-;; permanently nixed; used in ediff-windows-wordwise and ediff-regions-wordwise
-(ediff-defvar-local ediff-word-mode nil "")
-;; Name of the job (ediff-files, ediff-windows, etc.)
-(ediff-defvar-local ediff-job-name nil "")
-
-;; Narrowing and ediff-region/windows support
-;; This is a list (overlay-A overlay-B overlay-C)
-;; If set, Ediff compares only those parts of buffers A/B/C that lie within
-;; the bounds of these overlays.
-(ediff-defvar-local ediff-narrow-bounds nil "")
-
-;; List (overlay-A overlay-B overlay-C), where each overlay spans the
-;; entire corresponding buffer.
-(ediff-defvar-local ediff-wide-bounds nil "")
-
-;; Current visibility boundaries in buffers A, B, and C.
-;; This is also a list of overlays. When the user toggles narrow/widen,
-;; this list changes from ediff-wide-bounds to ediff-narrow-bounds.
-;; and back.
-(ediff-defvar-local ediff-visible-bounds nil "")
-
-(ediff-defvar-local ediff-start-narrowed t
- "Non-nil means start narrowed, if doing ediff-windows-* or ediff-regions-*")
-(ediff-defvar-local ediff-quit-widened t
- "*Non-nil means: when finished, Ediff widens buffers A/B.
-Actually, Ediff restores the scope of visibility that existed at startup.")
-
-(defcustom ediff-keep-variants t
- "nil means prompt to remove unmodified buffers A/B/C at session end.
-Supplying a prefix argument to the quit command `q' temporarily reverses the
-meaning of this variable."
- :type 'boolean
- :group 'ediff)
-
-(ediff-defvar-local ediff-highlight-all-diffs t "")
-(defcustom ediff-highlight-all-diffs t
- "If nil, only the selected differences are highlighted.
-Otherwise, all difference regions are highlighted, but the selected region is
-shown in brighter colors."
- :type 'boolean
- :group 'ediff-highlighting)
-
-
-;; The suffix of the control buffer name.
-(ediff-defvar-local ediff-control-buffer-suffix nil "")
-;; Same as ediff-control-buffer-suffix, but without <,>.
-;; It's a number rather than string.
-(ediff-defvar-local ediff-control-buffer-number nil "")
-
-
-;; The original values of ediff-protected-variables for buffer A
-(ediff-defvar-local ediff-buffer-values-orig-A nil "")
-;; The original values of ediff-protected-variables for buffer B
-(ediff-defvar-local ediff-buffer-values-orig-B nil "")
-;; The original values of ediff-protected-variables for buffer C
-(ediff-defvar-local ediff-buffer-values-orig-C nil "")
-;; The original values of ediff-protected-variables for buffer Ancestor
-(ediff-defvar-local ediff-buffer-values-orig-Ancestor nil "")
-
-;; association between buff-type and ediff-buffer-values-orig-*
-(defconst ediff-buffer-values-orig-alist
- '((A . ediff-buffer-values-orig-A)
- (B . ediff-buffer-values-orig-B)
- (C . ediff-buffer-values-orig-C)
- (Ancestor . ediff-buffer-values-orig-Ancestor)))
-
-;; Buffer-local variables to be saved then restored during Ediff sessions
-(defconst ediff-protected-variables '(
- ;;buffer-read-only
- mode-line-format))
-
-;; Vector of differences between the variants. Each difference is
-;; represented by a vector of two overlays plus a vector of fine diffs,
-;; plus a no-fine-diffs flag. The first overlay spans the
-;; difference region in the A buffer and the second overlays the diff in
-;; the B buffer. If a difference section is empty, the corresponding
-;; overlay's endpoints coincide.
-;;
-;; The precise form of a Difference Vector for one buffer is:
-;; [diff diff diff ...]
-;; where each diff has the form:
-;; [diff-overlay fine-diff-vector no-fine-diffs-flag state-of-diff]
-;; fine-diff-vector is a vector [fine-diff-overlay fine-diff-overlay ...]
-;; no-fine-diffs-flag says if there are fine differences.
-;; state-of-difference is A, B, C, or nil, indicating which buffer is
-;; different from the other two (used only in 3-way jobs.
-(ediff-defvar-local ediff-difference-vector-A nil "")
-(ediff-defvar-local ediff-difference-vector-B nil "")
-(ediff-defvar-local ediff-difference-vector-C nil "")
-(ediff-defvar-local ediff-difference-vector-Ancestor nil "")
-;; A-list of diff vector types associated with buffer types
-(defconst ediff-difference-vector-alist
- '((A . ediff-difference-vector-A)
- (B . ediff-difference-vector-B)
- (C . ediff-difference-vector-C)
- (Ancestor . ediff-difference-vector-Ancestor)))
-
-;; [ status status status ...]
-;; Each status: [state-of-merge state-of-ancestor]
-;; state-of-merge is default-A, default-B, prefer-A, or prefer-B. It
-;; indicates the way a diff region was created in buffer C.
-;; state-of-ancestor says if the corresponding region in ancestor buffer is
-;; empty.
-(ediff-defvar-local ediff-state-of-merge nil "")
-
-;; The difference that is currently selected.
-(ediff-defvar-local ediff-current-difference -1 "")
-;; Number of differences found.
-(ediff-defvar-local ediff-number-of-differences nil "")
-
-;; Buffer containing the output of diff, which is used by Ediff to step
-;; through files.
-(ediff-defvar-local ediff-diff-buffer nil "")
-;; Like ediff-diff-buffer, but contains context diff. It is not used by
-;; Ediff, but it is saved in a file, if user requests so.
-(ediff-defvar-local ediff-custom-diff-buffer nil "")
-;; Buffer used for diff-style fine differences between regions.
-(ediff-defvar-local ediff-fine-diff-buffer nil "")
-;; Temporary buffer used for computing fine differences.
-(defconst ediff-tmp-buffer " *ediff-tmp*" "")
-;; Buffer used for messages
-(defconst ediff-msg-buffer " *ediff-message*" "")
-;; Buffer containing the output of diff when diff returns errors.
-(ediff-defvar-local ediff-error-buffer nil "")
-;; Buffer to display debug info
-(ediff-defvar-local ediff-debug-buffer "*ediff-debug*" "")
-
-;; List of ediff control panels associated with each buffer A/B/C/Ancestor.
-;; Not used any more, but may be needed in the future.
-(ediff-defvar-local ediff-this-buffer-ediff-sessions nil "")
-
-;; to be deleted in due time
-;; List of difference overlays disturbed by working with the current diff.
-(defvar ediff-disturbed-overlays nil "")
-
-;; Priority of non-selected overlays.
-(defvar ediff-shadow-overlay-priority 100 "")
-
-(defcustom ediff-version-control-package 'vc
- "Version control package used.
-Currently, Ediff supports vc.el, rcs.el, pcl-cvs.el, and generic-sc.el. The
-standard Emacs interface to RCS, CVS, SCCS, etc., is vc.el. However, some
-people find the other two packages more convenient. Set this variable to the
-appropriate symbol: `rcs', `pcl-cvs', or `generic-sc' if you so desire."
- :type 'symbol
- :group 'ediff)
-
-(defcustom ediff-coding-system-for-read 'raw-text
- "The coding system for read to use when running the diff program as a subprocess.
-In most cases, the default will do. However, under certain circumstances in
-MS-Windows you might need to use something like 'raw-text-dos here.
-So, if the output that your diff program sends to Emacs contains extra ^M's,
-you might need to experiment here, if the default or 'raw-text-dos doesn't
-work."
- :type 'symbol
- :group 'ediff)
-
-(defcustom ediff-coding-system-for-write (if (featurep 'xemacs)
- 'escape-quoted
- 'emacs-internal)
- "The coding system for write to use when writing out difference regions
-to temp files in buffer jobs and when Ediff needs to find fine differences."
- :type 'symbol
- :group 'ediff)
-
-
-(defalias 'ediff-read-event
- (if (featurep 'xemacs) 'next-command-event 'read-event))
-
-(defalias 'ediff-overlayp
- (if (featurep 'xemacs) 'extentp 'overlayp))
-
-(defalias 'ediff-make-overlay
- (if (featurep 'xemacs) 'make-extent 'make-overlay))
-
-(defalias 'ediff-delete-overlay
- (if (featurep 'xemacs) 'delete-extent 'delete-overlay))
-
-;; Assumes that emacs-major-version and emacs-minor-version are defined.
-(defun ediff-check-version (op major minor &optional type-of-emacs)
- "Check the current version against MAJOR and MINOR version numbers.
-The comparison uses operator OP, which may be any of: =, >, >=, <, <=.
-TYPE-OF-EMACS is either 'xemacs or 'emacs."
- (and (cond ((eq type-of-emacs 'xemacs) (featurep 'xemacs))
- ((eq type-of-emacs 'emacs) (featurep 'emacs))
- (t))
- (cond ((eq op '=) (and (= emacs-minor-version minor)
- (= emacs-major-version major)))
- ((memq op '(> >= < <=))
- (and (or (funcall op emacs-major-version major)
- (= emacs-major-version major))
- (if (= emacs-major-version major)
- (funcall op emacs-minor-version minor)
- t)))
- (t
- (error "%S: Invalid op in ediff-check-version" op)))))
-
-;; ediff-check-version seems to be totally unused anyway.
-(make-obsolete 'ediff-check-version 'version< "23.1")
-
-(defun ediff-color-display-p ()
- (condition-case nil
- (if (featurep 'xemacs)
- (eq (device-class (selected-device)) 'color) ; xemacs form
- (display-color-p)) ; emacs form
- (error nil)))
-
-
-;; A var local to each control panel buffer. Indicates highlighting style
-;; in effect for this buffer: `face', `ascii',
-;; `off' -- turned off \(on a dumb terminal only\).
-(ediff-defvar-local ediff-highlighting-style
- (if (and (ediff-has-face-support-p) ediff-use-faces) 'face 'ascii)
- "")
-
-
-(if (ediff-has-face-support-p)
- (if (featurep 'xemacs)
- (progn
- (defalias 'ediff-valid-color-p 'valid-color-name-p)
- (defalias 'ediff-get-face 'get-face))
- (defalias 'ediff-valid-color-p (if (fboundp 'color-defined-p)
- 'color-defined-p
- 'x-color-defined-p))
- (defalias 'ediff-get-face 'internal-get-face)))
-
-(if (ediff-window-display-p)
- (if (featurep 'xemacs)
- (progn
- (defalias 'ediff-display-pixel-width 'device-pixel-width)
- (defalias 'ediff-display-pixel-height 'device-pixel-height))
- (defalias 'ediff-display-pixel-width
- (if (fboundp 'display-pixel-width)
- 'display-pixel-width
- 'x-display-pixel-width))
- (defalias 'ediff-display-pixel-height
- (if (fboundp 'display-pixel-height)
- 'display-pixel-height
- 'x-display-pixel-height))))
-
-;; A-list of current-diff-overlay symbols associated with buf types
-(defconst ediff-current-diff-overlay-alist
- '((A . ediff-current-diff-overlay-A)
- (B . ediff-current-diff-overlay-B)
- (C . ediff-current-diff-overlay-C)
- (Ancestor . ediff-current-diff-overlay-Ancestor)))
-
-;; A-list of current-diff-face-* symbols associated with buf types
-(defconst ediff-current-diff-face-alist
- '((A . ediff-current-diff-A)
- (B . ediff-current-diff-B)
- (C . ediff-current-diff-C)
- (Ancestor . ediff-current-diff-Ancestor)))
-
-
-(defun ediff-set-overlay-face (extent face)
- (ediff-overlay-put extent 'face face)
- (ediff-overlay-put extent 'help-echo 'ediff-region-help-echo))
-
-(defun ediff-region-help-echo (extent-or-window &optional overlay point)
- (unless overlay
- (setq overlay extent-or-window))
- (let ((is-current (ediff-overlay-get overlay 'ediff))
- (face (ediff-overlay-get overlay 'face))
- (diff-num (ediff-overlay-get overlay 'ediff-diff-num))
- face-help)
-
- ;; This happens only for refinement overlays
- (if (stringp face)
- (setq face (intern face)))
- (setq face-help (and face (get face 'ediff-help-echo)))
-
- (cond ((and is-current diff-num) ; current diff region
- (format "Difference region %S -- current" (1+ diff-num)))
- (face-help) ; refinement of current diff region
- (diff-num ; non-current
- (format "Difference region %S -- non-current" (1+ diff-num)))
- (t "")) ; none
- ))
-
-
-(defun ediff-set-face-pixmap (face pixmap)
- "Set face pixmap on a monochrome display."
- (if (and (ediff-window-display-p) (not (ediff-color-display-p)))
- (condition-case nil
- (set-face-background-pixmap face pixmap)
- (error
- (message "Pixmap not found for %S: %s" (face-name face) pixmap)
- (sit-for 1)))))
-
-(defun ediff-hide-face (face)
- (if (and (ediff-has-face-support-p)
- (boundp 'add-to-list)
- (boundp 'facemenu-unlisted-faces))
- (add-to-list 'facemenu-unlisted-faces face)))
-
-
-
-(defface ediff-current-diff-A
- (if (featurep 'emacs)
- '((((class color) (min-colors 16))
- (:foreground "firebrick" :background "pale green"))
- (((class color))
- (:foreground "blue3" :background "yellow3"))
- (t (:inverse-video t)))
- '((((type tty)) (:foreground "blue3" :background "yellow3"))
- (((class color)) (:foreground "firebrick" :background "pale green"))
- (t (:inverse-video t))))
- "Face for highlighting the selected difference in buffer A."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-current-diff-face-A 'ediff-current-diff-A
- "Face for highlighting the selected difference in buffer A.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-current-diff-A'
-this variable represents.")
-(ediff-hide-face ediff-current-diff-face-A)
-;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
-;; This means that some user customization may be trashed.
-(and (featurep 'xemacs)
- (ediff-has-face-support-p)
- (not (ediff-color-display-p))
- (copy-face 'modeline ediff-current-diff-face-A))
-
-
-
-(defface ediff-current-diff-B
- (if (featurep 'emacs)
- '((((class color) (min-colors 16))
- (:foreground "DarkOrchid" :background "Yellow"))
- (((class color))
- (:foreground "magenta3" :background "yellow3"
- :weight bold))
- (t (:inverse-video t)))
- '((((type tty)) (:foreground "magenta3" :background "yellow3"
- :weight bold))
- (((class color)) (:foreground "DarkOrchid" :background "Yellow"))
- (t (:inverse-video t))))
- "Face for highlighting the selected difference in buffer B."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-current-diff-face-B 'ediff-current-diff-B
- "Face for highlighting the selected difference in buffer B.
- this variable. Instead, use the customization
-widget to customize the actual face `ediff-current-diff-B'
-this variable represents.")
-(ediff-hide-face ediff-current-diff-face-B)
-;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
-;; This means that some user customization may be trashed.
-(and (featurep 'xemacs)
- (ediff-has-face-support-p)
- (not (ediff-color-display-p))
- (copy-face 'modeline ediff-current-diff-face-B))
-
-
-(defface ediff-current-diff-C
- (if (featurep 'emacs)
- '((((class color) (min-colors 16))
- (:foreground "Navy" :background "Pink"))
- (((class color))
- (:foreground "cyan3" :background "yellow3" :weight bold))
- (t (:inverse-video t)))
- '((((type tty)) (:foreground "cyan3" :background "yellow3" :weight bold))
- (((class color)) (:foreground "Navy" :background "Pink"))
- (t (:inverse-video t))))
- "Face for highlighting the selected difference in buffer C."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-current-diff-face-C 'ediff-current-diff-C
- "Face for highlighting the selected difference in buffer C.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-current-diff-C'
-this variable represents.")
-(ediff-hide-face ediff-current-diff-face-C)
-;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
-;; This means that some user customization may be trashed.
-(and (featurep 'xemacs)
- (ediff-has-face-support-p)
- (not (ediff-color-display-p))
- (copy-face 'modeline ediff-current-diff-face-C))
-
-
-(defface ediff-current-diff-Ancestor
- (if (featurep 'emacs)
- '((((class color) (min-colors 16))
- (:foreground "Black" :background "VioletRed"))
- (((class color))
- (:foreground "black" :background "magenta3"))
- (t (:inverse-video t)))
- '((((type tty)) (:foreground "black" :background "magenta3"))
- (((class color)) (:foreground "Black" :background "VioletRed"))
- (t (:inverse-video t))))
- "Face for highlighting the selected difference in buffer Ancestor."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-current-diff-face-Ancestor 'ediff-current-diff-Ancestor
- "Face for highlighting the selected difference in buffer Ancestor.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-current-diff-Ancestor'
-this variable represents.")
-(ediff-hide-face ediff-current-diff-face-Ancestor)
-;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
-;; This means that some user customization may be trashed.
-(and (featurep 'xemacs)
- (ediff-has-face-support-p)
- (not (ediff-color-display-p))
- (copy-face 'modeline ediff-current-diff-face-Ancestor))
-
-
-(defface ediff-fine-diff-A
- (if (featurep 'emacs)
- '((((class color) (min-colors 16))
- (:foreground "Navy" :background "sky blue"))
- (((class color))
- (:foreground "white" :background "sky blue" :weight bold))
- (t (:underline t :stipple "gray3")))
- '((((type tty)) (:foreground "white" :background "sky blue" :weight bold))
- (((class color)) (:foreground "Navy" :background "sky blue"))
- (t (:underline t :stipple "gray3"))))
- "Face for highlighting the refinement of the selected diff in buffer A."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-fine-diff-face-A 'ediff-fine-diff-A
- "Face for highlighting the fine differences in buffer A.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-fine-diff-A'
-this variable represents.")
-(ediff-hide-face ediff-fine-diff-face-A)
-
-(defface ediff-fine-diff-B
- (if (featurep 'emacs)
- '((((class color) (min-colors 16))
- (:foreground "Black" :background "cyan"))
- (((class color))
- (:foreground "magenta3" :background "cyan3"))
- (t (:underline t :stipple "gray3")))
- '((((type tty)) (:foreground "magenta3" :background "cyan3"))
- (((class color)) (:foreground "Black" :background "cyan"))
- (t (:underline t :stipple "gray3"))))
- "Face for highlighting the refinement of the selected diff in buffer B."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-fine-diff-face-B 'ediff-fine-diff-B
- "Face for highlighting the fine differences in buffer B.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-fine-diff-B'
-this variable represents.")
-(ediff-hide-face ediff-fine-diff-face-B)
-
-(defface ediff-fine-diff-C
- (if (featurep 'emacs)
- '((((type pc))
- (:foreground "white" :background "Turquoise"))
- (((class color) (min-colors 16))
- (:foreground "Black" :background "Turquoise"))
- (((class color))
- (:foreground "yellow3" :background "Turquoise"
- :weight bold))
- (t (:underline t :stipple "gray3")))
- '((((type tty)) (:foreground "yellow3" :background "Turquoise"
- :weight bold))
- (((type pc)) (:foreground "white" :background "Turquoise"))
- (((class color)) (:foreground "Black" :background "Turquoise"))
- (t (:underline t :stipple "gray3"))))
- "Face for highlighting the refinement of the selected diff in buffer C."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-fine-diff-face-C 'ediff-fine-diff-C
- "Face for highlighting the fine differences in buffer C.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-fine-diff-C'
-this variable represents.")
-(ediff-hide-face ediff-fine-diff-face-C)
-
-(defface ediff-fine-diff-Ancestor
- (if (featurep 'emacs)
- '((((class color) (min-colors 16))
- (:foreground "Black" :background "Green"))
- (((class color))
- (:foreground "red3" :background "green"))
- (t (:underline t :stipple "gray3")))
- '((((type tty)) (:foreground "red3" :background "green"))
- (((class color)) (:foreground "Black" :background "Green"))
- (t (:underline t :stipple "gray3"))))
- "Face for highlighting the refinement of the selected diff in the ancestor buffer.
-At present, this face is not used and no fine differences are computed for the
-ancestor buffer."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-fine-diff-face-Ancestor 'ediff-fine-diff-Ancestor
- "Face for highlighting the fine differences in buffer Ancestor.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-fine-diff-Ancestor'
-this variable represents.")
-(ediff-hide-face ediff-fine-diff-face-Ancestor)
-
-;; Some installs don't have stipple or Stipple. So, try them in turn.
-(defvar stipple-pixmap
- (cond ((not (ediff-has-face-support-p)) nil)
- ((and (boundp 'x-bitmap-file-path)
- (locate-library "stipple" t x-bitmap-file-path)) "stipple")
- ((and (boundp 'mswindowsx-bitmap-file-path)
- (locate-library "stipple" t mswindowsx-bitmap-file-path)) "stipple")
- (t "Stipple")))
-
-(defface ediff-even-diff-A
- (if (featurep 'emacs)
- `((((type pc))
- (:foreground "green3" :background "light grey"))
- (((class color) (min-colors 16))
- (:foreground "Black" :background "light grey"))
- (((class color))
- (:foreground "red3" :background "light grey"
- :weight bold))
- (t (:italic t :stipple ,stipple-pixmap)))
- `((((type tty)) (:foreground "red3" :background "light grey"
- :weight bold))
- (((type pc)) (:foreground "green3" :background "light grey"))
- (((class color)) (:foreground "Black" :background "light grey"))
- (t (:italic t :stipple ,stipple-pixmap))))
- "Face for highlighting even-numbered non-current differences in buffer A."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-even-diff-face-A 'ediff-even-diff-A
- "Face for highlighting even-numbered non-current differences in buffer A.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-even-diff-A'
-this variable represents.")
-(ediff-hide-face ediff-even-diff-face-A)
-
-(defface ediff-even-diff-B
- (if (featurep 'emacs)
- `((((class color) (min-colors 16))
- (:foreground "White" :background "Grey"))
- (((class color))
- (:foreground "blue3" :background "Grey" :weight bold))
- (t (:italic t :stipple ,stipple-pixmap)))
- `((((type tty)) (:foreground "blue3" :background "Grey" :weight bold))
- (((class color)) (:foreground "White" :background "Grey"))
- (t (:italic t :stipple ,stipple-pixmap))))
- "Face for highlighting even-numbered non-current differences in buffer B."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-even-diff-face-B 'ediff-even-diff-B
- "Face for highlighting even-numbered non-current differences in buffer B.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-even-diff-B'
-this variable represents.")
-(ediff-hide-face ediff-even-diff-face-B)
-
-(defface ediff-even-diff-C
- (if (featurep 'emacs)
- `((((type pc))
- (:foreground "yellow3" :background "light grey"))
- (((class color) (min-colors 16))
- (:foreground "Black" :background "light grey"))
- (((class color))
- (:foreground "yellow3" :background "light grey"
- :weight bold))
- (t (:italic t :stipple ,stipple-pixmap)))
- `((((type tty)) (:foreground "yellow3" :background "light grey"
- :weight bold))
- (((type pc)) (:foreground "yellow3" :background "light grey"))
- (((class color)) (:foreground "Black" :background "light grey"))
- (t (:italic t :stipple ,stipple-pixmap))))
- "Face for highlighting even-numbered non-current differences in buffer C."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-even-diff-face-C 'ediff-even-diff-C
- "Face for highlighting even-numbered non-current differences in buffer C.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-even-diff-C'
-this variable represents.")
-(ediff-hide-face ediff-even-diff-face-C)
-
-(defface ediff-even-diff-Ancestor
- (if (featurep 'emacs)
- `((((type pc))
- (:foreground "cyan3" :background "light grey"))
- (((class color) (min-colors 16))
- (:foreground "White" :background "Grey"))
- (((class color))
- (:foreground "cyan3" :background "light grey"
- :weight bold))
- (t (:italic t :stipple ,stipple-pixmap)))
- `((((type tty)) (:foreground "cyan3" :background "light grey"
- :weight bold))
- (((type pc)) (:foreground "cyan3" :background "light grey"))
- (((class color)) (:foreground "White" :background "Grey"))
- (t (:italic t :stipple ,stipple-pixmap))))
- "Face for highlighting even-numbered non-current differences in the ancestor buffer."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-even-diff-face-Ancestor 'ediff-even-diff-Ancestor
- "Face for highlighting even-numbered non-current differences in buffer Ancestor.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-even-diff-Ancestor'
-this variable represents.")
-(ediff-hide-face ediff-even-diff-face-Ancestor)
-
-;; Association between buffer types and even-diff-face symbols
-(defconst ediff-even-diff-face-alist
- '((A . ediff-even-diff-A)
- (B . ediff-even-diff-B)
- (C . ediff-even-diff-C)
- (Ancestor . ediff-even-diff-Ancestor)))
-
-(defface ediff-odd-diff-A
- (if (featurep 'emacs)
- '((((type pc))
- (:foreground "green3" :background "gray40"))
- (((class color) (min-colors 16))
- (:foreground "White" :background "Grey"))
- (((class color))
- (:foreground "red3" :background "black" :weight bold))
- (t (:italic t :stipple "gray1")))
- '((((type tty)) (:foreground "red3" :background "black" :weight bold))
- (((type pc)) (:foreground "green3" :background "gray40"))
- (((class color)) (:foreground "White" :background "Grey"))
- (t (:italic t :stipple "gray1"))))
- "Face for highlighting odd-numbered non-current differences in buffer A."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-odd-diff-face-A 'ediff-odd-diff-A
- "Face for highlighting odd-numbered non-current differences in buffer A.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-odd-diff-A'
-this variable represents.")
-(ediff-hide-face ediff-odd-diff-face-A)
-
-
-(defface ediff-odd-diff-B
- (if (featurep 'emacs)
- '((((type pc))
- (:foreground "White" :background "gray40"))
- (((class color) (min-colors 16))
- (:foreground "Black" :background "light grey"))
- (((class color))
- (:foreground "cyan3" :background "black" :weight bold))
- (t (:italic t :stipple "gray1")))
- '((((type tty)) (:foreground "cyan3" :background "black" :weight bold))
- (((type pc)) (:foreground "White" :background "gray40"))
- (((class color)) (:foreground "Black" :background "light grey"))
- (t (:italic t :stipple "gray1"))))
- "Face for highlighting odd-numbered non-current differences in buffer B."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-odd-diff-face-B 'ediff-odd-diff-B
- "Face for highlighting odd-numbered non-current differences in buffer B.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-odd-diff-B'
-this variable represents.")
-(ediff-hide-face ediff-odd-diff-face-B)
-
-(defface ediff-odd-diff-C
- (if (featurep 'emacs)
- '((((type pc))
- (:foreground "yellow3" :background "gray40"))
- (((class color) (min-colors 16))
- (:foreground "White" :background "Grey"))
- (((class color))
- (:foreground "yellow3" :background "black" :weight bold))
- (t (:italic t :stipple "gray1")))
- '((((type tty)) (:foreground "yellow3" :background "black" :weight bold))
- (((type pc)) (:foreground "yellow3" :background "gray40"))
- (((class color)) (:foreground "White" :background "Grey"))
- (t (:italic t :stipple "gray1"))))
- "Face for highlighting odd-numbered non-current differences in buffer C."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-odd-diff-face-C 'ediff-odd-diff-C
- "Face for highlighting odd-numbered non-current differences in buffer C.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-odd-diff-C'
-this variable represents.")
-(ediff-hide-face ediff-odd-diff-face-C)
-
-(defface ediff-odd-diff-Ancestor
- (if (featurep 'emacs)
- '((((class color) (min-colors 16))
- (:foreground "cyan3" :background "gray40"))
- (((class color))
- (:foreground "green3" :background "black" :weight bold))
- (t (:italic t :stipple "gray1")))
- '((((type tty)) (:foreground "green3" :background "black" :weight bold))
- (((class color)) (:foreground "cyan3" :background "gray40"))
- (t (:italic t :stipple "gray1"))))
- "Face for highlighting odd-numbered non-current differences in the ancestor buffer."
- :group 'ediff-highlighting)
-;; An internal variable. Ediff takes the face from here. When unhighlighting,
-;; this variable is set to nil, then again to the appropriate face.
-(defvar ediff-odd-diff-face-Ancestor 'ediff-odd-diff-Ancestor
- "Face for highlighting odd-numbered non-current differences in buffer Ancestor.
-DO NOT CHANGE this variable. Instead, use the customization
-widget to customize the actual face object `ediff-odd-diff-Ancestor'
-this variable represents.")
-(ediff-hide-face ediff-odd-diff-face-Ancestor)
-
-;; Association between buffer types and odd-diff-face symbols
-(defconst ediff-odd-diff-face-alist
- '((A . ediff-odd-diff-A)
- (B . ediff-odd-diff-B)
- (C . ediff-odd-diff-C)
- (Ancestor . ediff-odd-diff-Ancestor)))
-
-;; A-list of fine-diff face symbols associated with buffer types
-(defconst ediff-fine-diff-face-alist
- '((A . ediff-fine-diff-A)
- (B . ediff-fine-diff-B)
- (C . ediff-fine-diff-C)
- (Ancestor . ediff-fine-diff-Ancestor)))
-
-;; Help echo
-(put ediff-fine-diff-face-A 'ediff-help-echo
- "A `refinement' of the current difference region")
-(put ediff-fine-diff-face-B 'ediff-help-echo
- "A `refinement' of the current difference region")
-(put ediff-fine-diff-face-C 'ediff-help-echo
- "A `refinement' of the current difference region")
-(put ediff-fine-diff-face-Ancestor 'ediff-help-echo
- "A `refinement' of the current difference region")
-
-(add-hook 'ediff-quit-hook 'ediff-cleanup-mess)
-(add-hook 'ediff-suspend-hook 'ediff-default-suspend-function)
-
-
-;;; Overlays
-
-(ediff-defvar-local ediff-current-diff-overlay-A nil
- "Overlay for the current difference region in buffer A.")
-(ediff-defvar-local ediff-current-diff-overlay-B nil
- "Overlay for the current difference region in buffer B.")
-(ediff-defvar-local ediff-current-diff-overlay-C nil
- "Overlay for the current difference region in buffer C.")
-(ediff-defvar-local ediff-current-diff-overlay-Ancestor nil
- "Overlay for the current difference region in the ancestor buffer.")
-
-;; Compute priority of a current ediff overlay.
-(defun ediff-highest-priority (start end buffer)
- (let ((pos (max 1 (1- start)))
- ovr-list)
- (if (featurep 'xemacs)
- (1+ ediff-shadow-overlay-priority)
- (ediff-with-current-buffer buffer
- (while (< pos (min (point-max) (1+ end)))
- (setq ovr-list (append (overlays-at pos) ovr-list))
- (setq pos (next-overlay-change pos)))
- (+ 1 ediff-shadow-overlay-priority
- (apply 'max
- (cons
- 1
- (mapcar
- (lambda (ovr)
- (if (and ovr
- ;; exclude ediff overlays from priority
- ;; calculation, or else priority will keep
- ;; increasing
- (null (ediff-overlay-get ovr 'ediff))
- (null (ediff-overlay-get ovr 'ediff-diff-num)))
- ;; use the overlay priority or 0
- (or (ediff-overlay-get ovr 'priority) 0)
- 0))
- ovr-list))))))))
-
-
-(defvar ediff-toggle-read-only-function nil
- "*Specifies the function to be used to toggle read-only.
-If nil, Ediff tries to deduce the function from the binding of C-x C-q.
-Normally, this is the `toggle-read-only' function, but, if version
-control is used, it could be `vc-toggle-read-only' or `rcs-toggle-read-only'.")
-
-(defcustom ediff-make-buffers-readonly-at-startup nil
- "Make all variant buffers read-only when Ediff starts up.
-This property can be toggled interactively."
- :type 'boolean
- :group 'ediff)
-
-
-;;; Misc
-
-;; if nil, this silences some messages
-(defvar ediff-verbose-p t)
-
-(defcustom ediff-autostore-merges 'group-jobs-only
- "Save the results of merge jobs automatically.
-With value nil, don't save automatically. With value t, always
-save. Anything else means save automatically only if the merge
-job is part of a group of jobs, such as `ediff-merge-directory'
-or `ediff-merge-directory-revisions'."
- :type '(choice (const nil) (const t) (const group-jobs-only))
- :group 'ediff-merge)
-(make-variable-buffer-local 'ediff-autostore-merges)
-
-;; file where the result of the merge is to be saved. used internally
-(ediff-defvar-local ediff-merge-store-file nil "")
-
-(defcustom ediff-merge-filename-prefix "merge_"
- "Prefix to be attached to saved merge buffers."
- :type 'string
- :group 'ediff-merge)
-
-(defcustom ediff-no-emacs-help-in-control-buffer nil
- "Non-nil means C-h should not invoke Emacs help in control buffer.
-Instead, C-h would jump to previous difference."
- :type 'boolean
- :group 'ediff)
-
-;; This is the same as temporary-file-directory from Emacs 20.3.
-;; Copied over here because XEmacs doesn't have this variable.
-(defcustom ediff-temp-file-prefix
- (file-name-as-directory
- (cond ((boundp 'temporary-file-directory) temporary-file-directory)
- ((fboundp 'temp-directory) (temp-directory))
- (t "/tmp/")))
-;;; (file-name-as-directory
-;;; (cond ((memq system-type '(ms-dos windows-nt))
-;;; (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp"))
-;;; (t
-;;; (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
- "Prefix to put on Ediff temporary file names.
-Do not start with `~/' or `~USERNAME/'."
- :type 'string
- :group 'ediff)
-
-(defcustom ediff-temp-file-mode 384 ; u=rw only
- "Mode for Ediff temporary files."
- :type 'integer
- :group 'ediff)
-
-;; Metacharacters that have to be protected from the shell when executing
-;; a diff/diff3 command.
-(defcustom ediff-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]"
- "Regexp that matches characters that must be quoted with `\\' in shell command line.
-This default should work without changes."
- :type 'string
- :group 'ediff)
-
-;; needed to simulate frame-char-width in XEmacs.
-(defvar ediff-H-glyph (if (featurep 'xemacs) (make-glyph "H")))
-
-
-;; Temporary file used for refining difference regions in buffer A.
-(ediff-defvar-local ediff-temp-file-A nil "")
-;; Temporary file used for refining difference regions in buffer B.
-(ediff-defvar-local ediff-temp-file-B nil "")
-;; Temporary file used for refining difference regions in buffer C.
-(ediff-defvar-local ediff-temp-file-C nil "")
-
-
-(defun ediff-file-remote-p (file-name)
- (file-remote-p file-name))
-
-;; File for which we can get attributes, such as size or date
-(defun ediff-listable-file (file-name)
- (let ((handler (find-file-name-handler file-name 'file-local-copy)))
- (or (null handler) (eq handler 'dired-handler-fn))))
-
-
-(defsubst ediff-frame-unsplittable-p (frame)
- (cdr (assq 'unsplittable (frame-parameters frame))))
-
-(defsubst ediff-get-next-window (wind prev-wind)
- (cond ((window-live-p wind) wind)
- (prev-wind (next-window wind))
- (t (selected-window))
- ))
-
-
-(defsubst ediff-kill-buffer-carefully (buf)
- "Kill buffer BUF if it exists."
- (if (ediff-buffer-live-p buf)
- (kill-buffer (get-buffer buf))))
-
-(defsubst ediff-background-face (buf-type dif-num)
- ;; The value of dif-num is always 1- the one that user sees.
- ;; This is why even face is used when dif-num is odd.
- (ediff-get-symbol-from-alist
- buf-type (if (ediff-odd-p dif-num)
- ediff-even-diff-face-alist
- ediff-odd-diff-face-alist)
- ))
-
-
-;; activate faces on diff regions in buffer
-(defun ediff-paint-background-regions-in-one-buffer (buf-type unhighlight)
- (let ((diff-vector
- (eval (ediff-get-symbol-from-alist
- buf-type ediff-difference-vector-alist)))
- overl diff-num)
- (mapcar (lambda (rec)
- (setq overl (ediff-get-diff-overlay-from-diff-record rec)
- diff-num (ediff-overlay-get overl 'ediff-diff-num))
- (if (ediff-overlay-buffer overl)
- ;; only if overlay is alive
- (ediff-set-overlay-face
- overl
- (if (not unhighlight)
- (ediff-background-face buf-type diff-num))))
- )
- diff-vector)))
-
-
-;; activate faces on diff regions in all buffers
-(defun ediff-paint-background-regions (&optional unhighlight)
- (ediff-paint-background-regions-in-one-buffer
- 'A unhighlight)
- (ediff-paint-background-regions-in-one-buffer
- 'B unhighlight)
- (ediff-paint-background-regions-in-one-buffer
- 'C unhighlight)
- (ediff-paint-background-regions-in-one-buffer
- 'Ancestor unhighlight))
-
-
-;; arg is a record for a given diff in a difference vector
-;; this record is itself a vector
-(defsubst ediff-clear-fine-diff-vector (diff-record)
- (if diff-record
- (mapc 'ediff-delete-overlay
- (ediff-get-fine-diff-vector-from-diff-record diff-record))))
-
-(defsubst ediff-clear-fine-differences-in-one-buffer (n buf-type)
- (ediff-clear-fine-diff-vector (ediff-get-difference n buf-type))
- (ediff-set-fine-diff-vector n buf-type nil))
-
-(defsubst ediff-clear-fine-differences (n)
- (ediff-clear-fine-differences-in-one-buffer n 'A)
- (ediff-clear-fine-differences-in-one-buffer n 'B)
- (if ediff-3way-job
- (ediff-clear-fine-differences-in-one-buffer n 'C)))
-
-
-(defsubst ediff-mouse-event-p (event)
- (if (featurep 'xemacs)
- (button-event-p event)
- (string-match "mouse" (format "%S" (event-basic-type event)))))
-
-
-(defsubst ediff-key-press-event-p (event)
- (if (featurep 'xemacs)
- (key-press-event-p event)
- (or (char-or-string-p event) (symbolp event))))
-
-(defun ediff-event-point (event)
- (cond ((ediff-mouse-event-p event)
- (if (featurep 'xemacs)
- (event-point event)
- (posn-point (event-start event))))
- ((ediff-key-press-event-p event)
- (point))
- (t (error "Error"))))
-
-(defun ediff-event-buffer (event)
- (cond ((ediff-mouse-event-p event)
- (if (featurep 'xemacs)
- (event-buffer event)
- (window-buffer (posn-window (event-start event)))))
- ((ediff-key-press-event-p event)
- (current-buffer))
- (t (error "Error"))))
-
-(defun ediff-event-key (event-or-key)
- (if (featurep 'xemacs)
- ;;(if (eventp event-or-key) (event-key event-or-key) event-or-key)
- (if (eventp event-or-key) (event-to-character event-or-key t t) event-or-key)
- event-or-key))
-
-(defun ediff-last-command-char ()
- (ediff-event-key last-command-event))
-
-
-(defsubst ediff-frame-iconified-p (frame)
- (and (ediff-window-display-p) (frame-live-p frame)
- (if (featurep 'xemacs)
- (frame-iconified-p frame)
- (eq (frame-visible-p frame) 'icon))))
-
-(defsubst ediff-window-visible-p (wind)
- ;; under TTY, window-live-p also means window is visible
- (and (window-live-p wind)
- (or (not (ediff-window-display-p))
- (frame-visible-p (window-frame wind)))))
-
-
-(defsubst ediff-frame-char-width (frame)
- (if (featurep 'xemacs)
- (/ (frame-pixel-width frame) (frame-width frame))
- (frame-char-width frame)))
-
-(defun ediff-reset-mouse (&optional frame do-not-grab-mouse)
- (or frame (setq frame (selected-frame)))
- (if (ediff-window-display-p)
- (let ((frame-or-wind frame))
- (if (featurep 'xemacs)
- (setq frame-or-wind (frame-selected-window frame)))
- (or do-not-grab-mouse
- ;; don't set mouse if the user said to never do this
- (not ediff-grab-mouse)
- ;; Don't grab on quit, if the user doesn't want to.
- ;; If ediff-grab-mouse = t, then mouse won't be grabbed for
- ;; sessions that are not part of a group (this is done in
- ;; ediff-recenter). The condition below affects only terminating
- ;; sessions in session groups (in which case mouse is warped into
- ;; a meta buffer).
- (and (eq ediff-grab-mouse 'maybe)
- (memq this-command '(ediff-quit ediff-update-diffs)))
- (set-mouse-position frame-or-wind 1 0))
- )))
-
-(defsubst ediff-spy-after-mouse ()
- (setq ediff-mouse-pixel-position (mouse-pixel-position)))
-
-;; It is not easy to find out when the user grabs the mouse, since emacs and
-;; xemacs behave differently when mouse is not in any frame. Also, this is
-;; sensitive to when the user grabbed mouse. Not used for now.
-(defun ediff-user-grabbed-mouse ()
- (if ediff-mouse-pixel-position
- (cond ((not (eq (car ediff-mouse-pixel-position)
- (car (mouse-pixel-position)))))
- ((and (car (cdr ediff-mouse-pixel-position))
- (car (cdr (mouse-pixel-position)))
- (cdr (cdr ediff-mouse-pixel-position))
- (cdr (cdr (mouse-pixel-position))))
- (not (and (< (abs (- (car (cdr ediff-mouse-pixel-position))
- (car (cdr (mouse-pixel-position)))))
- ediff-mouse-pixel-threshold)
- (< (abs (- (cdr (cdr ediff-mouse-pixel-position))
- (cdr (cdr (mouse-pixel-position)))))
- ediff-mouse-pixel-threshold))))
- (t nil))))
-
-(defsubst ediff-frame-char-height (frame)
- (if (featurep 'xemacs)
- (glyph-height ediff-H-glyph (frame-selected-window frame))
- (frame-char-height frame)))
-
-;; Some overlay functions
-
-(defsubst ediff-overlay-start (overl)
- (if (ediff-overlayp overl)
- (if (featurep 'xemacs)
- (extent-start-position overl)
- (overlay-start overl))))
-
-(defsubst ediff-overlay-end (overl)
- (if (ediff-overlayp overl)
- (if (featurep 'xemacs)
- (extent-end-position overl)
- (overlay-end overl))))
-
-(defsubst ediff-empty-overlay-p (overl)
- (= (ediff-overlay-start overl) (ediff-overlay-end overl)))
-
-;; like overlay-buffer in Emacs. In XEmacs, returns nil if the extent is
-;; dead. Otherwise, works like extent-buffer
-(defun ediff-overlay-buffer (overl)
- (if (featurep 'xemacs)
- (and (extent-live-p overl) (extent-object overl))
- (overlay-buffer overl)))
-
-;; like overlay-get in Emacs. In XEmacs, returns nil if the extent is
-;; dead. Otherwise, like extent-property
-(defun ediff-overlay-get (overl property)
- (if (featurep 'xemacs)
- (and (extent-live-p overl) (extent-property overl property))
- (overlay-get overl property)))
-
-
-;; These two functions are here because XEmacs refuses to
-;; handle overlays whose buffers were deleted.
-(defun ediff-move-overlay (overlay beg end &optional buffer)
- "Calls `move-overlay' in Emacs and `set-extent-endpoints' in Lemacs.
-Checks if overlay's buffer exists before actually doing the move."
- (let ((buf (and overlay (ediff-overlay-buffer overlay))))
- (if (ediff-buffer-live-p buf)
- (if (featurep 'xemacs)
- (set-extent-endpoints overlay beg end)
- (move-overlay overlay beg end buffer))
- ;; buffer's dead
- (if overlay
- (ediff-delete-overlay overlay)))))
-
-(defun ediff-overlay-put (overlay prop value)
- "Calls `overlay-put' or `set-extent-property' depending on Emacs version.
-Checks if overlay's buffer exists."
- (if (ediff-buffer-live-p (ediff-overlay-buffer overlay))
- (if (featurep 'xemacs)
- (set-extent-property overlay prop value)
- (overlay-put overlay prop value))
- (ediff-delete-overlay overlay)))
-
-;; temporarily uses DIR to abbreviate file name
-;; if DIR is nil, use default-directory
-(defun ediff-abbreviate-file-name (file &optional dir)
- (cond ((stringp dir)
- (let ((directory-abbrev-alist (list (cons dir ""))))
- (abbreviate-file-name file)))
- (t
- (if (featurep 'xemacs)
- ;; XEmacs requires addl argument
- (abbreviate-file-name file t)
- (abbreviate-file-name file)))))
-
-;; Takes a directory and returns the parent directory.
-;; does nothing to `/'. If the ARG is a regular file,
-;; strip the file AND the last dir.
-(defun ediff-strip-last-dir (dir)
- (if (not (stringp dir)) (setq dir default-directory))
- (setq dir (expand-file-name dir))
- (or (file-directory-p dir) (setq dir (file-name-directory dir)))
- (let* ((pos (1- (length dir)))
- (last-char (aref dir pos)))
- (if (and (> pos 0) (= last-char ?/))
- (setq dir (substring dir 0 pos)))
- (ediff-abbreviate-file-name (file-name-directory dir))))
-
-(defun ediff-truncate-string-left (str newlen)
- ;; leave space for ... on the left
- (let ((len (length str))
- substr)
- (if (<= len newlen)
- str
- (setq newlen (max 0 (- newlen 3)))
- (setq substr (substring str (max 0 (- len 1 newlen))))
- (concat "..." substr))))
-
-(defsubst ediff-nonempty-string-p (string)
- (and (stringp string) (not (string= string ""))))
-
-(unless (fboundp 'subst-char-in-string)
- (defun subst-char-in-string (fromchar tochar string &optional inplace)
- "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
-Unless optional argument INPLACE is non-nil, return a new string."
- (let ((i (length string))
- (newstr (if inplace string (copy-sequence string))))
- (while (> i 0)
- (setq i (1- i))
- (if (eq (aref newstr i) fromchar)
- (aset newstr i tochar)))
- newstr)))
-
-(defun ediff-abbrev-jobname (jobname)
- (cond ((eq jobname 'ediff-directories)
- "Compare two directories")
- ((eq jobname 'ediff-files)
- "Compare two files")
- ((eq jobname 'ediff-buffers)
- "Compare two buffers")
- ((eq jobname 'ediff-directories3)
- "Compare three directories")
- ((eq jobname 'ediff-files3)
- "Compare three files")
- ((eq jobname 'ediff-buffers3)
- "Compare three buffers")
- ((eq jobname 'ediff-revision)
- "Compare file with a version")
- ((eq jobname 'ediff-directory-revisions)
- "Compare dir files with versions")
- ((eq jobname 'ediff-merge-directory-revisions)
- "Merge dir files with versions")
- ((eq jobname 'ediff-merge-directory-revisions-with-ancestor)
- "Merge dir versions via ancestors")
- (t
- (capitalize
- (subst-char-in-string ?- ?\s (substring (symbol-name jobname) 6))))
- ))
-
-
-;; If ediff modified mode line, strip the modification
-(defsubst ediff-strip-mode-line-format ()
- (if (member (car mode-line-format) '(" A: " " B: " " C: " " Ancestor: "))
- (setq mode-line-format (nth 2 mode-line-format))))
-
-;; Verify that we have a difference selected.
-(defsubst ediff-valid-difference-p (&optional n)
- (or n (setq n ediff-current-difference))
- (and (>= n 0) (< n ediff-number-of-differences)))
-
-(defsubst ediff-show-all-diffs (n)
- "Don't skip difference regions."
- nil)
-
-(defsubst ediff-message-if-verbose (string &rest args)
- (if ediff-verbose-p
- (apply 'message string args)))
-
-(defun ediff-file-attributes (filename attr-number)
- (if (ediff-listable-file filename)
- (nth attr-number (file-attributes filename))
- -1)
- )
-
-(defsubst ediff-file-size (filename)
- (ediff-file-attributes filename 7))
-(defsubst ediff-file-modtime (filename)
- (ediff-file-attributes filename 5))
-
-
-(defun ediff-convert-standard-filename (fname)
- (if (fboundp 'convert-standard-filename)
- (convert-standard-filename fname)
- fname))
-
-(if (featurep 'emacs)
- (defalias 'ediff-with-syntax-table 'with-syntax-table)
- (if (fboundp 'with-syntax-table)
- (defalias 'ediff-with-syntax-table 'with-syntax-table)
- ;; stolen from subr.el in emacs 21
- (defmacro ediff-with-syntax-table (table &rest body)
- (let ((old-table (make-symbol "table"))
- (old-buffer (make-symbol "buffer")))
- `(let ((,old-table (syntax-table))
- (,old-buffer (current-buffer)))
- (unwind-protect
- (progn
- (set-syntax-table (copy-syntax-table ,table))
- ,@body)
- (save-current-buffer
- (set-buffer ,old-buffer)
- (set-syntax-table ,old-table))))))))
-
-
-(provide 'ediff-init)
-
-
-
-;; Local Variables:
-;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
-;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
-;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
-;; End:
-
-;; arch-tag: fa31d384-1e70-4d4b-82a7-3e96307c46f5
-;;; ediff-init.el ends here
+++ /dev/null
-;;; ediff-merg.el --- merging utilities
-
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-
-;; compiler pacifier
-(defvar ediff-window-A)
-(defvar ediff-window-B)
-(defvar ediff-window-C)
-(defvar ediff-merge-window-share)
-(defvar ediff-window-config-saved)
-
-(eval-when-compile
- (require 'ediff-util))
-;; end pacifier
-
-(require 'ediff-init)
-
-(defcustom ediff-quit-merge-hook 'ediff-maybe-save-and-delete-merge
- "Hooks to run before quitting a merge job.
-The most common use is to save and delete the merge buffer."
- :type 'hook
- :group 'ediff-merge)
-
-
-(defcustom ediff-default-variant 'combined
- "The variant to be used as a default for buffer C in merging.
-Valid values are the symbols `default-A', `default-B', and `combined'."
- :type '(radio (const default-A) (const default-B) (const combined))
- :group 'ediff-merge)
-
-(defcustom ediff-combination-pattern
- '("<<<<<<< variant A" A ">>>>>>> variant B" B "####### Ancestor" Ancestor "======= end")
- "Pattern to be used for combining difference regions in buffers A and B.
-The value must be a list of the form
-\(STRING1 bufspec1 STRING2 bufspec2 STRING3 bufspec3 STRING4)
-where bufspec is the symbol A, B, or Ancestor. For instance, if the value is
-'(STRING1 A STRING2 Ancestor STRING3 B STRING4) then the
-combined text will look like this:
-
-STRING1
-diff region from variant A
-STRING2
-diff region from the ancestor
-STRING3
-diff region from variant B
-STRING4
-"
- :type '(choice (list string symbol string symbol string)
- (list string symbol string symbol string symbol string))
- :group 'ediff-merge)
-
-(defcustom ediff-show-clashes-only nil
- "If t, show only those diff regions where both buffers disagree with the ancestor.
-This means that regions that have status prefer-A or prefer-B will be
-skipped over. A value of nil means show all regions."
- :type 'boolean
- :group 'ediff-merge
- )
-(make-variable-buffer-local 'ediff-show-clashes-only)
-
-(defcustom ediff-skip-merge-regions-that-differ-from-default nil
- "If t, show only the regions that have not been changed by the user.
-A region is considered to have been changed if it is different from the current
-default (`default-A', `default-B', `combined') and it hasn't been marked as
-`prefer-A' or `prefer-B'.
-A region is considered to have been changed also when it is marked as
-as `prefer-A', but is different from the corresponding difference region in
-Buffer A or if it is marked as `prefer-B' and is different from the region in
-Buffer B."
- :type 'boolean
- :group 'ediff-merge
- )
-(make-variable-buffer-local 'ediff-skip-merge-regions-that-differ-from-default)
-
-;; check if there is no clash between the ancestor and one of the variants.
-;; if it is not a merge job then return true
-(defun ediff-merge-region-is-non-clash (n)
- (if (ediff-merge-job)
- (string-match "prefer" (or (ediff-get-state-of-merge n) ""))
- t))
-
-;; If ediff-show-clashes-only, check if there is no clash between the ancestor
-;; and one of the variants.
-(defun ediff-merge-region-is-non-clash-to-skip (n)
- (and (ediff-merge-job)
- ediff-show-clashes-only
- (ediff-merge-region-is-non-clash n)))
-
-;; If ediff-skip-changed-regions, check if the merge region differs from
-;; the current default. If a region is different from the default, it means
-;; that the user has made determination as to how to merge for this particular
-;; region.
-(defun ediff-skip-merge-region-if-changed-from-default-p (n)
- (and (ediff-merge-job)
- ediff-skip-merge-regions-that-differ-from-default
- (ediff-merge-changed-from-default-p n 'prefers-too)))
-
-
-(defun ediff-get-combined-region (n)
- (let ((pattern-list ediff-combination-pattern)
- (combo-region "")
- (err-msg
- "ediff-combination-pattern: Invalid format. Please consult the documentation")
- region-delim region-spec)
-
- (if (< (length pattern-list) 5)
- (error err-msg))
-
- (while (> (length pattern-list) 2)
- (setq region-delim (nth 0 pattern-list)
- region-spec (nth 1 pattern-list))
- (or (and (stringp region-delim) (memq region-spec '(A B Ancestor)))
- (error err-msg))
-
- (condition-case nil
- (setq combo-region
- (concat combo-region
- region-delim "\n"
- (ediff-get-region-contents
- n region-spec ediff-control-buffer)))
- (error ""))
- (setq pattern-list (cdr (cdr pattern-list)))
- )
-
- (setq region-delim (nth 0 pattern-list))
- (or (stringp region-delim)
- (error err-msg))
- (setq combo-region (concat combo-region region-delim "\n"))
- ))
-
-;;(defsubst ediff-make-combined-diff (regA regB)
-;; (concat (nth 0 ediff-combination-pattern) "\n"
-;; regA
-;; (nth 1 ediff-combination-pattern) "\n"
-;; regB
-;; (nth 2 ediff-combination-pattern) "\n"))
-
-(defsubst ediff-set-state-of-all-diffs-in-all-buffers (ctl-buf)
- (let ((n 0))
- (while (< n ediff-number-of-differences)
- (ediff-set-state-of-diff-in-all-buffers n ctl-buf)
- (setq n (1+ n)))))
-
-(defun ediff-set-state-of-diff-in-all-buffers (n ctl-buf)
- (let ((regA (ediff-get-region-contents n 'A ctl-buf))
- (regB (ediff-get-region-contents n 'B ctl-buf))
- (regC (ediff-get-region-contents n 'C ctl-buf)))
- (cond ((and (string= regA regB) (string= regA regC))
- (ediff-set-state-of-diff n 'A "=diff(B)")
- (ediff-set-state-of-diff n 'B "=diff(C)")
- (ediff-set-state-of-diff n 'C "=diff(A)"))
- ((string= regA regB)
- (ediff-set-state-of-diff n 'A "=diff(B)")
- (ediff-set-state-of-diff n 'B "=diff(A)")
- (ediff-set-state-of-diff n 'C nil))
- ((string= regA regC)
- (ediff-set-state-of-diff n 'A "=diff(C)")
- (ediff-set-state-of-diff n 'C "=diff(A)")
- (ediff-set-state-of-diff n 'B nil))
- ((string= regB regC)
- (ediff-set-state-of-diff n 'C "=diff(B)")
- (ediff-set-state-of-diff n 'B "=diff(C)")
- (ediff-set-state-of-diff n 'A nil))
- ((string= regC (ediff-get-combined-region n))
- (ediff-set-state-of-diff n 'A nil)
- (ediff-set-state-of-diff n 'B nil)
- (ediff-set-state-of-diff n 'C "=diff(A+B)"))
- (t (ediff-set-state-of-diff n 'A nil)
- (ediff-set-state-of-diff n 'B nil)
- (ediff-set-state-of-diff n 'C nil)))
- ))
-
-(defun ediff-set-merge-mode ()
- (normal-mode t)
- (remove-hook 'local-write-file-hooks 'ediff-set-merge-mode))
-
-
-;; Go over all diffs starting with DIFF-NUM and copy regions into buffer C
-;; according to the state of the difference.
-;; Since ediff-copy-diff refuses to copy identical diff regions, there is
-;; no need to optimize ediff-do-merge any further.
-;;
-;; If re-merging, change state of merge in all diffs starting with
-;; DIFF-NUM, except those where the state is prefer-* or where it is
-;; `default-*' or `combined' but the buf C region appears to be modified
-;; since last set by default.
-(defun ediff-do-merge (diff-num &optional remerging)
- (if (< diff-num 0) (setq diff-num 0))
- (let ((n diff-num)
- ;;(default-state-of-merge (format "%S" ediff-default-variant))
- do-not-copy state-of-merge)
- (while (< n ediff-number-of-differences)
- (setq do-not-copy nil) ; reset after each cycle
- (if (= (mod n 10) 0)
- (message "%s buffers A & B into C ... region %d of %d"
- (if remerging "Re-merging" "Merging")
- n
- ediff-number-of-differences))
-
- (setq state-of-merge (ediff-get-state-of-merge n))
-
- (if remerging
- ;;(let ((reg-A (ediff-get-region-contents n 'A ediff-control-buffer))
- ;; (reg-B (ediff-get-region-contents n 'B ediff-control-buffer))
- ;; (reg-C (ediff-get-region-contents n 'C ediff-control-buffer)))
- (progn
-
- ;; if region was edited since it was first set by default
- (if (or (ediff-merge-changed-from-default-p n)
- ;; was preferred
- (string-match "prefer" state-of-merge))
- ;; then ignore
- (setq do-not-copy t))
-
- ;; change state of merge for this diff, if necessary
- (if (and (string-match "\\(default\\|combined\\)" state-of-merge)
- (not do-not-copy))
- (ediff-set-state-of-merge
- n (format "%S" ediff-default-variant)))
- ))
-
- ;; state-of-merge may have changed via ediff-set-state-of-merge, so
- ;; check it once again
- (setq state-of-merge (ediff-get-state-of-merge n))
-
- (or do-not-copy
- (if (string= state-of-merge "combined")
- ;; use n+1 because ediff-combine-diffs works via user numbering
- ;; of diffs, which is 1+ to what ediff uses internally
- (ediff-combine-diffs (1+ n) 'batch)
- (ediff-copy-diff
- n (if (string-match "-A" state-of-merge) 'A 'B) 'C 'batch)))
- (setq n (1+ n)))
- (message "Merging buffers A & B into C ... Done")
- ))
-
-
-(defun ediff-re-merge ()
- "Remerge unmodified diff regions using a new default. Start with the current region."
- (interactive)
- (let* ((default-variant-alist
- (list '("default-A") '("default-B") '("combined")))
- (actual-alist
- (delete (list (symbol-name ediff-default-variant))
- default-variant-alist)))
- (setq ediff-default-variant
- (intern
- (completing-read
- (format "Current merge default is `%S'. New default: "
- ediff-default-variant)
- actual-alist nil 'must-match)))
- (ediff-do-merge ediff-current-difference 'remerge)
- (ediff-recenter)
- ))
-
-(defun ediff-shrink-window-C (arg)
- "Shrink window C to just one line.
-With a prefix argument, returns window C to its normal size.
-Used only for merging jobs."
- (interactive "P")
- (if (not ediff-merge-job)
- (error "ediff-shrink-window-C can be used only for merging jobs"))
- (cond ((eq arg '-) (setq arg -1))
- ((not (numberp arg)) (setq arg nil)))
- (cond ((null arg)
- (let ((ediff-merge-window-share
- (if (< (window-height ediff-window-C) 3)
- ediff-merge-window-share 0)))
- (setq ediff-window-config-saved "") ; force redisplay
- (ediff-recenter 'no-rehighlight)))
- ((and (< arg 0) (> (window-height ediff-window-C) 2))
- (setq ediff-merge-window-share (* ediff-merge-window-share 0.9))
- (setq ediff-window-config-saved "") ; force redisplay
- (ediff-recenter 'no-rehighlight))
- ((and (> arg 0) (> (window-height ediff-window-A) 2))
- (setq ediff-merge-window-share (* ediff-merge-window-share 1.1))
- (setq ediff-window-config-saved "") ; force redisplay
- (ediff-recenter 'no-rehighlight))))
-
-
-;; N here is the user's region number. It is 1+ what Ediff uses internally.
-(defun ediff-combine-diffs (n &optional batch-invocation)
- "Combine Nth diff regions of buffers A and B and place the combination in C.
-N is a prefix argument. If nil, combine the current difference regions.
-Combining is done according to the specifications in variable
-`ediff-combination-pattern'."
- (interactive "P")
- (setq n (if (numberp n) (1- n) ediff-current-difference))
-
- (let (reg-combined)
- ;;(setq regA (ediff-get-region-contents n 'A ediff-control-buffer)
- ;; regB (ediff-get-region-contents n 'B ediff-control-buffer))
- ;;(setq reg-combined (ediff-make-combined-diff regA regB))
- (setq reg-combined (ediff-get-combined-region n))
-
- (ediff-copy-diff n nil 'C batch-invocation reg-combined))
- (or batch-invocation (ediff-jump-to-difference (1+ n))))
-
-
-;; Checks if the region in buff C looks like a combination of the regions
-;; in buffers A and B. Return a list (reg-a-beg reg-a-end reg-b-beg reg-b-end)
-;; These refer to where the delimiters for region A, B, Ancestor start and end
-;; in buffer C
-(defun ediff-looks-like-combined-merge (region-num)
- (if ediff-merge-job
- (let ((combined (string-match (regexp-quote "(A+B)")
- (or (ediff-get-state-of-diff region-num 'C)
- "")))
- (mrgreg-beg (ediff-get-diff-posn 'C 'beg region-num))
- (mrgreg-end (ediff-get-diff-posn 'C 'end region-num))
- (pattern-list ediff-combination-pattern)
- delim reg-beg reg-end delim-regs-list)
-
- (if combined
- (ediff-with-current-buffer ediff-buffer-C
- (while pattern-list
- (goto-char mrgreg-beg)
- (setq delim (nth 0 pattern-list))
- (search-forward delim mrgreg-end 'noerror)
- (setq reg-beg (match-beginning 0))
- (setq reg-end (match-end 0))
- (if (and reg-beg reg-end)
- (setq delim-regs-list
- ;; in reverse
- (cons reg-end (cons reg-beg delim-regs-list))))
- (if (> (length pattern-list) 1)
- (setq pattern-list (cdr (cdr pattern-list)))
- (setq pattern-list nil))
- )))
-
- (reverse delim-regs-list)
- )))
-
-(defvar state-of-merge) ; dynamic var
-
-;; Check if the non-preferred merge has been modified since originally set.
-;; This affects only the regions that are marked as default-A/B or combined.
-;; If PREFERS-TOO is non-nil, then look at the regions marked as prefers-A/B as
-;; well.
-(defun ediff-merge-changed-from-default-p (diff-num &optional prefers-too)
- (let ((reg-A (ediff-get-region-contents diff-num 'A ediff-control-buffer))
- (reg-B (ediff-get-region-contents diff-num 'B ediff-control-buffer))
- (reg-C (ediff-get-region-contents diff-num 'C ediff-control-buffer)))
-
- (setq state-of-merge (ediff-get-state-of-merge diff-num))
-
- ;; if region was edited since it was first set by default
- (or (and (string= state-of-merge "default-A")
- (not (string= reg-A reg-C)))
- (and (string= state-of-merge "default-B")
- (not (string= reg-B reg-C)))
- (and (string= state-of-merge "combined")
- ;;(not (string= (ediff-make-combined-diff reg-A reg-B) reg-C)))
- (not (string= (ediff-get-combined-region diff-num) reg-C)))
- (and prefers-too
- (string= state-of-merge "prefer-A")
- (not (string= reg-A reg-C)))
- (and prefers-too
- (string= state-of-merge "prefer-B")
- (not (string= reg-B reg-C)))
- )))
-
-
-(provide 'ediff-merg)
-
-
-;; Local Variables:
-;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
-;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
-;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
-;; End:
-
-;; arch-tag: 9b798cf9-02ba-487f-a62e-b63aa823dbfb
-;;; ediff-merg.el ends here
+++ /dev/null
-;;; ediff-mult.el --- support for multi-file/multi-buffer processing in Ediff
-
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Users are encouraged to add functionality to this file.
-;; The present file contains all the infrastructure needed for that.
-;;
-;; Generally, to implement a new multisession capability within Ediff,
-;; you need to tell it
-;;
-;; 1. How to display the session group buffer.
-;; This function must indicate which Ediff sessions are active (+) and
-;; which are finished (-).
-;; See ediff-redraw-directory-group-buffer for an example.
-;; In all likelihood, ediff-redraw-directory-group-buffer can be used
-;; directly or after a small modification.
-;; 2. What action to take when the user clicks button 2 or types v,e, or
-;; RET. See ediff-filegroup-action.
-;; 3. Provide a list of pairs or triples of file names (or buffers,
-;; depending on the particular Ediff operation you want to invoke)
-;; in the following format:
-;; (HEADER (nil nil (obj1 nil) (obj2 nil) (obj3 nil))
-;; (...) ...)
-;; The function ediff-make-new-meta-list-element can be used to create
-;; 2nd and subsequent elements of that list (i.e., after the
-;; description header). See ediff-make-new-meta-list-element for the
-;; explanation of the two nil placeholders in such elements.
-;;
-;; There is API for extracting the components of the members of the
-;; above list. Search for `API for ediff-meta-list' for details.
-;;
-;; HEADER must be a list of SIX elements (nil or string):
-;; (regexp metaobj1 metaobj2 metaobj3 merge-save-buffer
-;; comparison-function)
-;; The function ediff-redraw-registry-buffer displays the
-;; 1st - 4th of these in the registry buffer.
-;; For some jobs some of the members of the header might be nil.
-;; The meaning of metaobj1, metaobj2, and metaobj3 depend on the job.
-;; Typically these are directories where the files to be compared are
-;; found.
-;; Also, keep in mind that the function ediff-prepare-meta-buffer
-;; (which see) prepends the session group buffer to the descriptor, so
-;; the descriptor becomes 7-long.
-;; Ediff expects that your function (in 2 above) will arrange to
-;; replace this prepended nil (via setcar) with the actual ediff
-;; control buffer associated with an appropriate Ediff session.
-;; This is arranged through internal startup hooks that can be passed
-;; to any of Ediff major entries (such as ediff-files, epatch, etc.).
-;; See how this is done in ediff-filegroup-action.
-;;
-;; Session descriptions are of the form
-;; (nil nil (obj1 . nil) (obj2 . nil) (obj3 . nil))
-;; which describe the objects relevant to the session.
-;; Use ediff-make-new-meta-list-element to create these things.
-;; Usually obj1/2/3 are names of files, but they may also be other
-;; things for some jobs. For instance, obj3 is nil for jobs that
-;; involve only two files. For patch jobs, obj2 and obj3 are markers
-;; that specify the patch corresponding to the file
-;; (whose name is obj1).
-;; The nil's are placeholders, which are used internally by ediff.
-;; 4. Write a function that makes a call to ediff-prepare-meta-buffer
-;; passing all this info.
-;; You may be able to use ediff-directories-internal as a template.
-;; 5. If you intend to add several related pieces of functionality,
-;; you may want to keep the function in 4 as an internal version
-;; and then write several top-level interactive functions that call it
-;; with different parameters.
-;; See how ediff-directories, ediff-merge-directories, and
-;; ediff-merge-directories-with-ancestor all use
-;; ediff-directories-internal.
-;;
-;; A useful addition here could be session groups selected by patterns
-;; (which are different in each directory). For instance, one may want to
-;; compare files of the form abc{something}.c to files old{something}.d
-;; which may be in the same or different directories. Or, one may want to
-;; compare all files of the form {something} to files of the form {something}~.
-;;
-;; Implementing this requires writing a collating function, which should pair
-;; up appropriate files. It will also require a generalization of the
-;; functions that do the layout of the meta- and differences buffers and of
-;; ediff-filegroup-action.
-
-;;; Code:
-
-
-(provide 'ediff-mult)
-
-(defgroup ediff-mult nil
- "Multi-file and multi-buffer processing in Ediff."
- :prefix "ediff-"
- :group 'ediff)
-
-
-;; compiler pacifier
-(eval-when-compile
- (require 'ediff-ptch)
- (require 'ediff))
-;; end pacifier
-
-(require 'ediff-init)
-
-;; meta-buffer
-(ediff-defvar-local ediff-meta-buffer nil "")
-(ediff-defvar-local ediff-parent-meta-buffer nil "")
-;; the registry buffer
-(defvar ediff-registry-buffer nil)
-
-(defconst ediff-meta-buffer-brief-message "Ediff Session Group Panel: %s
-
- Type ? to show useful commands in this buffer
-
-")
-
-(defconst ediff-meta-buffer-verbose-message "Ediff Session Group Panel: %s
-
-Useful commands (type ? to hide them and free up screen):
- button2, v, or RET over session record: start that Ediff session
- M:\tin sessions invoked from here, brings back this group panel
- R:\tdisplay the registry of active Ediff sessions
- h:\tmark session for hiding (toggle)
- x:\thide marked sessions; with prefix arg: unhide
- m:\tmark session for a non-hiding operation (toggle)
- uh/um:\tunmark all sessions marked for hiding/operation
- n,SPC:\tnext session
- p,DEL:\tprevious session
- E:\tbrowse Ediff on-line manual
- T:\ttoggle truncation of long file names
- q:\tquit this session group
-")
-
-(ediff-defvar-local ediff-meta-buffer-map nil
- "The keymap for the meta buffer.")
-(defvar ediff-dir-diffs-buffer-map (make-sparse-keymap)
- "The keymap to be installed in the buffer showing differences between
-directories.")
-
-;; Variable specifying the action to take when the use invokes ediff in the
-;; meta buffer. This is usually ediff-registry-action or ediff-filegroup-action
-(ediff-defvar-local ediff-meta-action-function nil "")
-;; Tells ediff-update-meta-buffer how to redraw it
-(ediff-defvar-local ediff-meta-redraw-function nil "")
-;; Tells ediff-filegroup-action and similar procedures how to invoke Ediff for
-;; the sessions in a given session group
-(ediff-defvar-local ediff-session-action-function nil "")
-
-(ediff-defvar-local ediff-metajob-name nil "")
-
-;; buffer used to collect custom diffs from individual sessions in the group
-(ediff-defvar-local ediff-meta-diff-buffer nil "")
-
-;; t means recurse into subdirs when deciding which files have same contents
-(ediff-defvar-local ediff-recurse-to-subdirectories nil "")
-
-;; history var to use for filtering groups of files
-(defvar ediff-filtering-regexp-history nil "")
-
-(defcustom ediff-default-filtering-regexp nil
- "The default regular expression used as a filename filter in multifile comparisons.
-Should be a sexp. For instance (car ediff-filtering-regexp-history) or nil."
- :type 'sexp
- :group 'ediff-mult)
-
-;; This has the form ((meta-buf regexp dir1 dir2 dir3 merge-auto-store-dir)
-;; (ctl-buf session-status (file1 . eq-status) (file2 . eq-status) (file3
-;; . eq-status)) (ctl-buf session-status (file1 . eq-status) (file2
-;; . eq-status)) ...)
-;; If ctl-buf is nil, the file-pair hasn't processed yet. If it is
-;; killed-buffer object, the file pair has been processed. If it is a live
-;; buffer, this means ediff is still working on the pair.
-;; Eq-status of a file is t if the file equals some other file in the same
-;; group.
-(ediff-defvar-local ediff-meta-list nil "")
-
-(ediff-defvar-local ediff-meta-session-number nil "")
-
-
-;; the difference list between directories in a directory session group
-(ediff-defvar-local ediff-dir-difference-list nil "")
-(ediff-defvar-local ediff-dir-diffs-buffer nil "")
-
-;; The registry of Ediff sessions. A list of control buffers.
-(defvar ediff-session-registry nil)
-
-(defcustom ediff-meta-truncate-filenames t
- "If non-nil, truncate long file names in the session group buffers.
-This can be toggled with `ediff-toggle-filename-truncation'."
- :type 'boolean
- :group 'ediff-mult)
-
-(defcustom ediff-meta-mode-hook nil
- "Hooks run just after setting up meta mode."
- :type 'hook
- :group 'ediff-mult)
-
-(defcustom ediff-registry-setup-hook nil
- "Hooks run just after the registry control panel is set up."
- :type 'hook
- :group 'ediff-mult)
-
-(defcustom ediff-before-session-group-setup-hooks nil
- "Hooks to run before Ediff arranges the window for group-level operations.
-It is used by commands such as `ediff-directories'.
-This hook can be used to save the previous window config, which can be restored
-on `ediff-quit', `ediff-suspend', or `ediff-quit-session-group-hook'."
- :type 'hook
- :group 'ediff-hook)
-(defcustom ediff-after-session-group-setup-hook nil
- "Hooks run just after a meta-buffer controlling a session group, such as
-ediff-directories, is run."
- :type 'hook
- :group 'ediff-mult)
-(defcustom ediff-quit-session-group-hook nil
- "Hooks run just before exiting a session group."
- :type 'hook
- :group 'ediff-mult)
-(defcustom ediff-show-registry-hook nil
- "Hooks run just after the registry buffer is shown."
- :type 'hook
- :group 'ediff-mult)
-(defcustom ediff-show-session-group-hook '(delete-other-windows)
- "Hooks run just after a session group buffer is shown."
- :type 'hook
- :group 'ediff-mult)
-(defcustom ediff-meta-buffer-keymap-setup-hook nil
- "Hooks run just after setting up the `ediff-meta-buffer-map'.
-This keymap controls key bindings in the meta buffer and is a local variable.
-This means that you can set different bindings for different kinds of meta
-buffers."
- :type 'hook
- :group 'ediff-mult)
-
-;; Buffer holding the multi-file patch. Local to the meta buffer
-(ediff-defvar-local ediff-meta-patchbufer nil "")
-
-;;; API for ediff-meta-list
-
-;; A meta-list is either ediff-meta-list, which contains a header and the list
-;; of ediff sessions or ediff-dir-difference-list, which is a header followed
-;; by the list of differences among the directories (i.e., files that are not
-;; in all directories). The header is the same in all meta lists, but the rest
-;; is different.
-;; Structure of the meta-list:
-;; (HEADER SESSION1 SESSION2 ...)
-;; HEADER: (GROUP-BUF REGEXP OBJA OBJB OBJC SAVE-DIR COMPARISON-FUNC)
-;; OBJA - first directory
-;; OBJB - second directory
-;; OBJC - third directory
-;; SESSION1/2/... are described below
-;; group buffer/regexp
-(defsubst ediff-get-group-buffer (meta-list)
- (nth 0 (car meta-list)))
-
-(defsubst ediff-get-group-regexp (meta-list)
- (nth 1 (car meta-list)))
-;; group objects
-(defsubst ediff-get-group-objA (meta-list)
- (nth 2 (car meta-list)))
-(defsubst ediff-get-group-objB (meta-list)
- (nth 3 (car meta-list)))
-(defsubst ediff-get-group-objC (meta-list)
- (nth 4 (car meta-list)))
-(defsubst ediff-get-group-merge-autostore-dir (meta-list)
- (nth 5 (car meta-list)))
-(defsubst ediff-get-group-comparison-func (meta-list)
- (nth 6 (car meta-list)))
-
-;; ELT is a session meta descriptor (what is being preserved as
-;; 'ediff-meta-info)
-;; The structure is: (SESSION-CTL-BUFFER STATUS OBJA OBJB OBJC)
-;; STATUS is ?I (hidden or invalid), ?* (marked for operation), ?H (hidden)
-;; nil (nothing)
-;; OBJA/B/C is (FILENAME EQSTATUS)
-;; EQSTATUS is ?= or nil (?= means that this file is equal to some other
-;; file in this session)
-;; session buffer
-(defsubst ediff-get-session-buffer (elt)
- (nth 0 elt))
-(defsubst ediff-get-session-status (elt)
- (nth 1 elt))
-(defsubst ediff-set-session-status (session-info new-status)
- (setcar (cdr session-info) new-status))
-;; session objects
-(defsubst ediff-get-session-objA (elt)
- (nth 2 elt))
-(defsubst ediff-get-session-objB (elt)
- (nth 3 elt))
-(defsubst ediff-get-session-objC (elt)
- (nth 4 elt))
-;; Take the "name" component of the object into acount. ObjA/C/B is of the form
-;; (name . equality-indicator)
-(defsubst ediff-get-session-objA-name (elt)
- (car (nth 2 elt)))
-(defsubst ediff-get-session-objB-name (elt)
- (car (nth 3 elt)))
-(defsubst ediff-get-session-objC-name (elt)
- (car (nth 4 elt)))
-;; equality indicators
-(defsubst ediff-get-file-eqstatus (elt)
- (nth 1 elt))
-(defsubst ediff-set-file-eqstatus (elt value)
- (setcar (cdr elt) value))
-
-;; Create a new element for the meta list out of obj1/2/3, which usually are
-;; files
-;;
-;; The first nil in such an element is later replaced with the session buffer.
-;; The second nil is reserved for session status.
-;;
-;; Also, session objects A/B/C are turned into lists of the form (obj nil).
-;; This nil is a placeholder for eq-indicator. It is either nil or =.
-;; If it is discovered that this file is = to some other
-;; file in the same session, eq-indicator is changed to `='.
-;; Currently, the eq-indicator is used only for 2 and 3-file jobs.
-(defun ediff-make-new-meta-list-element (obj1 obj2 obj3)
- (list nil nil (list obj1 nil) (list obj2 nil) (list obj3 nil)))
-
-;; Constructs a meta list header.
-;; OBJA, OBJB, OBJC are usually directories involved, but can be different for
-;; different jobs. For instance, multifile patch has only OBJA, which is the
-;; patch buffer.
-(defun ediff-make-new-meta-list-header (regexp
- objA objB objC
- merge-auto-store-dir
- comparison-func)
- (list regexp objA objB objC merge-auto-store-dir comparison-func))
-
-;; The activity marker is either or + (active session, i.e., ediff is currently
-;; run in it), or - (finished session, i.e., we've ran ediff in it and then
-;; exited). Return nil, if session is neither active nor finished
-(defun ediff-get-session-activity-marker (session)
- (let ((session-buf (ediff-get-session-buffer session)))
- (cond ((null session-buf) nil) ; virgin session
- ((ediff-buffer-live-p session-buf) ?+) ;active session
- (t ?-))))
-
-;; checks if the session is a meta session
-(defun ediff-meta-session-p (session-info)
- (and (stringp (ediff-get-session-objA-name session-info))
- (file-directory-p (ediff-get-session-objA-name session-info))
- (stringp (ediff-get-session-objB-name session-info))
- (file-directory-p (ediff-get-session-objB-name session-info))
- (if (stringp (ediff-get-session-objC-name session-info))
- (file-directory-p (ediff-get-session-objC-name session-info)) t)))
-
-
-(ediff-defvar-local ediff-verbose-help-enabled nil
- "If t, display redundant help in ediff-directories and other meta buffers.
-Toggled by ediff-toggle-verbose-help-meta-buffer" )
-
-;; Toggle verbose help in meta-buffers
-;; TODO: Someone who understands all this can make it better.
-(defun ediff-toggle-verbose-help-meta-buffer ()
- "Toggle showing tediously verbose help in meta buffers."
- (interactive)
- (setq ediff-verbose-help-enabled (not ediff-verbose-help-enabled))
- (ediff-update-meta-buffer (current-buffer) 'must-redraw))
-
-;; set up the keymap in the meta buffer
-(defun ediff-setup-meta-map ()
- (setq ediff-meta-buffer-map (make-sparse-keymap))
- (suppress-keymap ediff-meta-buffer-map)
- (define-key ediff-meta-buffer-map "?" 'ediff-toggle-verbose-help-meta-buffer)
- (define-key ediff-meta-buffer-map "q" 'ediff-quit-meta-buffer)
- (define-key ediff-meta-buffer-map "T" 'ediff-toggle-filename-truncation)
- (define-key ediff-meta-buffer-map "R" 'ediff-show-registry)
- (define-key ediff-meta-buffer-map "E" 'ediff-documentation)
- (define-key ediff-meta-buffer-map "v" ediff-meta-action-function)
- (define-key ediff-meta-buffer-map "\C-m" ediff-meta-action-function)
- (define-key ediff-meta-buffer-map " " 'ediff-next-meta-item)
- (define-key ediff-meta-buffer-map "n" 'ediff-next-meta-item)
- (define-key ediff-meta-buffer-map "\C-?" 'ediff-previous-meta-item)
- (define-key ediff-meta-buffer-map "p" 'ediff-previous-meta-item)
- (define-key ediff-meta-buffer-map [delete] 'ediff-previous-meta-item)
- (define-key ediff-meta-buffer-map [backspace] 'ediff-previous-meta-item)
-
- (let ((menu-map (make-sparse-keymap "Ediff-Meta")))
- (define-key ediff-meta-buffer-map [menu-bar ediff-meta-mode]
- (cons "Ediff-Meta" menu-map))
- (define-key menu-map [ediff-quit-meta-buffer]
- '(menu-item "Quit" ediff-quit-meta-buffer
- :help "Quit the meta buffer"))
- (define-key menu-map [ediff-toggle-filename-truncation]
- '(menu-item "Truncate filenames" ediff-toggle-filename-truncation
- :help "Toggle truncation of long file names in session group buffers"
- :button (:toggle . ediff-meta-truncate-filenames)))
- (define-key menu-map [ediff-show-registry]
- '(menu-item "Display Ediff Registry" ediff-show-registry
- :help "Display Ediff's registry"))
- (define-key menu-map [ediff-documentation]
- '(menu-item "Show Manual" ediff-documentation
- :help "Display Ediff's manual"))
-
- (or (ediff-one-filegroup-metajob)
- (progn
- (define-key ediff-meta-buffer-map "=" nil)
- (define-key ediff-meta-buffer-map "==" 'ediff-meta-mark-equal-files)
- (define-key ediff-meta-buffer-map "=m" 'ediff-meta-mark-equal-files)
- (define-key ediff-meta-buffer-map "=h" 'ediff-meta-mark-equal-files)))
-
-
- (define-key menu-map [ediff-next-meta-item]
- '(menu-item "Next" ediff-next-meta-item
- :help "Move to the next item in Ediff registry or session group buffer"))
- (define-key menu-map [ediff-previous-meta-item]
- '(menu-item "Previous" ediff-previous-meta-item
- :help "Move to the previous item in Ediff registry or session group buffer")))
-
-
- (if ediff-no-emacs-help-in-control-buffer
- (define-key ediff-meta-buffer-map "\C-h" 'ediff-previous-meta-item))
- (if (featurep 'emacs)
- (define-key ediff-meta-buffer-map [mouse-2] ediff-meta-action-function)
- (define-key ediff-meta-buffer-map [button2] ediff-meta-action-function))
-
- (use-local-map ediff-meta-buffer-map)
- ;; modify ediff-meta-buffer-map here
- (run-hooks 'ediff-meta-buffer-keymap-setup-hook))
-
-
-(defun ediff-meta-mode ()
- "This mode controls all operations on Ediff session groups.
-It is entered through one of the following commands:
- `ediff-directories'
- `edirs'
- `ediff-directories3'
- `edirs3'
- `ediff-merge-directories'
- `edirs-merge'
- `ediff-merge-directories-with-ancestor'
- `edirs-merge-with-ancestor'
- `ediff-directory-revisions'
- `edir-revisions'
- `ediff-merge-directory-revisions'
- `edir-merge-revisions'
- `ediff-merge-directory-revisions-with-ancestor'
- `edir-merge-revisions-with-ancestor'
-
-Commands:
-\\{ediff-meta-buffer-map}"
- (kill-all-local-variables)
- (setq major-mode 'ediff-meta-mode)
- (setq mode-name "MetaEdiff")
- ;; don't use run-mode-hooks here!
- (run-hooks 'ediff-meta-mode-hook))
-
-
-;; the keymap for the buffer showing directory differences
-(suppress-keymap ediff-dir-diffs-buffer-map)
-(define-key ediff-dir-diffs-buffer-map "q" 'ediff-bury-dir-diffs-buffer)
-(define-key ediff-dir-diffs-buffer-map " " 'next-line)
-(define-key ediff-dir-diffs-buffer-map "n" 'next-line)
-(define-key ediff-dir-diffs-buffer-map "\C-?" 'previous-line)
-(define-key ediff-dir-diffs-buffer-map "p" 'previous-line)
-(define-key ediff-dir-diffs-buffer-map "C" 'ediff-dir-diff-copy-file)
-(if (featurep 'emacs)
- (define-key ediff-dir-diffs-buffer-map [mouse-2] 'ediff-dir-diff-copy-file)
- (define-key ediff-dir-diffs-buffer-map [button2] 'ediff-dir-diff-copy-file))
-(define-key ediff-dir-diffs-buffer-map [delete] 'previous-line)
-(define-key ediff-dir-diffs-buffer-map [backspace] 'previous-line)
-
-(defun ediff-next-meta-item (count)
- "Move to the next item in Ediff registry or session group buffer.
-Moves in circular fashion. With numeric prefix arg, skip this many items."
- (interactive "p")
- (or count (setq count 1))
- (let (overl)
- (while (< 0 count)
- (setq count (1- count))
- (ediff-next-meta-item1)
- (setq overl (ediff-get-meta-overlay-at-pos (point)))
- ;; skip invisible ones
- (while (and overl (ediff-overlay-get overl 'invisible))
- (ediff-next-meta-item1)
- (setq overl (ediff-get-meta-overlay-at-pos (point)))))))
-
-;; Move to the next meta item
-(defun ediff-next-meta-item1 ()
- (let (pos)
- (setq pos (ediff-next-meta-overlay-start (point)))
- (if pos (goto-char pos))
- (if (eq ediff-metajob-name 'ediff-registry)
- (if (and (ediff-get-meta-info (current-buffer) pos 'noerror)
- (search-forward "*Ediff" nil t))
- (skip-chars-backward "a-zA-Z*"))
- (if (> (skip-chars-forward "-+?H* \t0-9") 0)
- (backward-char 1)))))
-
-
-(defun ediff-previous-meta-item (count)
- "Move to the previous item in Ediff registry or session group buffer.
-Moves in circular fashion. With numeric prefix arg, skip this many items."
- (interactive "p")
- (or count (setq count 1))
- (let (overl)
- (while (< 0 count)
- (setq count (1- count))
- (ediff-previous-meta-item1)
- (setq overl (ediff-get-meta-overlay-at-pos (point)))
- ;; skip invisible ones
- (while (and overl (ediff-overlay-get overl 'invisible))
- (ediff-previous-meta-item1)
- (setq overl (ediff-get-meta-overlay-at-pos (point)))))))
-
-(defun ediff-previous-meta-item1 ()
- (let (pos)
- (setq pos (ediff-previous-meta-overlay-start (point)))
-;;; ;; skip deleted
-;;; (while (ediff-get-session-status
-;;; (ediff-get-meta-info (current-buffer) pos 'noerror))
-;;; (setq pos (ediff-previous-meta-overlay-start pos)))
-
- (if pos (goto-char pos))
- (if (eq ediff-metajob-name 'ediff-registry)
- (if (and (ediff-get-meta-info (current-buffer) pos 'noerror)
- (search-forward "*Ediff" nil t))
- (skip-chars-backward "a-zA-Z*"))
- (if (> (skip-chars-forward "-+?H* \t0-9") 0)
- (backward-char 1)))
- ))
-
-(defsubst ediff-add-slash-if-directory (dir file)
- (if (file-directory-p (concat dir file))
- (file-name-as-directory file)
- file))
-
-(defun ediff-toggle-filename-truncation ()
- "Toggle truncation of long file names in session group buffers.
-Set `ediff-meta-truncate-filenames' variable if you want to change the default
-behavior."
- (interactive)
- (setq ediff-meta-truncate-filenames (not ediff-meta-truncate-filenames))
- (ediff-update-meta-buffer (current-buffer) 'must-redraw))
-
-
-;; These are used to encode membership of files in directory1/2/3
-;; Membership code of a file is a product of codes for the directories where
-;; this file is in
-(defvar ediff-membership-code1 2)
-(defvar ediff-membership-code2 3)
-(defvar ediff-membership-code3 5)
-(defvar ediff-product-of-memcodes (* ediff-membership-code1
- ediff-membership-code2
- ediff-membership-code3))
-
-;; DIR1, DIR2, DIR3 are directories. DIR3 can be nil.
-;; OUTPUT-DIR is a directory for auto-storing the results of merge jobs.
-;; Can be nil.
-;; REGEXP is nil or a filter regexp; only file names that match the regexp
-;; are considered.
-;; If a file is a directory in dir1 but not dir2 (or vice versa), it is not
-;; included in the intersection. However, a regular file that is a dir in dir3
-;; is included, since dir3 files are supposed to be ancestors for merging.
-;; If COMPARISON-FUNC is given, use it. Otherwise, use string=
-;;
-;; Returns a list of the form:
-;; (COMMON-PART DIFF-LIST)
-;; COMMON-PART is car and DIFF-LIST is cdr.
-;;
-;; COMMON-PART is of the form:
-;; (META-HEADER (f1 f2 f3) (f1 f2 f3) ...)
-;; f3 can be nil if intersecting only 2 directories.
-;; Each triple (f1 f2 f3) represents the files to be compared in the
-;; corresponding ediff subsession.
-;;
-;; DIFF-LIST is of the form:
-;; (META-HEADER (file . num) (file . num)...)
-;; where num encodes the set of dirs where the file is found:
-;; 2 - only dir1; 3 - only dir2; 5 - only dir3; 6 - dir1&2; 10 - dir1&3; etc.
-;; META-HEADER:
-;; Contains the meta info about this ediff operation
-;; (regexp dir1 dir2 dir3 merge-auto-store-dir comparison-func)
-;; Later the meta-buffer is prepended to this list.
-;;
-;; Some operations might use a different meta header. For instance,
-;; ediff-multifile-patch doesn't have dir2 and dir3, and regexp,
-;; comparison-func don't apply.
-;;
-(defun ediff-intersect-directories (jobname
- regexp dir1 dir2
- &optional
- dir3 merge-autostore-dir comparison-func)
- (setq comparison-func (or comparison-func 'string=))
- (let (lis1 lis2 lis3 common auxdir1 auxdir2 auxdir3 common-part difflist)
-
- (setq auxdir1 (file-name-as-directory dir1)
- lis1 (directory-files auxdir1 nil regexp)
- lis1 (delete "." lis1)
- lis1 (delete ".." lis1)
- lis1 (mapcar
- (lambda (elt)
- (ediff-add-slash-if-directory auxdir1 elt))
- lis1)
- auxdir2 (file-name-as-directory dir2)
- lis2 (directory-files auxdir2 nil regexp)
- lis2 (delete "." lis2)
- lis2 (delete ".." lis2)
- lis2 (mapcar
- (lambda (elt)
- (ediff-add-slash-if-directory auxdir2 elt))
- lis2))
-
- (if (stringp dir3)
- (setq auxdir3 (file-name-as-directory dir3)
- lis3 (directory-files auxdir3 nil regexp)
- lis3 (delete "." lis3)
- lis3 (delete ".." lis3)
- lis3 (mapcar
- (lambda (elt)
- (ediff-add-slash-if-directory auxdir3 elt))
- lis3)))
-
- (if (ediff-nonempty-string-p merge-autostore-dir)
- (setq merge-autostore-dir
- (file-name-as-directory merge-autostore-dir)))
- (setq common (ediff-intersection lis1 lis2 comparison-func))
-
- ;; In merge with ancestor jobs, we don't intersect with lis3.
- ;; If there is no ancestor, we'll offer to merge without the ancestor.
- ;; So, we intersect with lis3 only when we are doing 3-way file comparison
- (if (and lis3 (ediff-comparison-metajob3 jobname))
- (setq common (ediff-intersection common lis3 comparison-func)))
-
- ;; copying is needed because sort sorts via side effects
- (setq common (sort (ediff-copy-list common) 'string-lessp))
-
- ;; compute difference list
- (setq difflist (ediff-set-difference
- (ediff-union (ediff-union lis1 lis2 comparison-func)
- lis3
- comparison-func)
- common
- comparison-func)
- difflist (delete "." difflist)
- ;; copying is needed because sort sorts via side effects
- difflist (sort (ediff-copy-list (delete ".." difflist))
- 'string-lessp))
-
- (setq difflist (mapcar (lambda (elt) (cons elt 1)) difflist))
-
- ;; check for files belonging to lis1/2/3
- ;; Each elt is of the norm (file . number)
- ;; Number encodes the directories to which file belongs.
- ;; It is a product of a subset of ediff-membership-code1=2,
- ;; ediff-membership-code2=3, and ediff-membership-code3=5.
- ;; If file belongs to dir 1 only, the membership code is 2.
- ;; If it is in dir1 and dir3, then the membership code is 2*5=10;
- ;; if it is in dir1 and dir2, then the membership code is 2*3=6, etc.
- (mapc (lambda (elt)
- (if (member (car elt) lis1)
- (setcdr elt (* (cdr elt) ediff-membership-code1)))
- (if (member (car elt) lis2)
- (setcdr elt (* (cdr elt) ediff-membership-code2)))
- (if (member (car elt) lis3)
- (setcdr elt (* (cdr elt) ediff-membership-code3)))
- )
- difflist)
- (setq difflist (cons
- ;; diff metalist header
- (ediff-make-new-meta-list-header regexp
- auxdir1 auxdir2 auxdir3
- merge-autostore-dir
- comparison-func)
- difflist))
-
- (setq common-part
- (cons
- ;; metalist header
- (ediff-make-new-meta-list-header regexp
- auxdir1 auxdir2 auxdir3
- merge-autostore-dir
- comparison-func)
- (mapcar
- (lambda (elt)
- (ediff-make-new-meta-list-element
- (expand-file-name (concat auxdir1 elt))
- (expand-file-name (concat auxdir2 elt))
- (if lis3
- (progn
- ;; The following is done because: In merging with
- ;; ancestor, we don't intersect with lis3. So, it is
- ;; possible that elt is a file in auxdir1/2 but a
- ;; directory in auxdir3 Or elt may not exist in auxdir3 at
- ;; all. In the first case, we add a slash at the end. In
- ;; the second case, we insert nil.
- (setq elt (ediff-add-slash-if-directory auxdir3 elt))
- (if (file-exists-p (concat auxdir3 elt))
- (expand-file-name (concat auxdir3 elt)))))))
- common)))
- ;; return result
- (cons common-part difflist)
- ))
-
-;; find directory files that are under revision. Include subdirectories, since
-;; we may visit them recursively. DIR1 is the directory to inspect.
-;; MERGE-AUTOSTORE-DIR is the directory where to auto-store the results of
-;; merges. Can be nil.
-(defun ediff-get-directory-files-under-revision (jobname
- regexp dir1
- &optional merge-autostore-dir)
- (let (lis1 elt common auxdir1)
- (setq auxdir1 (file-name-as-directory dir1)
- lis1 (directory-files auxdir1 nil regexp))
-
- (if (ediff-nonempty-string-p merge-autostore-dir)
- (setq merge-autostore-dir
- (file-name-as-directory merge-autostore-dir)))
-
- (while lis1
- (setq elt (car lis1)
- lis1 (cdr lis1))
- ;; take files under revision control
- (cond ((file-directory-p (concat auxdir1 elt))
- (setq common
- (cons (ediff-add-slash-if-directory auxdir1 elt) common)))
- ((and (featurep 'vc-hooks) (vc-backend (concat auxdir1 elt)))
- (setq common (cons elt common)))
- ;; The following two are needed only if vc-hooks isn't loaded.
- ;; They won't recognize CVS files.
- ((file-exists-p (concat auxdir1 elt ",v"))
- (setq common (cons elt common)))
- ((file-exists-p (concat auxdir1 "RCS/" elt ",v"))
- (setq common (cons elt common)))
- ) ; cond
- ) ; while
-
- (setq common (delete "./" common)
- common (delete "../" common)
- common (delete "RCS" common)
- common (delete "CVS" common)
- )
-
- ;; copying is needed because sort sorts via side effects
- (setq common (sort (ediff-copy-list common) 'string-lessp))
-
- ;; return result
- (cons
- ;; header -- has 6 elements. Meta buffer is prepended later by
- ;; ediff-prepare-meta-buffer
- (ediff-make-new-meta-list-header regexp
- auxdir1 nil nil
- merge-autostore-dir nil)
- (mapcar (lambda (elt) (ediff-make-new-meta-list-element
- (expand-file-name (concat auxdir1 elt)) nil nil))
- common))
- ))
-
-
-;; If file groups selected by patterns will ever be implemented, this
-;; comparison function might become useful.
-;;;; uses external variables PAT1 PAT2 to compare str1/2
-;;;; patterns must be of the form ???*???? where ??? are strings of chars
-;;;; containing no *.
-;;(defun ediff-pattern= (str1 str2)
-;; (let (pos11 pos12 pos21 pos22 len1 len2)
-;; (setq pos11 0
-;; len (length epat1)
-;; pos12 len)
-;; (while (and (< pos11 len) (not (= (aref epat1 pos11) ?*)))
-;; (setq pos11 (1+ pos11)))
-;; (while (and (> pos12 0) (not (= (aref epat1 (1- pos12)) ?*)))
-;; (setq pos12 (1- pos12)))
-;;
-;; (setq pos21 0
-;; len (length epat2)
-;; pos22 len)
-;; (while (and (< pos21 len) (not (= (aref epat2 pos21) ?*)))
-;; (setq pos21 (1+ pos21)))
-;; (while (and (> pos22 0) (not (= (aref epat2 (1- pos22)) ?*)))
-;; (setq pos22 (1- pos22)))
-;;
-;; (if (and (> (length str1) pos12) (>= pos12 pos11) (> pos11 -1)
-;; (> (length str2) pos22) (>= pos22 pos21) (> pos21 -1))
-;; (string= (substring str1 pos11 pos12)
-;; (substring str2 pos21 pos22)))
-;; ))
-
-
-;; Prepare meta-buffer in accordance with the argument-function and
-;; redraw-function. Must return the created meta-buffer.
-(defun ediff-prepare-meta-buffer (action-func meta-list
- meta-buffer-name redraw-function
- jobname &optional startup-hooks)
- (let* ((meta-buffer-name
- (ediff-unique-buffer-name meta-buffer-name "*"))
- (meta-buffer (get-buffer-create meta-buffer-name)))
- (ediff-with-current-buffer meta-buffer
-
- ;; comes first
- (ediff-meta-mode)
-
- (setq ediff-meta-action-function action-func
- ediff-meta-redraw-function redraw-function
- ediff-metajob-name jobname
- ediff-meta-buffer meta-buffer)
-
- ;; comes after ediff-meta-action-function is set
- (ediff-setup-meta-map)
-
- (if (eq ediff-metajob-name 'ediff-registry)
- (progn
- (setq ediff-registry-buffer meta-buffer
- ediff-meta-list meta-list)
- ;; this func is used only from registry buffer, not from other
- ;; meta-buffs.
- (define-key
- ediff-meta-buffer-map "M" 'ediff-show-meta-buff-from-registry))
- ;; Initialize the meta list -- we don't do this for registry.
- (setq ediff-meta-list
- ;; add meta-buffer to the list header
- (cons (cons meta-buffer (car meta-list))
- (cdr meta-list))))
-
- (or (eq meta-buffer ediff-registry-buffer)
- (setq ediff-session-registry
- (cons meta-buffer ediff-session-registry)))
-
- ;; redraw-function uses ediff-meta-list
- (funcall redraw-function ediff-meta-list)
-
- ;; set read-only/non-modified
- (setq buffer-read-only t)
- (set-buffer-modified-p nil)
-
- (run-hooks 'startup-hooks)
-
- ;; Arrange to show directory contents differences
- ;; Must be after run startup-hooks, since ediff-dir-difference-list is
- ;; set inside these hooks
- (if (eq action-func 'ediff-filegroup-action)
- (progn
- ;; put meta buffer in (car ediff-dir-difference-list)
- (setq ediff-dir-difference-list
- (cons (cons meta-buffer (car ediff-dir-difference-list))
- (cdr ediff-dir-difference-list)))
-
- (or (ediff-one-filegroup-metajob jobname)
- (ediff-draw-dir-diffs ediff-dir-difference-list))
- (define-key
- ediff-meta-buffer-map "h" 'ediff-mark-for-hiding-at-pos)
- (define-key ediff-meta-buffer-map "x" 'ediff-hide-marked-sessions)
- (define-key
- ediff-meta-buffer-map "m" 'ediff-mark-for-operation-at-pos)
- (define-key ediff-meta-buffer-map "u" nil)
- (define-key
- ediff-meta-buffer-map "um" 'ediff-unmark-all-for-operation)
- (define-key
- ediff-meta-buffer-map "uh" 'ediff-unmark-all-for-hiding)
-
- (define-key ediff-meta-buffer-map
- [menu-bar ediff-meta-mode ediff-hide-marked-sessions]
- '(menu-item "Hide marked" ediff-hide-marked-sessions
- :help "Hide marked sessions. With prefix arg, unhide"))
-
- (define-key ediff-meta-buffer-map
- [menu-bar ediff-meta-mode ediff-mark-for-hiding-at-pos]
- '(menu-item "Mark for hiding" ediff-mark-for-hiding-at-pos
- :help "Mark session for hiding. With prefix arg, unmark"))
-
- (define-key ediff-meta-buffer-map
- [menu-bar ediff-meta-mode ediff-mark-for-operation-at-pos]
- '(menu-item "Mark for group operation" ediff-mark-for-operation-at-pos
- :help "Mark session for a group operation. With prefix arg, unmark"))
-
- (define-key ediff-meta-buffer-map
- [menu-bar ediff-meta-mode ediff-unmark-all-for-hiding]
- '(menu-item "Unmark all for hiding" ediff-unmark-all-for-hiding
- :help "Unmark all sessions marked for hiding"))
-
- (define-key ediff-meta-buffer-map
- [menu-bar ediff-meta-mode ediff-unmark-all-for-operation]
- '(menu-item "Unmark all for group operation" ediff-unmark-all-for-operation
- :help "Unmark all sessions marked for operation"))
-
- (cond ((ediff-collect-diffs-metajob jobname)
- (define-key ediff-meta-buffer-map
- [menu-bar ediff-meta-mode ediff-collect-custom-diffs]
- '(menu-item "Collect diffs" ediff-collect-custom-diffs
- :help "Collect custom diffs of marked sessions in buffer `*Ediff Multifile Diffs*'"))
- (define-key
- ediff-meta-buffer-map "P" 'ediff-collect-custom-diffs))
- ((ediff-patch-metajob jobname)
- (define-key ediff-meta-buffer-map
- [menu-bar ediff-meta-mode ediff-meta-show-patch]
- '(menu-item "Show multi-file patch" ediff-meta-show-patch
- :help "Show the multi-file patch associated with this group session"))
- (define-key
- ediff-meta-buffer-map "P" 'ediff-meta-show-patch)))
- (define-key ediff-meta-buffer-map "^" 'ediff-up-meta-hierarchy)
- (define-key ediff-meta-buffer-map "D" 'ediff-show-dir-diffs)
-
- (define-key ediff-meta-buffer-map
- [menu-bar ediff-meta-mode ediff-up-meta-hierarchy]
- '(menu-item "Go to parent session" ediff-up-meta-hierarchy
- :help "Go to the parent session group buffer"))
-
- (define-key ediff-meta-buffer-map
- [menu-bar ediff-meta-mode ediff-show-dir-diffs]
- '(menu-item "Diff directories" ediff-show-dir-diffs
- :help "Display differences among the directories involved in session group"))))
-
- (if (eq ediff-metajob-name 'ediff-registry)
- (run-hooks 'ediff-registry-setup-hook)
- (run-hooks 'ediff-after-session-group-setup-hook))
- ) ; eval in meta-buffer
- meta-buffer))
-
-;; Insert the activity marker for session SESSION in the meta buffer at point
-;; The activity marker is either SPC (untouched session), or + (active session,
-;; i.e., ediff is currently run in it), or - (finished session, i.e., we've ran
-;; ediff in it and then exited)
-(defun ediff-insert-session-activity-marker-in-meta-buffer (session)
- (insert
- (cond ((ediff-get-session-activity-marker session))
- ;; virgin session
- (t " "))))
-
-;; Insert session status at point. Status is either ?H (marked for hiding), or
-;; ?I (hidden or invalid), or ?* (meaning marked for an operation; currently,
-;; such op can only be checking for equality)), or SPC (meaning neither marked
-;; nor invalid)
-(defun ediff-insert-session-status-in-meta-buffer (session)
- (insert
- (cond ((ediff-get-session-status session)) ; session has status: ?H, ?I, ?*
- ;; normal session, no marks or hidings
- (t " "))))
-
-;; If NEW-MARKER is non-nil, use it to substitute the current activity marker
-;; in the meta buffer. If nil, use SPC
-(defun ediff-replace-session-activity-marker-in-meta-buffer (point new-marker)
- (let* ((overl (ediff-get-meta-overlay-at-pos point))
- (session-info (ediff-overlay-get overl 'ediff-meta-info))
- (activity-marker (ediff-get-session-activity-marker session-info))
- buffer-read-only)
- (or new-marker activity-marker (setq new-marker ?\s))
- (goto-char (ediff-overlay-start overl))
- (if (eq (char-after (point)) new-marker)
- () ; if marker shown in buffer is the same as new-marker, do nothing
- (insert new-marker)
- (delete-char 1)
- (set-buffer-modified-p nil))))
-
-;; If NEW-STATUS is non-nil, use it to substitute the current status marker in
-;; the meta buffer. If nil, use SPC
-(defun ediff-replace-session-status-in-meta-buffer (point new-status)
- (let* ((overl (ediff-get-meta-overlay-at-pos point))
- (session-info (ediff-overlay-get overl 'ediff-meta-info))
- (status (ediff-get-session-status session-info))
- buffer-read-only)
- (setq new-status (or new-status status ?\s))
- (goto-char (ediff-overlay-start overl))
- (forward-char 1) ; status is the second char in session record
- (if (eq (char-after (point)) new-status)
- () ; if marker shown in buffer is the same as new-marker, do nothing
- (insert new-status)
- (delete-char 1)
- (set-buffer-modified-p nil))))
-
-;; insert all file info in meta buffer for a given session
-(defun ediff-insert-session-info-in-meta-buffer (session-info sessionNum)
- (let ((f1 (ediff-get-session-objA session-info))
- (f2 (ediff-get-session-objB session-info))
- (f3 (ediff-get-session-objC session-info))
- (pt (point))
- (hidden (eq (ediff-get-session-status session-info) ?I)))
- ;; insert activity marker, i.e., SPC, - or +
- (ediff-insert-session-activity-marker-in-meta-buffer session-info)
- ;; insert session status, i.e., *, H
- (ediff-insert-session-status-in-meta-buffer session-info)
- (insert " Session " (int-to-string sessionNum) ":\n")
- (ediff-meta-insert-file-info1 f1)
- (ediff-meta-insert-file-info1 f2)
- (ediff-meta-insert-file-info1 f3)
- (ediff-set-meta-overlay pt (point) session-info sessionNum hidden)))
-
-
-;; this is a setup function for ediff-directories
-;; must return meta-buffer
-(defun ediff-redraw-directory-group-buffer (meta-list)
- ;; extract directories
- (let ((meta-buf (ediff-get-group-buffer meta-list))
- (empty t)
- (sessionNum 0)
- regexp elt merge-autostore-dir
- point tmp-list buffer-read-only)
- (ediff-with-current-buffer meta-buf
- (setq point (point))
- (erase-buffer)
- ;; delete phony overlays that used to represent sessions before the buff
- ;; was redrawn
- (if (featurep 'xemacs)
- (map-extents 'delete-extent)
- (mapc 'delete-overlay (overlays-in 1 1)))
-
- (setq regexp (ediff-get-group-regexp meta-list)
- merge-autostore-dir
- (ediff-get-group-merge-autostore-dir meta-list))
-
- (if ediff-verbose-help-enabled
- (progn
- (insert (format ediff-meta-buffer-verbose-message
- (ediff-abbrev-jobname ediff-metajob-name)))
-
- (cond ((ediff-collect-diffs-metajob)
- (insert
- " P:\tcollect custom diffs of all marked sessions\n"))
- ((ediff-patch-metajob)
- (insert
- " P:\tshow patch appropriately for the context (session or group)\n")))
- (insert
- " ^:\tshow parent session group\n")
- (or (ediff-one-filegroup-metajob)
- (insert
- " D:\tshow differences among directories\n"
- " ==:\tfor each session, show which files are identical\n"
- " =h:\tlike ==, but also marks sessions for hiding\n"
- " =m:\tlike ==, but also marks sessions for operation\n\n")))
- (insert (format ediff-meta-buffer-brief-message
- (ediff-abbrev-jobname ediff-metajob-name))))
-
- (insert "\n")
- (if (and (stringp regexp) (> (length regexp) 0))
- (insert
- (format "*** Filter-through regular expression: %s\n" regexp)))
- (ediff-insert-dirs-in-meta-buffer meta-list)
- (if (and ediff-autostore-merges (ediff-merge-metajob)
- (ediff-nonempty-string-p merge-autostore-dir))
- (insert (format
- "\nMerge results are automatically stored in:\n\t%s\n"
- merge-autostore-dir)))
- (insert "\n
- Size Last modified Name
- ----------------------------------------------
-
-")
-
- ;; discard info on directories and regexp
- (setq meta-list (cdr meta-list)
- tmp-list meta-list)
- (while (and tmp-list empty)
- (if (and (car tmp-list)
- (not (eq (ediff-get-session-status (car tmp-list)) ?I)))
- (setq empty nil))
- (setq tmp-list (cdr tmp-list)))
-
- (if empty
- (insert
- " ****** ****** This session group has no members\n"))
-
- ;; now organize file names like this:
- ;; use-mark sizeA dateA sizeB dateB filename
- ;; make sure directories are displayed with a trailing slash.
- (while meta-list
- (setq elt (car meta-list)
- meta-list (cdr meta-list)
- sessionNum (1+ sessionNum))
- (if (eq (ediff-get-session-status elt) ?I)
- ()
- (ediff-insert-session-info-in-meta-buffer elt sessionNum)))
- (set-buffer-modified-p nil)
- (goto-char point)
- meta-buf)))
-
-(defun ediff-update-markers-in-dir-meta-buffer (meta-list)
- (let ((meta-buf (ediff-get-group-buffer meta-list))
- session-info point overl buffer-read-only)
- (ediff-with-current-buffer meta-buf
- (setq point (point))
- (goto-char (point-min))
- (ediff-next-meta-item1)
- (while (not (bobp))
- (setq session-info (ediff-get-meta-info meta-buf (point) 'no-error)
- overl (ediff-get-meta-overlay-at-pos (point)))
- (if session-info
- (progn
- (cond ((eq (ediff-get-session-status session-info) ?I)
- ;; Do hiding
- (if overl (ediff-overlay-put overl 'invisible t)))
- ((and (eq (ediff-get-session-status session-info) ?H)
- overl (ediff-overlay-get overl 'invisible))
- ;; Do unhiding
- (ediff-overlay-put overl 'invisible nil))
- (t (ediff-replace-session-activity-marker-in-meta-buffer
- (point)
- (ediff-get-session-activity-marker session-info))
- (ediff-replace-session-status-in-meta-buffer
- (point)
- (ediff-get-session-status session-info))))))
- (ediff-next-meta-item1) ; advance to the next item
- ) ; end while
- (set-buffer-modified-p nil)
- (goto-char point))
- meta-buf))
-
-(defun ediff-update-session-marker-in-dir-meta-buffer (session-num)
- (let (buffer-meta-overlays session-info overl buffer-read-only)
- (setq overl
- (if (featurep 'xemacs)
- (map-extents
- (lambda (ext maparg)
- (if (and
- (ediff-overlay-get ext 'ediff-meta-info)
- (eq (ediff-overlay-get ext 'ediff-meta-session-number)
- session-num))
- ext)))
- ;; Emacs doesn't have map-extents, so try harder
- ;; Splice overlay lists to get all buffer overlays
- (setq buffer-meta-overlays (overlay-lists)
- buffer-meta-overlays (append (car buffer-meta-overlays)
- (cdr buffer-meta-overlays)))
- (car
- (delq nil
- (mapcar
- (lambda (overl)
- (if (and
- (ediff-overlay-get overl 'ediff-meta-info)
- (eq (ediff-overlay-get
- overl 'ediff-meta-session-number)
- session-num))
- overl))
- buffer-meta-overlays)))))
- (or overl
- (error
- "Bug in ediff-update-session-marker-in-dir-meta-buffer: no overlay with given number %S"
- session-num))
- (setq session-info (ediff-overlay-get overl 'ediff-meta-info))
- (goto-char (ediff-overlay-start overl))
- (ediff-replace-session-activity-marker-in-meta-buffer
- (point)
- (ediff-get-session-activity-marker session-info))
- (ediff-replace-session-status-in-meta-buffer
- (point)
- (ediff-get-session-status session-info)))
- (ediff-next-meta-item1))
-
-
-
-;; Check if this is a problematic session.
-;; Return nil if not. Otherwise, return symbol representing the problem
-;; At present, problematic sessions occur only in -with-ancestor comparisons
-;; when the ancestor is a directory rather than a file, or when there is no
-;; suitable ancestor file in the ancestor directory
-(defun ediff-problematic-session-p (session)
- (let ((f1 (ediff-get-session-objA-name session))
- (f2 (ediff-get-session-objB-name session))
- (f3 (ediff-get-session-objC-name session)))
- (cond ((and (stringp f1) (not (file-directory-p f1))
- (stringp f2) (not (file-directory-p f2))
- ;; either invalid file name or a directory
- (or (not (stringp f3)) (file-directory-p f3))
- (ediff-ancestor-metajob))
- ;; more may be added later
- 'ancestor-is-dir)
- (t nil))))
-
-(defun ediff-meta-insert-file-info1 (fileinfo)
- (let ((fname (car fileinfo))
- (feq (ediff-get-file-eqstatus fileinfo))
- (max-filename-width (if ediff-meta-truncate-filenames
- (- (window-width) 41)
- 500))
- file-modtime file-size)
- (cond ((not (stringp fname)) (setq file-size -2)) ; file doesn't exits
- ((ediff-listable-file fname)
- (if (file-exists-p fname)
- ;; set real size and modtime
- (setq file-size (ediff-file-size fname)
- file-modtime (ediff-file-modtime fname))
- (setq file-size -2))) ; file doesn't exist
- ( t (setq file-size -1))) ; remote file
- (if (stringp fname)
- (insert
- (format
- "%s %s %-20s %s\n"
- (if feq "=" " ") ; equality indicator
- (format "%10s" (cond ((= file-size -1) "--")
- ((< file-size -1) "--")
- (t file-size)))
- (cond ((= file-size -1) "*remote file*")
- ((< file-size -1) "*file doesn't exist*")
- (t (ediff-format-date (decode-time file-modtime))))
-
- ;; dir names in meta lists have training slashes, so we just
- ;; abbreviate the file name, if file exists
- (if (and (not (stringp fname)) (< file-size -1))
- "-------" ; file doesn't exist
- (ediff-truncate-string-left
- (ediff-abbreviate-file-name fname)
- max-filename-width)))))))
-
-(defconst ediff-months '((1 . "Jan") (2 . "Feb") (3 . "Mar") (4 . "Apr")
- (5 . "May") (6 . "Jun") (7 . "Jul") (8 . "Aug")
- (9 . "Sep") (10 . "Oct") (11 . "Nov") (12 . "Dec"))
- "Months' associative array.")
-
-;; returns 2char string
-(defsubst ediff-fill-leading-zero (num)
- (if (< num 10)
- (format "0%d" num)
- (number-to-string num)))
-
-;; TIME is like the output of decode-time
-(defun ediff-format-date (time)
- (format "%s %2d %4d %s:%s:%s"
- (cdr (assoc (nth 4 time) ediff-months)) ; month
- (nth 3 time) ; day
- (nth 5 time) ; year
- (ediff-fill-leading-zero (nth 2 time)) ; hour
- (ediff-fill-leading-zero (nth 1 time)) ; min
- (ediff-fill-leading-zero (nth 0 time)) ; sec
- ))
-
-;; Draw the directories
-(defun ediff-insert-dirs-in-meta-buffer (meta-list)
- (let* ((dir1 (ediff-abbreviate-file-name (ediff-get-group-objA meta-list)))
- (dir2 (ediff-get-group-objB meta-list))
- (dir2 (if (stringp dir2) (ediff-abbreviate-file-name dir2)))
- (dir3 (ediff-get-group-objC meta-list))
- (dir3 (if (stringp dir3) (ediff-abbreviate-file-name dir3))))
- (insert "*** Directory A: " dir1 "\n")
- (if dir2 (insert "*** Directory B: " dir2 "\n"))
- (if dir3 (insert "*** Directory C: " dir3 "\n"))
- (insert "\n")))
-
-(defun ediff-draw-dir-diffs (diff-list &optional buf-name)
- (if (null diff-list) (error "Lost difference info on these directories"))
- (setq buf-name
- (or buf-name
- (ediff-unique-buffer-name "*Ediff File Group Differences" "*")))
- (let* ((regexp (ediff-get-group-regexp diff-list))
- (dir1 (ediff-abbreviate-file-name (ediff-get-group-objA diff-list)))
- (dir2 (ediff-abbreviate-file-name (ediff-get-group-objB diff-list)))
- (dir3 (ediff-get-group-objC diff-list))
- (dir3 (if (stringp dir3) (ediff-abbreviate-file-name dir3)))
- (meta-buf (ediff-get-group-buffer diff-list))
- (underline (make-string 26 ?-))
- file membership-code saved-point
- buffer-read-only)
- ;; skip the directory part
- (setq diff-list (cdr diff-list))
- (setq ediff-dir-diffs-buffer (get-buffer-create buf-name))
- (ediff-with-current-buffer ediff-dir-diffs-buffer
- (setq saved-point (point))
- (use-local-map ediff-dir-diffs-buffer-map)
- (erase-buffer)
- (setq ediff-meta-buffer meta-buf)
- (insert "\t\t*** Directory Differences ***\n")
- (insert "
-Useful commands:
- C,button2: over file name -- copy this file to directory that doesn't have it
- q: hide this buffer
- n,SPC: next line
- p,DEL: previous line\n\n")
-
- (insert (format "\n*** Directory A: %s\n" dir1))
- (if dir2 (insert (format "*** Directory B: %s\n" dir2)))
- (if dir3 (insert (format "*** Directory C: %s\n" dir3)))
- (if (and (stringp regexp) (> (length regexp) 0))
- (insert
- (format "*** Filter-through regular expression: %s\n" regexp)))
- (insert "\n")
- (insert (format "\n%-27s%-26s" "Directory A" "Directory B"))
- (if dir3
- (insert (format " %-25s\n" "Directory C"))
- (insert "\n"))
- (insert (format "%s%s" underline underline))
- (if (stringp dir3)
- (insert (format "%s\n\n" underline))
- (insert "\n\n"))
-
- (if (null diff-list)
- (insert "\n\t*** No differences ***\n"))
-
- (while diff-list
- (setq file (car (car diff-list))
- membership-code (cdr (car diff-list))
- diff-list (cdr diff-list))
- (if (= (mod membership-code ediff-membership-code1) 0) ; dir1
- (let ((beg (point)))
- (insert (format "%-27s"
- (ediff-truncate-string-left
- (ediff-abbreviate-file-name
- (if (file-directory-p (concat dir1 file))
- (file-name-as-directory file)
- file))
- 24)))
- ;; format of meta info in the dir-diff-buffer:
- ;; (filename-tail filename-full otherdir1 otherdir2 otherdir3)
- (ediff-set-meta-overlay
- beg (point)
- (list meta-buf file (concat dir1 file) dir1 dir2 dir3)))
- (insert (format "%-27s" "---")))
- (if (= (mod membership-code ediff-membership-code2) 0) ; dir2
- (let ((beg (point)))
- (insert (format "%-26s"
- (ediff-truncate-string-left
- (ediff-abbreviate-file-name
- (if (file-directory-p (concat dir2 file))
- (file-name-as-directory file)
- file))
- 24)))
- (ediff-set-meta-overlay
- beg (point)
- (list meta-buf file (concat dir2 file) dir1 dir2 dir3)))
- (insert (format "%-26s" "---")))
- (if (stringp dir3)
- (if (= (mod membership-code ediff-membership-code3) 0) ; dir3
- (let ((beg (point)))
- (insert (format " %-25s"
- (ediff-truncate-string-left
- (ediff-abbreviate-file-name
- (if (file-directory-p (concat dir3 file))
- (file-name-as-directory file)
- file))
- 24)))
- (ediff-set-meta-overlay
- beg (point)
- (list meta-buf file (concat dir3 file) dir1 dir2 dir3)))
- (insert (format " %-25s" "---"))))
- (insert "\n"))
- (setq buffer-read-only t)
- (set-buffer-modified-p nil)
- (goto-char saved-point)) ; end eval in diff buffer
- ))
-
-(defun ediff-bury-dir-diffs-buffer ()
- "Bury the directory difference buffer. Display the meta buffer instead."
- (interactive)
- ;; ediff-meta-buffer is set in ediff-draw-dir-diffs so the directory
- ;; difference buffer remembers the meta buffer
- (let ((buf ediff-meta-buffer)
- wind)
- (ediff-kill-buffer-carefully ediff-dir-diffs-buffer)
- (if (setq wind (ediff-get-visible-buffer-window buf))
- (select-window wind)
- (set-window-buffer (selected-window) buf))))
-
-;; executes in dir session group buffer
-;; show buffer differences
-(defun ediff-show-dir-diffs ()
- "Display differences among the directories involved in session group."
- (interactive)
- (if (ediff-one-filegroup-metajob)
- (error "This command is inapplicable in the present context"))
- (or (ediff-buffer-live-p ediff-dir-diffs-buffer)
- (ediff-draw-dir-diffs ediff-dir-difference-list))
- (let ((buf ediff-dir-diffs-buffer))
- (other-window 1)
- (set-window-buffer (selected-window) buf)
- (goto-char (point-min))))
-
-;; Format of meta info in dir-diff-buffer:
-;; (filename-tail filename-full otherdir1 otherdir2)
-(defun ediff-dir-diff-copy-file ()
- "Copy file described at point to directories where this file is missing."
- (interactive)
- (let* ((pos (ediff-event-point last-command-event))
- (info (ediff-get-meta-info (current-buffer) pos 'noerror))
- (meta-buf (car info))
- (file-tail (nth 1 info))
- (file-abs (nth 2 info))
- (otherdir1 (nth 3 info))
- (otherfile1 (if otherdir1 (concat otherdir1 file-tail)))
- (otherdir2 (nth 4 info))
- (otherfile2 (if otherdir2 (concat otherdir2 file-tail)))
- (otherdir3 (nth 5 info))
- (otherfile3 (if otherdir3 (concat otherdir3 file-tail)))
- meta-list dir-diff-list
- )
- (if (null info)
- (error "No file suitable for copying described at this location"))
- (ediff-with-current-buffer meta-buf
- (setq meta-list ediff-meta-list
- dir-diff-list ediff-dir-difference-list))
-
- ;; copy file to directories where it doesn't exist, update
- ;; ediff-dir-difference-list and redisplay
- (mapc
- (lambda (otherfile-struct)
- (let ((otherfile (car otherfile-struct))
- (file-mem-code (cdr otherfile-struct)))
- (if otherfile
- (or (file-exists-p otherfile)
- (if (y-or-n-p
- (format "Copy %s to %s? " file-abs otherfile))
- (let* ((file-diff-record (assoc file-tail dir-diff-list))
- (new-mem-code
- (* (cdr file-diff-record) file-mem-code)))
- (copy-file file-abs otherfile)
- (setcdr file-diff-record new-mem-code)
- (ediff-draw-dir-diffs dir-diff-list (buffer-name))
- (sit-for 0)
- ;; if file is in all three dirs or in two dirs and only
- ;; two dirs are involved, delete this file's record
- (if (or (= new-mem-code ediff-product-of-memcodes)
- (and (> new-mem-code ediff-membership-code3)
- (null otherfile3)))
- (delq file-diff-record dir-diff-list))
- ))))
- ))
- ;; 2,3,5 are numbers used to encode membership of a file in
- ;; dir1/2/3. See ediff-intersect-directories.
- (list (cons otherfile1 2) (cons otherfile2 3) (cons otherfile3 5)))
-
- (if (and (file-exists-p otherfile1)
- (file-exists-p otherfile2)
- (or (not otherfile3) (file-exists-p otherfile3)))
- ;; update ediff-meta-list by direct modification
- (nconc meta-list
- (list (ediff-make-new-meta-list-element
- (expand-file-name otherfile1)
- (expand-file-name otherfile2)
- (if otherfile3
- (expand-file-name otherfile3)))))
- )
- (ediff-update-meta-buffer meta-buf 'must-redraw)
- ))
-
-(defun ediff-up-meta-hierarchy ()
- "Go to the parent session group buffer."
- (interactive)
- (if (ediff-buffer-live-p ediff-parent-meta-buffer)
- (ediff-show-meta-buffer
- ediff-parent-meta-buffer ediff-meta-session-number)
- (error "This session group has no parent")))
-
-
-;; argument is ignored
-(defun ediff-redraw-registry-buffer (&optional ignore)
- (ediff-with-current-buffer ediff-registry-buffer
- (let ((point (point))
- elt bufAname bufBname bufCname cur-diff total-diffs pt
- job-name meta-list registry-list buffer-read-only)
- (erase-buffer)
- ;; delete phony overlays that used to represent sessions before the buff
- ;; was redrawn
- (if (featurep 'xemacs)
- (map-extents 'delete-extent)
- (mapc 'delete-overlay (overlays-in 1 1)))
-
- (insert "This is a registry of all active Ediff sessions.
-
-Useful commands:
- button2, `v', RET over a session record: switch to that session
- M over a session record: display the associated session group
- R in any Ediff session: display session registry
- n,SPC: next session
- p,DEL: previous session
- E: browse Ediff on-line manual
- q: bury registry
-
-
-\t\tActive Ediff Sessions:
-\t\t----------------------
-
-")
- ;; purge registry list from dead buffers
- (mapc (lambda (elt)
- (if (not (ediff-buffer-live-p elt))
- (setq ediff-session-registry
- (delq elt ediff-session-registry))))
- ediff-session-registry)
-
- (if (null ediff-session-registry)
- (insert " ******* No active Ediff sessions *******\n"))
-
- (setq registry-list ediff-session-registry)
- (while registry-list
- (setq elt (car registry-list)
- registry-list (cdr registry-list))
-
- (if (ediff-buffer-live-p elt)
- (if (ediff-with-current-buffer elt
- (setq job-name ediff-metajob-name
- meta-list ediff-meta-list)
- (and ediff-metajob-name
- (not (eq ediff-metajob-name 'ediff-registry))))
- (progn
- (setq pt (point))
- (insert (format " *group*\t%s: %s\n"
- (buffer-name elt)
- (ediff-abbrev-jobname job-name)))
- (insert (format "\t\t %s %s %s\n"
- (ediff-abbreviate-file-name
- (ediff-get-group-objA meta-list))
- (ediff-abbreviate-file-name
- (if (stringp
- (ediff-get-group-objB meta-list))
- (ediff-get-group-objB meta-list)
- ""))
- (ediff-abbreviate-file-name
- (if (stringp
- (ediff-get-group-objC meta-list))
- (ediff-get-group-objC meta-list)
- ""))))
- (ediff-set-meta-overlay pt (point) elt))
- (progn
- (ediff-with-current-buffer elt
- (setq bufAname (if (ediff-buffer-live-p ediff-buffer-A)
- (buffer-name ediff-buffer-A)
- "!!!killed buffer!!!")
- bufBname (if (ediff-buffer-live-p ediff-buffer-B)
- (buffer-name ediff-buffer-B)
- "!!!killed buffer!!!")
- bufCname (cond ((not (ediff-3way-job))
- "")
- ((ediff-buffer-live-p ediff-buffer-C)
- (buffer-name ediff-buffer-C))
- (t "!!!killed buffer!!!")))
- (setq total-diffs (format "%-4d" ediff-number-of-differences)
- cur-diff
- (cond ((= ediff-current-difference -1) " _")
- ((= ediff-current-difference
- ediff-number-of-differences)
- " $")
- (t (format
- "%4d" (1+ ediff-current-difference))))
- job-name ediff-job-name))
- ;; back in the meta buf
- (setq pt (point))
- (insert cur-diff "/" total-diffs "\t"
- (buffer-name elt)
- (format ": %s" (ediff-abbrev-jobname job-name)))
- (insert
- "\n\t\t " bufAname " " bufBname " " bufCname "\n")
- (ediff-set-meta-overlay pt (point) elt))))
- ) ; while
- (set-buffer-modified-p nil)
- (goto-char point)
- )))
-
-;; Sets overlay around a meta record with 'ediff-meta-info property PROP
-;; If optional SESSION-NUMBER, make it a property of the overlay,
-;; ediff-meta-session-number
-;; PROP is either the ctl or meta buffer (used when we work with the registry)
-;; or a session meta descriptor of the form
-;; (SESSION-CTL-BUFFER STATUS OBJA OBJB OBJC)
-(defun ediff-set-meta-overlay (b e prop &optional session-number hidden)
- (let (overl)
- (setq overl (ediff-make-overlay b e))
- (if (featurep 'emacs)
- (ediff-overlay-put overl 'mouse-face 'highlight)
- (ediff-overlay-put overl 'highlight t))
- (ediff-overlay-put overl 'ediff-meta-info prop)
- (ediff-overlay-put overl 'invisible hidden)
- (ediff-overlay-put overl 'follow-link t)
- (if (numberp session-number)
- (ediff-overlay-put overl 'ediff-meta-session-number session-number))))
-
-(defun ediff-mark-for-hiding-at-pos (unmark)
- "Mark session for hiding. With prefix arg, unmark."
- (interactive "P")
- (let* ((pos (ediff-event-point last-command-event))
- (meta-buf (ediff-event-buffer last-command-event))
- ;; ediff-get-meta-info gives error if meta-buf or pos are invalid
- (info (ediff-get-meta-info meta-buf pos))
- (session-number (ediff-get-session-number-at-pos pos)))
- (ediff-mark-session-for-hiding info unmark)
- (ediff-next-meta-item 1)
- (save-excursion
- (ediff-update-meta-buffer meta-buf nil session-number))
- ))
-
-;; Returns whether session was marked or unmarked
-(defun ediff-mark-session-for-hiding (info unmark)
- (let ((session-buf (ediff-get-session-buffer info))
- ignore)
- (cond ((eq unmark 'mark) (setq unmark nil))
- ((eq (ediff-get-session-status info) ?H) (setq unmark t))
- (unmark ; says unmark, but the marker is different from H
- (setq ignore t)))
- (cond (ignore)
- (unmark (ediff-set-session-status info nil))
-;;; (if (ediff-buffer-live-p session-buf)
-;;; (error "Can't hide active session, %s" (buffer-name session-buf)))
- (t (ediff-set-session-status info ?H))))
- unmark)
-
-
-(defun ediff-mark-for-operation-at-pos (unmark)
- "Mark session for a group operation. With prefix arg, unmark."
- (interactive "P")
- (let* ((pos (ediff-event-point last-command-event))
- (meta-buf (ediff-event-buffer last-command-event))
- ;; ediff-get-meta-info gives error if meta-buf or pos are invalid
- (info (ediff-get-meta-info meta-buf pos))
- (session-number (ediff-get-session-number-at-pos pos)))
- (ediff-mark-session-for-operation info unmark)
- (ediff-next-meta-item 1)
- (save-excursion
- (ediff-update-meta-buffer meta-buf nil session-number))
- ))
-
-
-;; returns whether session was unmarked.
-;; remember: this is a toggle op
-(defun ediff-mark-session-for-operation (info unmark)
- (let (ignore)
- (cond ((eq unmark 'mark) (setq unmark nil))
- ((eq (ediff-get-session-status info) ?*) (setq unmark t))
- (unmark ; says unmark, but the marker is different from *
- (setq ignore t)))
- (cond (ignore)
- (unmark (ediff-set-session-status info nil))
- (t (ediff-set-session-status info ?*))))
- unmark)
-
-
-(defun ediff-hide-marked-sessions (unhide)
- "Hide marked sessions. With prefix arg, unhide."
- (interactive "P")
- (let ((grp-buf (ediff-get-group-buffer ediff-meta-list))
- (meta-list (cdr ediff-meta-list))
- (from (if unhide ?I ?H))
- (to (if unhide ?H ?I))
- (numMarked 0)
- active-sessions-exist session-buf elt)
- (while meta-list
- (setq elt (car meta-list)
- meta-list (cdr meta-list)
- session-buf (ediff-get-session-buffer elt))
-
- (if (eq (ediff-get-session-status elt) from)
- (progn
- (setq numMarked (1+ numMarked))
- (if (and (eq to ?I) (buffer-live-p session-buf))
- ;; shouldn't hide active sessions
- (setq active-sessions-exist t)
- (ediff-set-session-status elt to)))))
- (if (> numMarked 0)
- (ediff-update-meta-buffer grp-buf 'must-redraw)
- (beep)
- (if unhide
- (message "Nothing to reveal...")
- (message "Nothing to hide...")))
- (if active-sessions-exist
- (message "Note: Ediff didn't hide active sessions!"))
- ))
-
-;; Apply OPERATION to marked sessions. Operation expects one argument of type
-;; meta-list member (not the first one), i.e., a regular session description.
-;; Returns number of marked sessions on which operation was performed
-(defun ediff-operate-on-marked-sessions (operation)
- (let ((grp-buf (ediff-get-group-buffer ediff-meta-list))
- (meta-list (cdr ediff-meta-list))
- (marksym ?*)
- (numMarked 0)
- (sessionNum 0)
- (diff-buffer ediff-meta-diff-buffer)
- session-buf elt)
- (while meta-list
- (setq elt (car meta-list)
- meta-list (cdr meta-list)
- sessionNum (1+ sessionNum))
- (cond ((eq (ediff-get-session-status elt) marksym)
- (save-excursion
- (setq numMarked (1+ numMarked))
- (funcall operation elt sessionNum)))
- ;; The following goes into a session represented by a subdirectory
- ;; and applies operation to marked sessions there
- ((and (ediff-meta-session-p elt)
- (ediff-buffer-live-p
- (setq session-buf (ediff-get-session-buffer elt))))
- (setq numMarked
- (+ numMarked
- (ediff-with-current-buffer session-buf
- ;; pass meta-diff along
- (setq ediff-meta-diff-buffer diff-buffer)
- ;; collect diffs in child group
- (ediff-operate-on-marked-sessions operation)))))))
- (ediff-update-meta-buffer grp-buf 'must-redraw) ; just in case
- numMarked
- ))
-
-(defun ediff-append-custom-diff (session sessionNum)
- (or (ediff-collect-diffs-metajob)
- (error "Can't compute multifile patch in this context"))
- (let ((session-buf (ediff-get-session-buffer session))
- (meta-diff-buff ediff-meta-diff-buffer)
- (metajob ediff-metajob-name)
- tmp-buf custom-diff-buf)
- (if (ediff-buffer-live-p session-buf)
- (ediff-with-current-buffer session-buf
- (if (eq ediff-control-buffer session-buf) ; individual session
- (progn
- (ediff-compute-custom-diffs-maybe)
- (setq custom-diff-buf ediff-custom-diff-buffer)))))
-
- (or (ediff-buffer-live-p meta-diff-buff)
- (error "Ediff: something wrong--killed multiple diff's buffer"))
-
- (cond ((ediff-buffer-live-p custom-diff-buf)
- ;; for live session buffers we do them first because the user may
- ;; have changed them with respect to the underlying files
- (with-current-buffer meta-diff-buff
- (goto-char (point-max))
- (insert-buffer-substring custom-diff-buf)
- (insert "\n")))
- ;; if ediff session is not live, run diff directly on the files
- ((memq metajob '(ediff-directories
- ediff-merge-directories
- ediff-merge-directories-with-ancestor))
- ;; get diffs by calling shell command on ediff-custom-diff-program
- (with-current-buffer
- (setq tmp-buf (get-buffer-create ediff-tmp-buffer))
- (erase-buffer)
- (shell-command
- (format
- "%s %s %s %s"
- (shell-quote-argument ediff-custom-diff-program)
- ediff-custom-diff-options
- (shell-quote-argument (ediff-get-session-objA-name session))
- (shell-quote-argument (ediff-get-session-objB-name session))
- )
- t)
- )
- (with-current-buffer meta-diff-buff
- (goto-char (point-max))
- (insert-buffer-substring tmp-buf)
- (insert "\n")))
- (t
- (ediff-kill-buffer-carefully meta-diff-buff)
- (error "Session %d compares versions of file. Such session must be active to enable multifile patch collection" sessionNum )))
- ))
-
-(defun ediff-collect-custom-diffs ()
- "Collect custom diffs of marked sessions in buffer `*Ediff Multifile Diffs*'.
-This operation is defined only for `ediff-directories' and
-`ediff-directory-revisions', since its intent is to produce
-multifile patches. For `ediff-directory-revisions', we insist that
-all marked sessions must be active."
- (interactive)
- (let ((coding-system-for-read ediff-coding-system-for-read))
- (or (ediff-buffer-live-p ediff-meta-diff-buffer)
- (setq ediff-meta-diff-buffer
- (get-buffer-create
- (ediff-unique-buffer-name "*Ediff Multifile Diffs" "*"))))
- (ediff-with-current-buffer ediff-meta-diff-buffer
- (setq buffer-read-only nil)
- (erase-buffer))
- (if (> (ediff-operate-on-marked-sessions 'ediff-append-custom-diff) 0)
- ;; did something
- (progn
- (display-buffer ediff-meta-diff-buffer 'not-this-window)
- (ediff-with-current-buffer ediff-meta-diff-buffer
- (set-buffer-modified-p nil)
- (setq buffer-read-only t))
- (if (fboundp 'diff-mode)
- (with-current-buffer ediff-meta-diff-buffer
- (diff-mode))))
- (beep)
- (message "No marked sessions found"))))
-
-(defun ediff-meta-show-patch ()
- "Show the multi-file patch associated with this group session."
- (interactive)
- (let* ((pos (ediff-event-point last-command-event))
- (meta-buf (ediff-event-buffer last-command-event))
- (info (ediff-get-meta-info meta-buf pos 'noerror))
- (patchbuffer ediff-meta-patchbufer))
- (if (ediff-buffer-live-p patchbuffer)
- (ediff-with-current-buffer patchbuffer
- (save-restriction
- (if (not info)
- (widen)
- (narrow-to-region
- (ediff-get-session-objB-name info)
- (ediff-get-session-objC-name info)))
- (set-buffer (get-buffer-create ediff-tmp-buffer))
- (erase-buffer)
- (insert-buffer-substring patchbuffer)
- (goto-char (point-min))
- (display-buffer ediff-tmp-buffer 'not-this-window)
- ))
- (error "The patch buffer wasn't found"))))
-
-
-;; This function executes in meta buffer. It knows where event happened.
-(defun ediff-filegroup-action ()
- "Execute appropriate action for a selected session."
- (interactive)
- (let* ((pos (ediff-event-point last-command-event))
- (meta-buf (ediff-event-buffer last-command-event))
- ;; ediff-get-meta-info gives error if meta-buf or pos are invalid
- (info (ediff-get-meta-info meta-buf pos))
- (session-buf (ediff-get-session-buffer info))
- (session-number (ediff-get-session-number-at-pos pos meta-buf))
- (default-regexp (eval ediff-default-filtering-regexp))
- merge-autostore-dir file1 file2 file3 regexp)
-
- (setq file1 (ediff-get-session-objA-name info)
- file2 (ediff-get-session-objB-name info)
- file3 (ediff-get-session-objC-name info))
-
- ;; make sure we don't start on hidden sessions
- ;; ?H means marked for hiding. ?I means invalid (hidden).
- (if (memq (ediff-get-session-status info) '(?I))
- (progn
- (beep)
- (if (y-or-n-p "This session is marked as hidden, unmark? ")
- (progn
- (ediff-set-session-status info nil)
- (ediff-update-meta-buffer meta-buf nil session-number))
- (error "Aborted"))))
-
- (ediff-with-current-buffer meta-buf
- (setq merge-autostore-dir
- (ediff-get-group-merge-autostore-dir ediff-meta-list))
- (goto-char pos) ; if the user clicked on session--move point there
- ;; First handle sessions involving directories (which are themselves
- ;; session groups)
- ;; After that handle individual sessions
- (cond ((ediff-meta-session-p info)
- ;; do ediff/ediff-merge on subdirectories
- (if (ediff-buffer-live-p session-buf)
- (ediff-show-meta-buffer session-buf)
- (setq regexp
- (read-string
- (if (stringp default-regexp)
- (format
- "Filter through regular expression (default %s): "
- default-regexp)
- "Filter through regular expression: ")
- nil
- 'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp)))
- (ediff-directories-internal
- file1 file2 file3 regexp
- ediff-session-action-function
- ediff-metajob-name
- ;; make it update (car info) after startup
- `(list (lambda ()
- ;; child session group should know its parent
- (setq ediff-parent-meta-buffer
- (quote ,ediff-meta-buffer)
- ediff-meta-session-number
- ,session-number)
- ;; and parent will know its child
- (setcar (quote ,info) ediff-meta-buffer))))))
-
- ;; Do ediff-revision on a subdirectory
- ((and (ediff-one-filegroup-metajob)
- (ediff-revision-metajob)
- (file-directory-p file1))
- (if (ediff-buffer-live-p session-buf)
- (ediff-show-meta-buffer session-buf)
- (setq regexp (read-string "Filter through regular expression: "
- nil 'ediff-filtering-regexp-history))
- (ediff-directory-revisions-internal
- file1 regexp
- ediff-session-action-function ediff-metajob-name
- ;; make it update (car info) after startup
- `(list (lambda ()
- ;; child session group should know its parent and
- ;; its number
- (setq ediff-parent-meta-buffer
- (quote ,ediff-meta-buffer)
- ediff-meta-session-number
- ,session-number)
- ;; and parent will know its child
- (setcar (quote ,info) ediff-meta-buffer))))))
-
- ;; From here on---only individual session handlers
-
- ;; handle an individual session with a live control buffer
- ((ediff-buffer-live-p session-buf)
- (ediff-with-current-buffer session-buf
- (setq ediff-mouse-pixel-position (mouse-pixel-position))
- (ediff-recenter 'no-rehighlight)))
-
- ((ediff-problematic-session-p info)
- (beep)
- (if (y-or-n-p
- "This session has no ancestor. Merge without the ancestor? ")
- (ediff-merge-files
- file1 file2
- ;; provide startup hooks
- `(list (lambda ()
- (add-hook
- 'ediff-after-quit-hook-internal
- (lambda ()
- (if (ediff-buffer-live-p ,(current-buffer))
- (ediff-show-meta-buffer
- ,(current-buffer) ,session-number)))
- nil 'local)
- (setq ediff-meta-buffer ,(current-buffer)
- ediff-meta-session-number
- ,session-number)
- (setq ediff-merge-store-file
- ,(if (ediff-nonempty-string-p
- merge-autostore-dir)
- (concat
- merge-autostore-dir
- ediff-merge-filename-prefix
- (file-name-nondirectory file1))
- ))
- ;; make ediff-startup pass
- ;; ediff-control-buffer back to the meta
- ;; level; see below
- (setcar
- (quote ,info) ediff-control-buffer))))
- (error "Aborted")))
- ((ediff-one-filegroup-metajob) ; needs 1 file arg
- (funcall ediff-session-action-function
- file1
- ;; provide startup hooks
- `(list (lambda ()
- (add-hook
- 'ediff-after-quit-hook-internal
- (lambda ()
- (if (ediff-buffer-live-p
- ,(current-buffer))
- (ediff-show-meta-buffer
- ,(current-buffer)
- ,session-number)))
- nil 'local)
- (setq ediff-meta-buffer ,(current-buffer)
- ediff-meta-session-number
- ,session-number)
- (setq ediff-merge-store-file
- ,(if (ediff-nonempty-string-p
- merge-autostore-dir)
- (concat
- merge-autostore-dir
- ediff-merge-filename-prefix
- (file-name-nondirectory file1))) )
- ;; make ediff-startup pass
- ;; ediff-control-buffer back to the meta
- ;; level; see below
- (setcar
- (quote ,info) ediff-control-buffer)))))
- ((not (ediff-metajob3)) ; need 2 file args
- (funcall ediff-session-action-function
- file1 file2
- ;; provide startup hooks
- `(list (lambda ()
- (add-hook
- 'ediff-after-quit-hook-internal
- (lambda ()
- (if (ediff-buffer-live-p
- ,(current-buffer))
- (ediff-show-meta-buffer
- ,(current-buffer)
- ,session-number)))
- nil 'local)
- (setq ediff-meta-buffer ,(current-buffer)
- ediff-meta-session-number
- ,session-number)
- (setq ediff-merge-store-file
- ,(if (ediff-nonempty-string-p
- merge-autostore-dir)
- (concat
- merge-autostore-dir
- ediff-merge-filename-prefix
- (file-name-nondirectory file1))) )
- ;; make ediff-startup pass
- ;; ediff-control-buffer back to the meta
- ;; level; see below
- (setcar
- (quote ,info) ediff-control-buffer)))))
- ((ediff-metajob3) ; need 3 file args
- (funcall ediff-session-action-function
- file1 file2 file3
- ;; arrange startup hooks
- `(list (lambda ()
- (add-hook
- 'ediff-after-quit-hook-internal
- (lambda ()
- (if (ediff-buffer-live-p
- ,(current-buffer))
- (ediff-show-meta-buffer
- ,(current-buffer)
- ,session-number)))
- nil 'local)
- (setq ediff-merge-store-file
- ,(if (ediff-nonempty-string-p
- merge-autostore-dir)
- (concat
- merge-autostore-dir
- ediff-merge-filename-prefix
- (file-name-nondirectory file1))) )
- (setq ediff-meta-buffer , (current-buffer)
- ediff-meta-session-number
- ,session-number)
- ;; this arranges that ediff-startup will pass
- ;; the value of ediff-control-buffer back to
- ;; the meta level, to the record in the meta
- ;; list containing the information about the
- ;; session associated with that
- ;; ediff-control-buffer
- (setcar
- (quote ,info) ediff-control-buffer)))))
- ) ; cond
- ) ; eval in meta-buf
- ))
-
-(defun ediff-registry-action ()
- "Switch to a selected session."
- (interactive)
- (let* ((pos (ediff-event-point last-command-event))
- (buf (ediff-event-buffer last-command-event))
- (ctl-buf (ediff-get-meta-info buf pos)))
-
- (if (ediff-buffer-live-p ctl-buf)
- ;; check if this is ediff-control-buffer or ediff-meta-buffer
- (if (ediff-with-current-buffer ctl-buf
- (eq (key-binding "q") 'ediff-quit-meta-buffer))
- ;; it's a meta-buffer -- last action should just display it
- (ediff-show-meta-buffer ctl-buf t)
- ;; it's a session buffer -- invoke go back to session
- (ediff-with-current-buffer ctl-buf
- (setq ediff-mouse-pixel-position (mouse-pixel-position))
- (ediff-recenter 'no-rehighlight)))
- (beep)
- (message "You've selected a stale session --- try again")
- (ediff-update-registry))
- (ediff-with-current-buffer buf
- (goto-char pos))
- ))
-
-
-;; If session number is t, means don't update meta buffer
-(defun ediff-show-meta-buffer (&optional meta-buf session-number)
- "Show the session group buffer."
- (interactive)
- (run-hooks 'ediff-before-directory-setup-hooks)
- (let (wind frame silent)
- (if meta-buf (setq silent t))
-
- (setq meta-buf (or meta-buf ediff-meta-buffer))
- (cond ((not (bufferp meta-buf))
- (error "This Ediff session is not part of a session group"))
- ((not (ediff-buffer-live-p meta-buf))
- (error
- "Can't find this session's group panel -- session itself is ok")))
-
- (cond ((numberp session-number)
- (ediff-update-meta-buffer meta-buf nil session-number))
- ;; if session-number is t, don't update
- (session-number)
- (t (ediff-cleanup-meta-buffer meta-buf)))
-
- (ediff-with-current-buffer meta-buf
- (save-excursion
- (cond ((setq wind (ediff-get-visible-buffer-window meta-buf))
- (or silent
- (message
- "Already showing the group panel for this session"))
- (set-window-buffer wind meta-buf)
- (select-window wind))
- ((window-live-p (setq wind ediff-window-C)) ;in merge--merge buf
- (set-window-buffer ediff-window-C meta-buf)
- (select-window wind))
- ((window-live-p (setq wind ediff-window-A))
- (set-window-buffer ediff-window-A meta-buf)
- (select-window wind))
- ((window-live-p (setq wind ediff-window-B))
- (set-window-buffer ediff-window-B meta-buf)
- (select-window wind))
- ((and
- (setq wind
- (ediff-get-visible-buffer-window ediff-registry-buffer))
- (ediff-window-display-p))
- (select-window wind)
- (other-window 1)
- (set-window-buffer (selected-window) meta-buf))
- (t (ediff-skip-unsuitable-frames 'ok-unsplittable)
- (set-window-buffer (selected-window) meta-buf)))
- ))
- (if (and (ediff-window-display-p)
- (window-live-p
- (setq wind (ediff-get-visible-buffer-window meta-buf))))
- (progn
- (setq frame (window-frame wind))
- (raise-frame frame)
- (ediff-reset-mouse frame)))
- (sit-for 0) ; sometimes needed to synch the display and ensure that the
- ; point ends up after the just completed session
- (run-hooks 'ediff-show-session-group-hook)
- ))
-
-(defun ediff-show-current-session-meta-buffer ()
- (interactive)
- (ediff-show-meta-buffer nil ediff-meta-session-number))
-
-(defun ediff-show-meta-buff-from-registry ()
- "Display the session group buffer for a selected session group."
- (interactive)
- (let* ((pos (ediff-event-point last-command-event))
- (meta-buf (ediff-event-buffer last-command-event))
- (info (ediff-get-meta-info meta-buf pos))
- (meta-or-session-buf info))
- (ediff-with-current-buffer meta-or-session-buf
- (ediff-show-meta-buffer nil t))))
-
-;;;###autoload
-(defun ediff-show-registry ()
- "Display Ediff's registry."
- (interactive)
- (ediff-update-registry)
- (if (not (ediff-buffer-live-p ediff-registry-buffer))
- (error "No active Ediff sessions or corrupted session registry"))
- (let (wind frame)
- ;; for some reason, point moves in ediff-registry-buffer, so we preserve it
- ;; explicitly
- (ediff-with-current-buffer ediff-registry-buffer
- (save-excursion
- (cond ((setq wind
- (ediff-get-visible-buffer-window ediff-registry-buffer))
- (message "Already showing the registry")
- (set-window-buffer wind ediff-registry-buffer)
- (select-window wind))
- ((window-live-p ediff-window-C)
- (set-window-buffer ediff-window-C ediff-registry-buffer)
- (select-window ediff-window-C))
- ((window-live-p ediff-window-A)
- (set-window-buffer ediff-window-A ediff-registry-buffer)
- (select-window ediff-window-A))
- ((window-live-p ediff-window-B)
- (set-window-buffer ediff-window-B ediff-registry-buffer)
- (select-window ediff-window-B))
- ((and (setq wind
- (ediff-get-visible-buffer-window ediff-meta-buffer))
- (ediff-window-display-p))
- (select-window wind)
- (other-window 1)
- (set-window-buffer (selected-window) ediff-registry-buffer))
- (t (ediff-skip-unsuitable-frames 'ok-unsplittable)
- (set-window-buffer (selected-window) ediff-registry-buffer)))
- ))
- (if (ediff-window-display-p)
- (progn
- (setq frame
- (window-frame
- (ediff-get-visible-buffer-window ediff-registry-buffer)))
- (raise-frame frame)
- (ediff-reset-mouse frame)))
- (run-hooks 'ediff-show-registry-hook)
- ))
-
-;;;###autoload
-(defalias 'eregistry 'ediff-show-registry)
-
-;; If meta-buf doesn't exist, it is created. In that case, id doesn't have a
-;; parent meta-buf
-;; Check if META-BUF exists before calling this function
-;; Optional MUST-REDRAW, if non-nil, would force redrawal of the whole meta
-;; buffer. Otherwise, it will just go over the buffer and update activity marks
-;; and session status.
-;; SESSION-NUMBER, if specified, says which session caused the update.
-(defun ediff-update-meta-buffer (meta-buf &optional must-redraw session-number)
- (if (ediff-buffer-live-p meta-buf)
- (ediff-with-current-buffer meta-buf
- (let (overl)
- (cond (must-redraw ; completely redraw the meta buffer
- (funcall ediff-meta-redraw-function ediff-meta-list))
- ((numberp session-number) ; redraw only for the given session
- (ediff-update-session-marker-in-dir-meta-buffer
- session-number))
- (t ; update what changed only, but scan the entire meta buffer
- (ediff-update-markers-in-dir-meta-buffer ediff-meta-list)))
- (setq overl (ediff-get-meta-overlay-at-pos (point)))
- ;; skip the invisible sessions
- (while (and overl (ediff-overlay-get overl 'invisible))
- (ediff-next-meta-item1)
- (setq overl (ediff-get-meta-overlay-at-pos (point))))
- ))))
-
-(defun ediff-update-registry ()
- (ediff-with-current-buffer (current-buffer)
- (if (ediff-buffer-live-p ediff-registry-buffer)
- (ediff-redraw-registry-buffer)
- (ediff-prepare-meta-buffer
- 'ediff-registry-action
- ediff-session-registry
- "*Ediff Registry"
- 'ediff-redraw-registry-buffer
- 'ediff-registry))
- ))
-
-;; If meta-buf exists, it is redrawn along with parent.
-;; Otherwise, nothing happens.
-(defun ediff-cleanup-meta-buffer (meta-buffer)
- (if (ediff-buffer-live-p meta-buffer)
- (ediff-with-current-buffer meta-buffer
- (ediff-update-meta-buffer meta-buffer)
- (if (ediff-buffer-live-p ediff-parent-meta-buffer)
- (ediff-update-meta-buffer
- ediff-parent-meta-buffer nil ediff-meta-session-number)))))
-
-;; t if no session is in progress
-(defun ediff-safe-to-quit (meta-buffer)
- (if (ediff-buffer-live-p meta-buffer)
- (let ((lis ediff-meta-list)
- (cont t)
- buffer-read-only)
- ;;(ediff-update-meta-buffer meta-buffer)
- (ediff-with-current-buffer meta-buffer
- (setq lis (cdr lis)) ; discard the description part of meta-list
- (while (and cont lis)
- (if (ediff-buffer-live-p
- (ediff-get-group-buffer lis)) ; in progress
- (setq cont nil))
- (setq lis (cdr lis)))
- cont))))
-
-(defun ediff-quit-meta-buffer ()
- "If the group has no active session, delete the meta buffer.
-If no session is in progress, ask to confirm before deleting meta buffer.
-Otherwise, bury the meta buffer.
-If this is a session registry buffer then just bury it."
- (interactive)
- (let* ((buf (current-buffer))
- (dir-diffs-buffer ediff-dir-diffs-buffer)
- (meta-diff-buffer ediff-meta-diff-buffer)
- (session-number ediff-meta-session-number)
- (parent-buf ediff-parent-meta-buffer)
- (dont-show-registry (eq buf ediff-registry-buffer)))
- (if dont-show-registry
- (bury-buffer)
- ;;(ediff-cleanup-meta-buffer buf)
- (cond ((and (ediff-safe-to-quit buf)
- (y-or-n-p "Quit this session group? "))
- (run-hooks 'ediff-quit-session-group-hook)
- (message "")
- (ediff-dispose-of-meta-buffer buf))
- ((ediff-safe-to-quit buf)
- (bury-buffer))
- (t
- (error
- "This session group has active sessions---cannot exit")))
- (ediff-update-meta-buffer parent-buf nil session-number)
- (ediff-kill-buffer-carefully dir-diffs-buffer)
- (ediff-kill-buffer-carefully meta-diff-buffer)
- (if (ediff-buffer-live-p parent-buf)
- (progn
- (setq dont-show-registry t)
- (ediff-show-meta-buffer parent-buf session-number)))
- )
- (or dont-show-registry
- (ediff-show-registry))))
-
-(defun ediff-dispose-of-meta-buffer (buf)
- (setq ediff-session-registry (delq buf ediff-session-registry))
- (ediff-with-current-buffer buf
- (if (ediff-buffer-live-p ediff-dir-diffs-buffer)
- (kill-buffer ediff-dir-diffs-buffer)))
- (kill-buffer buf))
-
-
-;; Obtain information on a meta record where the user clicked or typed
-;; BUF is the buffer where this happened and POINT is the position
-;; If optional NOERROR arg is given, don't report error and return nil if no
-;; meta info is found on line.
-(defun ediff-get-meta-info (buf point &optional noerror)
- (let (result olist tmp)
- (if (and point (ediff-buffer-live-p buf))
- (ediff-with-current-buffer buf
- (if (featurep 'xemacs)
- (setq result
- (if (setq tmp (extent-at point buf 'ediff-meta-info))
- (ediff-overlay-get tmp 'ediff-meta-info)))
- (setq olist
- (mapcar (lambda (elt)
- (unless (overlay-get elt 'invisible)
- (overlay-get elt 'ediff-meta-info)))
- (overlays-at point)))
- (while (and olist (null (car olist)))
- (setq olist (cdr olist)))
- (setq result (car olist)))))
- (or result
- (unless noerror
- (ediff-update-registry)
- (error "No session info in this line")))))
-
-
-(defun ediff-get-meta-overlay-at-pos (point)
- (if (featurep 'xemacs)
- (extent-at point (current-buffer) 'ediff-meta-info)
- (let* ((overl-list (overlays-at point))
- (overl (car overl-list)))
- (while (and overl (null (overlay-get overl 'ediff-meta-info)))
- (setq overl-list (cdr overl-list)
- overl (car overl-list)))
- overl)))
-
-(defun ediff-get-session-number-at-pos (point &optional meta-buffer)
- (setq meta-buffer (if (ediff-buffer-live-p meta-buffer)
- meta-buffer
- (current-buffer)))
- (ediff-with-current-buffer meta-buffer
- (ediff-overlay-get
- (ediff-get-meta-overlay-at-pos point) 'ediff-meta-session-number)))
-
-
-;; Return location of the next meta overlay after point
-(defun ediff-next-meta-overlay-start (point)
- (if (eobp)
- (goto-char (point-min))
- (let ((overl (ediff-get-meta-overlay-at-pos point)))
- (if (featurep 'xemacs)
- (progn ; xemacs
- (if overl
- (setq overl (next-extent overl))
- (setq overl (next-extent (current-buffer))))
- (if overl
- (extent-start-position overl)
- (point-max)))
- ;; emacs
- (if overl
- ;; note: end of current overlay is the beginning of the next one
- (overlay-end overl)
- (next-overlay-change point))))))
-
-
-(defun ediff-previous-meta-overlay-start (point)
- (if (bobp)
- (goto-char (point-max))
- (let ((overl (ediff-get-meta-overlay-at-pos point)))
- (if (featurep 'xemacs)
- (progn
- (if overl
- (setq overl (previous-extent overl))
- (setq overl (previous-extent (current-buffer))))
- (if overl
- (extent-start-position overl)
- (point-min)))
- (if overl (setq point (overlay-start overl)))
- ;; to get to the beginning of prev overlay
- (if (not (bobp))
- ;; trick to overcome an emacs bug--doesn't always find previous
- ;; overlay change correctly
- (setq point (1- point)))
- (setq point (previous-overlay-change point))
- ;; If we are not over an overlay after subtracting 1, it means we are
- ;; in the description area preceding session records. In this case,
- ;; goto the top of the registry buffer.
- (or (car (overlays-at point))
- (setq point (point-min)))
- point))))
-
-;; this is the action invoked when the user selects a patch from the meta
-;; buffer.
-(defun ediff-patch-file-form-meta (file &optional startup-hooks)
- (let* ((pos (ediff-event-point last-command-event))
- (meta-buf (ediff-event-buffer last-command-event))
- ;; ediff-get-meta-info gives error if meta-buf or pos are invalid
- (info (ediff-get-meta-info meta-buf pos))
- (meta-patchbuf ediff-meta-patchbufer)
- session-buf beg-marker end-marker)
-
- (if (or (file-directory-p file) (string-match "/dev/null" file))
- (error "`%s' is not an ordinary file" (file-name-as-directory file)))
- (setq session-buf (ediff-get-session-buffer info)
- beg-marker (ediff-get-session-objB-name info)
- end-marker (ediff-get-session-objC-name info))
-
- (or (ediff-buffer-live-p session-buf) ; either an active patch session
- (null session-buf) ; or it is a virgin session
- (error
- "Patch has already been applied to this file -- can't repeat!"))
-
- (ediff-with-current-buffer meta-patchbuf
- (save-restriction
- (widen)
- (narrow-to-region beg-marker end-marker)
- (ediff-patch-file-internal meta-patchbuf file startup-hooks)))))
-
-
-(defun ediff-unmark-all-for-operation ()
- "Unmark all sessions marked for operation."
- (interactive)
- (let ((list (cdr ediff-meta-list))
- elt)
- (while (setq elt (car list))
- (ediff-mark-session-for-operation elt 'unmark)
- (setq list (cdr list))))
- (ediff-update-meta-buffer (current-buffer) 'must-redraw))
-
-(defun ediff-unmark-all-for-hiding ()
- "Unmark all sessions marked for hiding."
- (interactive)
- (let ((list (cdr ediff-meta-list))
- elt)
- (while (setq elt (car list))
- (ediff-mark-session-for-hiding elt 'unmark)
- (setq list (cdr list))))
- (ediff-update-meta-buffer (current-buffer) 'must-redraw))
-
-
-;; ACTION is ?h, ?m, ?=: to mark for hiding, mark for operation, or simply
-;; indicate which are equal files
-(defun ediff-meta-mark-equal-files (&optional action)
- "Run through the session list and mark identical files.
-This is used only for sessions that involve 2 or 3 files at the same time.
-ACTION is an optional argument that can be ?h, ?m, ?=, to mark for hiding, mark
-for operation, or simply indicate which are equal files. If it is nil, then
-`(ediff-last-command-char)' is used to decide which action to take."
- (interactive)
- (if (null action)
- (setq action (ediff-last-command-char)))
- (let ((list (cdr ediff-meta-list))
- marked1 marked2 marked3
- fileinfo1 fileinfo2 fileinfo3 elt)
- (message "Comparing files...")
- (while (setq elt (car list))
- (setq fileinfo1 (ediff-get-session-objA elt)
- fileinfo2 (ediff-get-session-objB elt)
- fileinfo3 (ediff-get-session-objC elt))
- (ediff-set-file-eqstatus fileinfo1 nil)
- (ediff-set-file-eqstatus fileinfo2 nil)
- (ediff-set-file-eqstatus fileinfo3 nil)
-
- (setq marked1 t
- marked2 t
- marked3 t)
- (or (ediff-mark-if-equal fileinfo1 fileinfo2)
- (setq marked1 nil))
- (if (ediff-metajob3)
- (progn
- (or (ediff-mark-if-equal fileinfo1 fileinfo3)
- (setq marked2 nil))
- (or (ediff-mark-if-equal fileinfo2 fileinfo3)
- (setq marked3 nil))))
- (if (and marked1 marked2 marked3)
- (cond ((eq action ?h)
- (ediff-mark-session-for-hiding elt 'mark))
- ((eq action ?m)
- (ediff-mark-session-for-operation elt 'mark))
- ))
- (setq list (cdr list)))
- (message "Comparing files... Done"))
- (setq ediff-recurse-to-subdirectories nil)
- (ediff-update-meta-buffer (current-buffer) 'must-redraw))
-
-;; mark files 1 and 2 as equal, if they are.
-;; returns t, if something was marked
-(defun ediff-mark-if-equal (fileinfo1 fileinfo2)
- (let ((f1 (car fileinfo1))
- (f2 (car fileinfo2)))
- (if (and (stringp f1) (stringp f2) (ediff-same-contents f1 f2))
- (progn
- (ediff-set-file-eqstatus fileinfo1 t)
- (ediff-set-file-eqstatus fileinfo2 t)
- ))
- ))
-
-
-
-;; Local Variables:
-;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
-;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
-;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
-;; End:
-
-;; arch-tag: c8a76898-f96f-4d9c-be9d-129134017188
-;;; ediff-mult.el ends here
+++ /dev/null
-;;; ediff-ptch.el --- Ediff's patch support
-
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-
-(provide 'ediff-ptch)
-
-(defgroup ediff-ptch nil
- "Ediff patch support."
- :tag "Patch"
- :prefix "ediff-"
- :group 'ediff)
-
-;; compiler pacifier
-(eval-when-compile
- (require 'ediff))
-;; end pacifier
-
-(require 'ediff-init)
-
-(defcustom ediff-patch-program "patch"
- "Name of the program that applies patches.
-It is recommended to use GNU-compatible versions."
- :type 'string
- :group 'ediff-ptch)
-(defcustom ediff-patch-options "-f"
- "Options to pass to ediff-patch-program.
-
-Note: the `-b' option should be specified in `ediff-backup-specs'.
-
-It is recommended to pass the `-f' option to the patch program, so it won't ask
-questions. However, some implementations don't accept this option, in which
-case the default value for this variable should be changed."
- :type 'string
- :group 'ediff-ptch)
-
-(defvar ediff-last-dir-patch nil
- "Last directory used by an Ediff command for file to patch.")
-
-;; the default backup extension
-(defconst ediff-default-backup-extension
- (if (memq system-type '(emx ms-dos))
- "_orig" ".orig"))
-
-
-(defcustom ediff-backup-extension ediff-default-backup-extension
- "Backup extension used by the patch program.
-See also `ediff-backup-specs'."
- :type 'string
- :group 'ediff-ptch)
-
-(defun ediff-test-patch-utility ()
- (condition-case nil
- (cond ((eq 0 (call-process ediff-patch-program nil nil nil "-z." "-b"))
- ;; GNU `patch' v. >= 2.2
- 'gnu)
- ((eq 0 (call-process ediff-patch-program nil nil nil "-b"))
- 'posix)
- (t 'traditional))
- (file-error nil)))
-
-(defcustom ediff-backup-specs
- (let ((type (ediff-test-patch-utility)))
- (cond ((eq type 'gnu)
- ;; GNU `patch' v. >= 2.2
- (format "-z%s -b" ediff-backup-extension))
- ((eq type 'posix)
- ;; POSIX `patch' -- ediff-backup-extension must be ".orig"
- (setq ediff-backup-extension ediff-default-backup-extension)
- "-b")
- (t
- ;; traditional `patch'
- (format "-b %s" ediff-backup-extension))))
- "Backup directives to pass to the patch program.
-Ediff requires that the old version of the file \(before applying the patch\)
-be saved in a file named `the-patch-file.extension'. Usually `extension' is
-`.orig', but this can be changed by the user and may depend on the system.
-Therefore, Ediff needs to know the backup extension used by the patch program.
-
-Some versions of the patch program let you specify `-b backup-extension'.
-Other versions only permit `-b', which assumes the extension `.orig'
-\(in which case ediff-backup-extension MUST be also `.orig'\). The latest
-versions of GNU patch require `-b -z backup-extension'.
-
-Note that both `ediff-backup-extension' and `ediff-backup-specs'
-must be set properly. If your patch program takes the option `-b',
-but not `-b extension', the variable `ediff-backup-extension' must
-still be set so Ediff will know which extension to use.
-
-Ediff tries to guess the appropriate value for this variables. It is believed
-to be working for `traditional' patch, all versions of GNU patch, and for POSIX
-patch. So, don't change these variables, unless the default doesn't work."
- :type 'string
- :group 'ediff-ptch)
-
-
-(defcustom ediff-patch-default-directory nil
- "Default directory to look for patches."
- :type '(choice (const nil) string)
- :group 'ediff-ptch)
-
-;; This context diff does not recognize spaces inside files, but removing ' '
-;; from [^ \t] breaks normal patches for some reason
-(defcustom ediff-context-diff-label-regexp
- (concat "\\(" ; context diff 2-liner
- "^\\*\\*\\* +\\([^ \t]+\\)[^*]+[\t ]*\n--- +\\([^ \t]+\\)"
- "\\|" ; unified format diff 2-liner
- "^--- +\\([^ \t]+\\).*\n\\+\\+\\+ +\\([^ \t]+\\)"
- "\\)")
- "Regexp matching filename 2-liners at the start of each context diff.
-You probably don't want to change that, unless you are using an obscure patch
-program."
- :type 'regexp
- :group 'ediff-ptch)
-
-;; The buffer of the patch file. Local to control buffer.
-(ediff-defvar-local ediff-patchbufer nil "")
-
-;; The buffer where patch displays its diagnostics.
-(ediff-defvar-local ediff-patch-diagnostics nil "")
-
-;; Map of patch buffer. Has the form:
-;; ((filename1 marker1 marker2) (filename2 marker1 marker2) ...)
-;; where filenames are files to which patch would have applied the patch;
-;; marker1 delimits the beginning of the corresponding patch and marker2 does
-;; it for the end.
-(ediff-defvar-local ediff-patch-map nil "")
-
-;; strip prefix from filename
-;; returns /dev/null, if can't strip prefix
-(defsubst ediff-file-name-sans-prefix (filename prefix)
- (if prefix
- (save-match-data
- (if (string-match (concat "^" (if (stringp prefix)
- (regexp-quote prefix)
- ""))
- filename)
- (substring filename (match-end 0))
- (concat "/null/" filename)))
- filename)
- )
-
-
-
-;; no longer used
-;; return the number of matches of regexp in buf starting from the beginning
-(defun ediff-count-matches (regexp buf)
- (ediff-with-current-buffer buf
- (let ((count 0) opoint)
- (save-excursion
- (goto-char (point-min))
- (while (and (not (eobp))
- (progn (setq opoint (point))
- (re-search-forward regexp nil t)))
- (if (= opoint (point))
- (forward-char 1)
- (setq count (1+ count)))))
- count)))
-
-;; Scan BUF (which is supposed to contain a patch) and make a list of the form
-;; ((nil nil filename-spec1 marker1 marker2)
-;; (nil nil filename-spec2 marker1 marker2) ...)
-;; where filename-spec[12] are files to which the `patch' program would
-;; have applied the patch.
-;; nin, nil are placeholders. See ediff-make-new-meta-list-element in
-;; ediff-meta.el for the explanations.
-;; In the beginning we don't know exactly which files need to be patched.
-;; We usually come up with two candidates and ediff-file-name-sans-prefix
-;; resolves this later.
-;;
-;; The marker `marker1' delimits the beginning of the corresponding patch and
-;; `marker2' does it for the end.
-;; The result of ediff-map-patch-buffer is a list, which is then assigned
-;; to ediff-patch-map.
-;; The function returns the number of elements in the list ediff-patch-map
-(defun ediff-map-patch-buffer (buf)
- (ediff-with-current-buffer buf
- (let ((count 0)
- (mark1 (move-marker (make-marker) (point-min)))
- (mark1-end (point-min))
- (possible-file-names '("/dev/null" . "/dev/null"))
- mark2-end mark2 filenames
- beg1 beg2 end1 end2
- patch-map opoint)
- (save-excursion
- (goto-char (point-min))
- (setq opoint (point))
- (while (and (not (eobp))
- (re-search-forward ediff-context-diff-label-regexp nil t))
- (if (= opoint (point))
- (forward-char 1) ; ensure progress towards the end
- (setq mark2 (move-marker (make-marker) (match-beginning 0))
- mark2-end (match-end 0)
- beg1 (or (match-beginning 2) (match-beginning 4))
- end1 (or (match-end 2) (match-end 4))
- beg2 (or (match-beginning 3) (match-beginning 5))
- end2 (or (match-end 3) (match-end 5)))
- ;; possible-file-names is holding the new file names until we
- ;; insert the old file name in the patch map
- ;; It is a pair
- ;; (filename-from-1st-header-line . filename-from-2nd-line)
- (setq possible-file-names
- (cons (if (and beg1 end1)
- (buffer-substring beg1 end1)
- "/dev/null")
- (if (and beg2 end2)
- (buffer-substring beg2 end2)
- "/dev/null")))
- ;; check for any `Index:' or `Prereq:' lines, but don't use them
- (if (re-search-backward "^Index:" mark1-end 'noerror)
- (move-marker mark2 (match-beginning 0)))
- (if (re-search-backward "^Prereq:" mark1-end 'noerror)
- (move-marker mark2 (match-beginning 0)))
-
- (goto-char mark2-end)
-
- (if filenames
- (setq patch-map
- (cons (ediff-make-new-meta-list-element
- filenames mark1 mark2)
- patch-map)))
- (setq mark1 mark2
- mark1-end mark2-end
- filenames possible-file-names))
- (setq opoint (point)
- count (1+ count))))
- (setq mark2 (point-max-marker)
- patch-map (cons (ediff-make-new-meta-list-element
- possible-file-names mark1 mark2)
- patch-map))
- (setq ediff-patch-map (nreverse patch-map))
- count)))
-
-;; Fix up the file names in the list using the argument FILENAME
-;; Algorithm: find the files' directories in the patch and, if a directory is
-;; absolute, cut it out from the corresponding file name in the patch.
-;; Relative directories are not cut out.
-;; Prepend the directory of FILENAME to each resulting file (which came
-;; originally from the patch).
-;; In addition, the first file in the patch document is replaced by FILENAME.
-;; Each file is actually a pair of files found in the context diff header
-;; In the end, for each pair, we ask the user which file to patch.
-;; Note: Ediff doesn't recognize multi-file patches that are separated
-;; with the `Index:' line. It treats them as a single-file patch.
-;;
-;; Executes inside the patch buffer
-(defun ediff-fixup-patch-map (filename)
- (setq filename (expand-file-name filename))
- (let ((actual-dir (if (file-directory-p filename)
- ;; directory part of filename
- (file-name-as-directory filename)
- (file-name-directory filename)))
- ;; In case 2 files are possible patch targets, the user will be offered
- ;; to choose file1 or file2. In a multifile patch, if the user chooses
- ;; 1 or 2, this choice is preserved to decide future alternatives.
- chosen-alternative
- )
-
- ;; chop off base-dirs
- (mapc (lambda (session-info)
- (let* ((proposed-file-names
- ;; Filename-spec is objA; it is represented as
- ;; (file1 . file2). Get it using ediff-get-session-objA.
- (ediff-get-session-objA-name session-info))
- ;; base-dir1 is the dir part of the 1st file in the patch
- (base-dir1
- (or (file-name-directory (car proposed-file-names))
- ""))
- ;; directory part of the 2nd file in the patch
- (base-dir2
- (or (file-name-directory (cdr proposed-file-names))
- ""))
- )
- ;; If both base-dir1 and base-dir2 are relative and exist,
- ;; assume that
- ;; these dirs lead to the actual files starting at the present
- ;; directory. So, we don't strip these relative dirs from the
- ;; file names. This is a heuristic intended to improve guessing
- (let ((default-directory (file-name-directory filename)))
- (unless (or (file-name-absolute-p base-dir1)
- (file-name-absolute-p base-dir2)
- (not (file-exists-p base-dir1))
- (not (file-exists-p base-dir2)))
- (setq base-dir1 ""
- base-dir2 "")))
- (or (string= (car proposed-file-names) "/dev/null")
- (setcar proposed-file-names
- (ediff-file-name-sans-prefix
- (car proposed-file-names) base-dir1)))
- (or (string=
- (cdr proposed-file-names) "/dev/null")
- (setcdr proposed-file-names
- (ediff-file-name-sans-prefix
- (cdr proposed-file-names) base-dir2)))
- ))
- ediff-patch-map)
-
- ;; take the given file name into account
- (or (file-directory-p filename)
- (string= "/dev/null" filename)
- (setcar (ediff-get-session-objA (car ediff-patch-map))
- (cons (file-name-nondirectory filename)
- (file-name-nondirectory filename))))
-
- ;; prepend actual-dir
- (mapc (lambda (session-info)
- (let ((proposed-file-names
- (ediff-get-session-objA-name session-info)))
- (if (and (string-match "^/null/" (car proposed-file-names))
- (string-match "^/null/" (cdr proposed-file-names)))
- ;; couldn't intuit the file name to patch, so
- ;; something is amiss
- (progn
- (with-output-to-temp-buffer ediff-msg-buffer
- (ediff-with-current-buffer standard-output
- (fundamental-mode))
- (princ
- (format "
-The patch file contains a context diff for
- %s
- %s
-However, Ediff cannot infer the name of the actual file
-to be patched on your system. If you know the correct file name,
-please enter it now.
-
-If you don't know and still would like to apply patches to
-other files, enter /dev/null
-"
- (substring (car proposed-file-names) 6)
- (substring (cdr proposed-file-names) 6))))
- (let ((directory t)
- user-file)
- (while directory
- (setq user-file
- (read-file-name
- "Please enter file name: "
- actual-dir actual-dir t))
- (if (not (file-directory-p user-file))
- (setq directory nil)
- (setq directory t)
- (beep)
- (message "%s is a directory" user-file)
- (sit-for 2)))
- (setcar (ediff-get-session-objA session-info)
- (cons user-file user-file))))
- (setcar proposed-file-names
- (expand-file-name
- (concat actual-dir (car proposed-file-names))))
- (setcdr proposed-file-names
- (expand-file-name
- (concat actual-dir (cdr proposed-file-names)))))
- ))
- ediff-patch-map)
- ;; Check for the existing files in each pair and discard the nonexisting
- ;; ones. If both exist, ask the user.
- (mapcar (lambda (session-info)
- (let* ((file1 (car (ediff-get-session-objA-name session-info)))
- (file2 (cdr (ediff-get-session-objA-name session-info)))
- (session-file-object
- (ediff-get-session-objA session-info))
- (f1-exists (file-exists-p file1))
- (f2-exists (file-exists-p file2)))
- (cond
- ((and
- ;; The patch program prefers the shortest file as the patch
- ;; target. However, this is a questionable heuristic. In an
- ;; interactive program, like ediff, we can offer the user a
- ;; choice.
- ;; (< (length file2) (length file1))
- (not f1-exists)
- f2-exists)
- ;; replace file-pair with the winning file2
- (setcar session-file-object file2))
- ((and
- ;; (< (length file1) (length file2))
- (not f2-exists)
- f1-exists)
- ;; replace file-pair with the winning file1
- (setcar session-file-object file1))
- ((and f1-exists f2-exists
- (string= file1 file2))
- (setcar session-file-object file1))
- ((and f1-exists f2-exists (eq chosen-alternative 1))
- (setcar session-file-object file1))
- ((and f1-exists f2-exists (eq chosen-alternative 2))
- (setcar session-file-object file2))
- ((and f1-exists f2-exists)
- (with-output-to-temp-buffer ediff-msg-buffer
- (ediff-with-current-buffer standard-output
- (fundamental-mode))
- (princ (format "
-Ediff has inferred that
- %s
- %s
-are two possible targets for applying the patch.
-Both files seem to be plausible alternatives.
-
-Please advice:
- Type `y' to use %s as the target;
- Type `n' to use %s as the target.
-"
- file1 file2 file1 file2)))
- (setcar session-file-object
- (if (y-or-n-p (format "Use %s ? " file1))
- (progn
- (setq chosen-alternative 1)
- file1)
- (setq chosen-alternative 2)
- file2))
- )
- (f2-exists (setcar session-file-object file2))
- (f1-exists (setcar session-file-object file1))
- (t
- (with-output-to-temp-buffer ediff-msg-buffer
- (ediff-with-current-buffer standard-output
- (fundamental-mode))
- (princ "\nEdiff has inferred that")
- (if (string= file1 file2)
- (princ (format "
- %s
-is assumed to be the target for this patch. However, this file does not exist."
- file1))
- (princ (format "
- %s
- %s
-are two possible targets for this patch. However, these files do not exist."
- file1 file2)))
- (princ "
-\nPlease enter an alternative patch target ...\n"))
- (let ((directory t)
- target)
- (while directory
- (setq target (read-file-name
- "Please enter a patch target: "
- actual-dir actual-dir t))
- (if (not (file-directory-p target))
- (setq directory nil)
- (beep)
- (message "%s is a directory" target)
- (sit-for 2)))
- (setcar session-file-object target))))))
- ediff-patch-map)
- ))
-
-(defun ediff-show-patch-diagnostics ()
- (interactive)
- (cond ((window-live-p ediff-window-A)
- (set-window-buffer ediff-window-A ediff-patch-diagnostics))
- ((window-live-p ediff-window-B)
- (set-window-buffer ediff-window-B ediff-patch-diagnostics))
- (t (display-buffer ediff-patch-diagnostics 'not-this-window))))
-
-;; prompt for file, get the buffer
-(defun ediff-prompt-for-patch-file ()
- (let ((dir (cond (ediff-use-last-dir ediff-last-dir-patch)
- (ediff-patch-default-directory) ; try patch default dir
- (t default-directory)))
- (coding-system-for-read ediff-coding-system-for-read)
- patch-file-name)
- (setq patch-file-name
- (read-file-name
- (format "Patch is in file%s: "
- (cond ((and buffer-file-name
- (equal (expand-file-name dir)
- (file-name-directory buffer-file-name)))
- (concat
- " (default "
- (file-name-nondirectory buffer-file-name)
- ")"))
- (t "")))
- dir buffer-file-name 'must-match))
- (if (file-directory-p patch-file-name)
- (error "Patch file cannot be a directory: %s" patch-file-name)
- (find-file-noselect patch-file-name))
- ))
-
-
-;; Try current buffer, then the other window's buffer. Else, give up.
-(defun ediff-prompt-for-patch-buffer ()
- (get-buffer
- (read-buffer
- "Buffer that holds the patch: "
- (cond ((save-excursion
- (goto-char (point-min))
- (re-search-forward ediff-context-diff-label-regexp nil t))
- (current-buffer))
- ((save-window-excursion
- (other-window 1)
- (save-excursion
- (goto-char (point-min))
- (and (re-search-forward ediff-context-diff-label-regexp nil t)
- (current-buffer)))))
- ((save-window-excursion
- (other-window -1)
- (save-excursion
- (goto-char (point-min))
- (and (re-search-forward ediff-context-diff-label-regexp nil t)
- (current-buffer)))))
- (t (ediff-other-buffer (current-buffer))))
- 'must-match)))
-
-
-(defun ediff-get-patch-buffer (&optional arg patch-buf)
- "Obtain patch buffer. If patch is already in a buffer---use it.
-Else, read patch file into a new buffer. If patch buffer is passed as an
-optional argument, then use it."
- (let ((last-nonmenu-event t) ; Emacs: don't use dialog box
- last-command-event) ; XEmacs: don't use dialog box
-
- (cond ((ediff-buffer-live-p patch-buf))
- ;; even prefix arg: patch in buffer
- ((and (integerp arg) (eq 0 (mod arg 2)))
- (setq patch-buf (ediff-prompt-for-patch-buffer)))
- ;; odd prefix arg: get patch from a file
- ((and (integerp arg) (eq 1 (mod arg 2)))
- (setq patch-buf (ediff-prompt-for-patch-file)))
- (t (setq patch-buf
- (if (y-or-n-p "Is the patch already in a buffer? ")
- (ediff-prompt-for-patch-buffer)
- (ediff-prompt-for-patch-file)))))
-
- (ediff-with-current-buffer patch-buf
- (goto-char (point-min))
- (or (ediff-get-visible-buffer-window patch-buf)
- (progn
- (pop-to-buffer patch-buf 'other-window)
- (select-window (previous-window)))))
- (ediff-map-patch-buffer patch-buf)
- patch-buf))
-
-;; Dispatch the right patch file function: regular or meta-level,
-;; depending on how many patches are in the patch file.
-;; At present, there is no support for meta-level patches.
-;; Should return either the ctl buffer or the meta-buffer
-(defun ediff-dispatch-file-patching-job (patch-buf filename
- &optional startup-hooks)
- (ediff-with-current-buffer patch-buf
- ;; relativize names in the patch with respect to source-file
- (ediff-fixup-patch-map filename)
- (if (< (length ediff-patch-map) 2)
- (ediff-patch-file-internal
- patch-buf
- (if (and ediff-patch-map
- (not (string-match
- "^/dev/null"
- ;; this is the file to patch
- (ediff-get-session-objA-name (car ediff-patch-map))))
- (> (length
- (ediff-get-session-objA-name (car ediff-patch-map)))
- 1))
- (ediff-get-session-objA-name (car ediff-patch-map))
- filename)
- startup-hooks)
- (ediff-multi-patch-internal patch-buf startup-hooks))
- ))
-
-
-;; When patching a buffer, never change the orig file. Instead, create a new
-;; buffer, ***_patched, even if the buff visits a file.
-;; Users who want to actually patch the buffer should use
-;; ediff-patch-file, not ediff-patch-buffer.
-(defun ediff-patch-buffer-internal (patch-buf
- buf-to-patch-name
- &optional startup-hooks)
- (let* ((buf-to-patch (get-buffer buf-to-patch-name))
- (visited-file (if buf-to-patch (buffer-file-name buf-to-patch)))
- (buf-mod-status (buffer-modified-p buf-to-patch))
- (multifile-patch-p (> (length (ediff-with-current-buffer patch-buf
- ediff-patch-map)) 1))
- default-dir file-name ctl-buf)
- (if multifile-patch-p
- (error
- "To apply multi-file patches, please use `ediff-patch-file'"))
-
- ;; create a temp file to patch
- (ediff-with-current-buffer buf-to-patch
- (setq default-dir default-directory)
- (setq file-name (ediff-make-temp-file buf-to-patch))
- ;; temporarily switch visited file name, if any
- (set-visited-file-name file-name)
- ;; don't create auto-save file, if buff was visiting a file
- (or visited-file
- (setq buffer-auto-save-file-name nil))
- ;; don't confuse the user with a new bufname
- (rename-buffer buf-to-patch-name)
- (set-buffer-modified-p nil)
- (set-visited-file-modtime) ; sync buffer and temp file
- (setq default-directory default-dir)
- )
-
- ;; dispatch a patch function
- (setq ctl-buf (ediff-dispatch-file-patching-job
- patch-buf file-name startup-hooks))
-
- (ediff-with-current-buffer ctl-buf
- (delete-file (buffer-file-name ediff-buffer-A))
- (delete-file (buffer-file-name ediff-buffer-B))
- (ediff-with-current-buffer ediff-buffer-A
- (if default-dir (setq default-directory default-dir))
- (set-visited-file-name visited-file) ; visited-file might be nil
- (rename-buffer buf-to-patch-name)
- (set-buffer-modified-p buf-mod-status))
- (ediff-with-current-buffer ediff-buffer-B
- (setq buffer-auto-save-file-name nil) ; don't create auto-save file
- (if default-dir (setq default-directory default-dir))
- (set-visited-file-name nil)
- (rename-buffer (ediff-unique-buffer-name
- (concat buf-to-patch-name "_patched") ""))
- (set-buffer-modified-p t)))
- ))
-
-
-;; Traditional patch has weird return codes.
-;; GNU and Posix return 1 if some hanks failed and 2 in case of trouble.
-;; 0 is a good code in all cases.
-;; We'll do the concervative thing.
-(defun ediff-patch-return-code-ok (code)
- (eq code 0))
-;;; (if (eq (ediff-test-patch-utility) 'traditional)
-;;; (eq code 0)
-;;; (not (eq code 2))))
-
-(defun ediff-patch-file-internal (patch-buf source-filename
- &optional startup-hooks)
- (setq source-filename (expand-file-name source-filename))
-
- (let* ((shell-file-name ediff-shell)
- (patch-diagnostics (get-buffer-create "*ediff patch diagnostics*"))
- ;; ediff-find-file may use a temp file to do the patch
- ;; so, we save source-filename and true-source-filename as a var
- ;; that initially is source-filename but may be changed to a temp
- ;; file for the purpose of patching.
- (true-source-filename source-filename)
- (target-filename source-filename)
- ;; this ensures that the patch process gets patch buffer in the
- ;; encoding that Emacs thinks is right for that type of text
- (coding-system-for-write
- (if (boundp 'buffer-file-coding-system) buffer-file-coding-system))
- target-buf buf-to-patch file-name-magic-p
- patch-return-code ctl-buf backup-style aux-wind)
-
- (if (string-match "V" ediff-patch-options)
- (error
- "Ediff doesn't take the -V option in `ediff-patch-options'--sorry"))
-
- ;; Make a temp file, if source-filename has a magic file handler (or if
- ;; it is handled via auto-mode-alist and similar magic).
- ;; Check if there is a buffer visiting source-filename and if they are in
- ;; sync; arrange for the deletion of temp file.
- (ediff-find-file 'true-source-filename 'buf-to-patch
- 'ediff-last-dir-patch 'startup-hooks)
-
- ;; Check if source file name has triggered black magic, such as file name
- ;; handlers or auto mode alist, and make a note of it.
- ;; true-source-filename should be either the original name or a
- ;; temporary file where we put the after-product of the file handler.
- (setq file-name-magic-p (not (equal (file-truename true-source-filename)
- (file-truename source-filename))))
-
- ;; Checkout orig file, if necessary, so that the patched file
- ;; could be checked back in.
- (ediff-maybe-checkout buf-to-patch)
-
- (ediff-with-current-buffer patch-diagnostics
- (insert-buffer-substring patch-buf)
- (message "Applying patch ... ")
- ;; fix environment for gnu patch, so it won't make numbered extensions
- (setq backup-style (getenv "VERSION_CONTROL"))
- (setenv "VERSION_CONTROL" nil)
- (setq patch-return-code
- (call-process-region
- (point-min) (point-max)
- shell-file-name
- t ; delete region (which contains the patch
- t ; insert output (patch diagnostics) in current buffer
- nil ; don't redisplay
- shell-command-switch ; usually -c
- (format "%s %s %s %s"
- ediff-patch-program
- ediff-patch-options
- ediff-backup-specs
- (expand-file-name true-source-filename))
- ))
-
- ;; restore environment for gnu patch
- (setenv "VERSION_CONTROL" backup-style))
-
- (message "Applying patch ... done")
- (message "")
-
- (switch-to-buffer patch-diagnostics)
- (sit-for 0) ; synchronize - let the user see diagnostics
-
- (or (and (ediff-patch-return-code-ok patch-return-code)
- (file-exists-p
- (concat true-source-filename ediff-backup-extension)))
- (progn
- (with-output-to-temp-buffer ediff-msg-buffer
- (ediff-with-current-buffer standard-output
- (fundamental-mode))
- (princ (format
- "Patch program has failed due to a bad patch file,
-it couldn't apply all hunks, OR
-it couldn't create the backup for the file being patched.
-
-The former could be caused by a corrupt patch file or because the %S
-program doesn't understand the format of the patch file in use.
-
-The second problem might be due to an incompatibility among these settings:
- ediff-patch-program = %S ediff-patch-options = %S
- ediff-backup-extension = %S ediff-backup-specs = %S
-
-See Ediff on-line manual for more details on these variables.
-In particular, check the documentation for `ediff-backup-specs'.
-
-In any of the above cases, Ediff doesn't compare files automatically.
-However, if the patch was applied partially and the backup file was created,
-you can still examine the changes via M-x ediff-files"
- ediff-patch-program
- ediff-patch-program
- ediff-patch-options
- ediff-backup-extension
- ediff-backup-specs
- )))
- (beep 1)
- (if (setq aux-wind (get-buffer-window ediff-msg-buffer))
- (progn
- (select-window aux-wind)
- (goto-char (point-max))))
- (switch-to-buffer-other-window patch-diagnostics)
- (error "Patch appears to have failed")))
-
- ;; If black magic is involved, apply patch to a temp copy of the
- ;; file. Otherwise, apply patch to the orig copy. If patch is applied
- ;; to temp copy, we name the result old-name_patched for local files
- ;; and temp-copy_patched for remote files. The orig file name isn't
- ;; changed, and the temp copy of the original is later deleted.
- ;; Without magic, the original file is renamed (usually into
- ;; old-name_orig) and the result of patching will have the same name as
- ;; the original.
- (if (not file-name-magic-p)
- (ediff-with-current-buffer buf-to-patch
- (set-visited-file-name
- (concat source-filename ediff-backup-extension))
- (set-buffer-modified-p nil))
-
- ;; Black magic in effect.
- ;; If orig file was remote, put the patched file in the temp directory.
- ;; If orig file is local, put the patched file in the directory of
- ;; the orig file.
- (setq target-filename
- (concat
- (if (ediff-file-remote-p (file-truename source-filename))
- true-source-filename
- source-filename)
- "_patched"))
-
- (rename-file true-source-filename target-filename t)
-
- ;; arrange that the temp copy of orig will be deleted
- (rename-file (concat true-source-filename ediff-backup-extension)
- true-source-filename t))
-
- ;; make orig buffer read-only
- (setq startup-hooks
- (cons 'ediff-set-read-only-in-buf-A startup-hooks))
-
- ;; set up a buf for the patched file
- (setq target-buf (find-file-noselect target-filename))
-
- (setq ctl-buf
- (ediff-buffers-internal
- buf-to-patch target-buf nil
- startup-hooks 'epatch))
- (ediff-with-current-buffer ctl-buf
- (setq ediff-patchbufer patch-buf
- ediff-patch-diagnostics patch-diagnostics))
-
- (bury-buffer patch-diagnostics)
- (message "Type `P', if you need to see patch diagnostics")
- ctl-buf))
-
-(defun ediff-multi-patch-internal (patch-buf &optional startup-hooks)
- (let (meta-buf)
- (setq startup-hooks
- ;; this sets various vars in the meta buffer inside
- ;; ediff-prepare-meta-buffer
- (cons `(lambda ()
- ;; tell what to do if the user clicks on a session record
- (setq ediff-session-action-function
- 'ediff-patch-file-form-meta
- ediff-meta-patchbufer patch-buf) )
- startup-hooks))
- (setq meta-buf (ediff-prepare-meta-buffer
- 'ediff-filegroup-action
- (ediff-with-current-buffer patch-buf
- (cons (ediff-make-new-meta-list-header
- nil ; regexp
- (format "%S" patch-buf) ; obj A
- nil nil ; objects B,C
- nil ; merge-auto-store-dir
- nil ; comparison-func
- )
- ediff-patch-map))
- "*Ediff Session Group Panel"
- 'ediff-redraw-directory-group-buffer
- 'ediff-multifile-patch
- startup-hooks))
- (ediff-show-meta-buffer meta-buf)
- ))
-
-
-
-
-;; Local Variables:
-;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
-;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
-;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
-;; End:
-
-;; arch-tag: 2fe2161e-e116-469b-90fa-5cbb44c1bd1b
-;;; ediff-ptch.el ends here
+++ /dev/null
-;;; ediff-util.el --- the core commands and utilities of ediff
-
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-
-(provide 'ediff-util)
-
-;; Compiler pacifier
-(defvar ediff-use-toolbar-p)
-(defvar ediff-toolbar-height)
-(defvar ediff-toolbar)
-(defvar ediff-toolbar-3way)
-(defvar bottom-toolbar)
-(defvar bottom-toolbar-visible-p)
-(defvar bottom-toolbar-height)
-(defvar mark-active)
-
-(defvar ediff-after-quit-hook-internal nil)
-
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
-
-(eval-when-compile
- (require 'ediff))
-
-;; end pacifier
-
-
-(require 'ediff-init)
-(require 'ediff-help)
-(require 'ediff-mult)
-(require 'ediff-wind)
-(require 'ediff-diff)
-(require 'ediff-merg)
-;; for compatibility with current stable version of xemacs
-(if (featurep 'xemacs)
- (require 'ediff-tbar))
-
-\f
-;;; Functions
-
-(defun ediff-mode ()
- "Ediff mode controls all operations in a single Ediff session.
-This mode is entered through one of the following commands:
- `ediff'
- `ediff-files'
- `ediff-buffers'
- `ebuffers'
- `ediff3'
- `ediff-files3'
- `ediff-buffers3'
- `ebuffers3'
- `ediff-merge'
- `ediff-merge-files'
- `ediff-merge-files-with-ancestor'
- `ediff-merge-buffers'
- `ediff-merge-buffers-with-ancestor'
- `ediff-merge-revisions'
- `ediff-merge-revisions-with-ancestor'
- `ediff-windows-wordwise'
- `ediff-windows-linewise'
- `ediff-regions-wordwise'
- `ediff-regions-linewise'
- `epatch'
- `ediff-patch-file'
- `ediff-patch-buffer'
- `epatch-buffer'
- `erevision'
- `ediff-revision'
-
-Commands:
-\\{ediff-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'ediff-mode)
- (setq mode-name "Ediff")
- ;; We use run-hooks instead of run-mode-hooks for two reasons.
- ;; The ediff control buffer is read-only and it is not supposed to be
- ;; modified by minor modes and such. So, run-mode-hooks doesn't do anything
- ;; useful here on top of what run-hooks does.
- ;; Second, changing run-hooks to run-mode-hooks would require an
- ;; if-statement, since XEmacs doesn't have this.
- (run-hooks 'ediff-mode-hook))
-
-
-\f
-;;; Build keymaps
-
-(ediff-defvar-local ediff-mode-map nil
- "Local keymap used in Ediff mode.
-This is local to each Ediff Control Panel, so they may vary from invocation
-to invocation.")
-
-;; Set up the keymap in the control buffer
-(defun ediff-set-keys ()
- "Set up Ediff keymap, if necessary."
- (if (null ediff-mode-map)
- (ediff-setup-keymap))
- (use-local-map ediff-mode-map))
-
-;; Reload Ediff keymap. For debugging only.
-(defun ediff-reload-keymap ()
- (interactive)
- (setq ediff-mode-map nil)
- (ediff-set-keys))
-
-
-(defun ediff-setup-keymap ()
- "Set up the keymap used in the control buffer of Ediff."
- (setq ediff-mode-map (make-sparse-keymap))
- (suppress-keymap ediff-mode-map)
-
- (define-key ediff-mode-map
- (if (featurep 'emacs) [mouse-2] [button2]) 'ediff-help-for-quick-help)
- (define-key ediff-mode-map "\C-m" 'ediff-help-for-quick-help)
-
- (define-key ediff-mode-map "p" 'ediff-previous-difference)
- (define-key ediff-mode-map "\C-?" 'ediff-previous-difference)
- (define-key ediff-mode-map [delete] 'ediff-previous-difference)
- (define-key ediff-mode-map "\C-h" (if ediff-no-emacs-help-in-control-buffer
- 'ediff-previous-difference nil))
- ;; must come after C-h, or else C-h wipes out backspace's binding in XEmacs
- (define-key ediff-mode-map [backspace] 'ediff-previous-difference)
- (define-key ediff-mode-map "n" 'ediff-next-difference)
- (define-key ediff-mode-map " " 'ediff-next-difference)
- (define-key ediff-mode-map "j" 'ediff-jump-to-difference)
- (define-key ediff-mode-map "g" nil)
- (define-key ediff-mode-map "ga" 'ediff-jump-to-difference-at-point)
- (define-key ediff-mode-map "gb" 'ediff-jump-to-difference-at-point)
- (define-key ediff-mode-map "q" 'ediff-quit)
- (define-key ediff-mode-map "D" 'ediff-show-diff-output)
- (define-key ediff-mode-map "z" 'ediff-suspend)
- (define-key ediff-mode-map "\C-l" 'ediff-recenter)
- (define-key ediff-mode-map "|" 'ediff-toggle-split)
- (define-key ediff-mode-map "h" 'ediff-toggle-hilit)
- (or ediff-word-mode
- (define-key ediff-mode-map "@" 'ediff-toggle-autorefine))
- (if ediff-narrow-job
- (define-key ediff-mode-map "%" 'ediff-toggle-narrow-region))
- (define-key ediff-mode-map "~" 'ediff-swap-buffers)
- (define-key ediff-mode-map "v" 'ediff-scroll-vertically)
- (define-key ediff-mode-map "\C-v" 'ediff-scroll-vertically)
- (define-key ediff-mode-map "^" 'ediff-scroll-vertically)
- (define-key ediff-mode-map "\M-v" 'ediff-scroll-vertically)
- (define-key ediff-mode-map "V" 'ediff-scroll-vertically)
- (define-key ediff-mode-map "<" 'ediff-scroll-horizontally)
- (define-key ediff-mode-map ">" 'ediff-scroll-horizontally)
- (define-key ediff-mode-map "i" 'ediff-status-info)
- (define-key ediff-mode-map "E" 'ediff-documentation)
- (define-key ediff-mode-map "?" 'ediff-toggle-help)
- (define-key ediff-mode-map "!" 'ediff-update-diffs)
- (define-key ediff-mode-map "M" 'ediff-show-current-session-meta-buffer)
- (define-key ediff-mode-map "R" 'ediff-show-registry)
- (or ediff-word-mode
- (define-key ediff-mode-map "*" 'ediff-make-or-kill-fine-diffs))
- (define-key ediff-mode-map "a" nil)
- (define-key ediff-mode-map "b" nil)
- (define-key ediff-mode-map "r" nil)
- (cond (ediff-merge-job
- ;; Will barf if no ancestor
- (define-key ediff-mode-map "/" 'ediff-show-ancestor)
- ;; In merging, we allow only A->C and B->C copying.
- (define-key ediff-mode-map "a" 'ediff-copy-A-to-C)
- (define-key ediff-mode-map "b" 'ediff-copy-B-to-C)
- (define-key ediff-mode-map "r" 'ediff-restore-diff-in-merge-buffer)
- (define-key ediff-mode-map "s" 'ediff-shrink-window-C)
- (define-key ediff-mode-map "+" 'ediff-combine-diffs)
- (define-key ediff-mode-map "$" nil)
- (define-key ediff-mode-map "$$" 'ediff-toggle-show-clashes-only)
- (define-key ediff-mode-map "$*" 'ediff-toggle-skip-changed-regions)
- (define-key ediff-mode-map "&" 'ediff-re-merge))
- (ediff-3way-comparison-job
- (define-key ediff-mode-map "ab" 'ediff-copy-A-to-B)
- (define-key ediff-mode-map "ba" 'ediff-copy-B-to-A)
- (define-key ediff-mode-map "ac" 'ediff-copy-A-to-C)
- (define-key ediff-mode-map "bc" 'ediff-copy-B-to-C)
- (define-key ediff-mode-map "c" nil)
- (define-key ediff-mode-map "ca" 'ediff-copy-C-to-A)
- (define-key ediff-mode-map "cb" 'ediff-copy-C-to-B)
- (define-key ediff-mode-map "ra" 'ediff-restore-diff)
- (define-key ediff-mode-map "rb" 'ediff-restore-diff)
- (define-key ediff-mode-map "rc" 'ediff-restore-diff)
- (define-key ediff-mode-map "C" 'ediff-toggle-read-only))
- (t ; 2-way comparison
- (define-key ediff-mode-map "a" 'ediff-copy-A-to-B)
- (define-key ediff-mode-map "b" 'ediff-copy-B-to-A)
- (define-key ediff-mode-map "ra" 'ediff-restore-diff)
- (define-key ediff-mode-map "rb" 'ediff-restore-diff))
- ) ; cond
- (define-key ediff-mode-map "G" 'ediff-submit-report)
- (define-key ediff-mode-map "#" nil)
- (define-key ediff-mode-map "#h" 'ediff-toggle-regexp-match)
- (define-key ediff-mode-map "#f" 'ediff-toggle-regexp-match)
- (define-key ediff-mode-map "#c" 'ediff-toggle-ignore-case)
- (or ediff-word-mode
- (define-key ediff-mode-map "##" 'ediff-toggle-skip-similar))
- (define-key ediff-mode-map "o" nil)
- (define-key ediff-mode-map "A" 'ediff-toggle-read-only)
- (define-key ediff-mode-map "B" 'ediff-toggle-read-only)
- (define-key ediff-mode-map "w" nil)
- (define-key ediff-mode-map "wa" 'ediff-save-buffer)
- (define-key ediff-mode-map "wb" 'ediff-save-buffer)
- (define-key ediff-mode-map "wd" 'ediff-save-buffer)
- (define-key ediff-mode-map "=" 'ediff-inferior-compare-regions)
- (if (and (fboundp 'ediff-show-patch-diagnostics) (ediff-patch-job))
- (define-key ediff-mode-map "P" 'ediff-show-patch-diagnostics))
- (if ediff-3way-job
- (progn
- (define-key ediff-mode-map "wc" 'ediff-save-buffer)
- (define-key ediff-mode-map "gc" 'ediff-jump-to-difference-at-point)
- ))
-
- (define-key ediff-mode-map "m" 'ediff-toggle-wide-display)
-
- ;; Allow ediff-mode-map to be referenced indirectly
- (fset 'ediff-mode-map ediff-mode-map)
- (run-hooks 'ediff-keymap-setup-hook))
-
-
-;;; Setup functions
-
-;; Common startup entry for all Ediff functions It now returns control buffer
-;; so other functions can do post-processing SETUP-PARAMETERS is a list of the
-;; form ((param .val) (param . val)...) This serves a similar purpose to
-;; STARTUP-HOOKS, but these parameters are set in the new control buffer right
-;; after this buf is created and before any windows are set and such.
-(defun ediff-setup (buffer-A file-A buffer-B file-B buffer-C file-C
- startup-hooks setup-parameters
- &optional merge-buffer-file)
- (run-hooks 'ediff-before-setup-hook)
- ;; ediff-convert-standard-filename puts file names in the form appropriate
- ;; for the OS at hand.
- (setq file-A (ediff-convert-standard-filename (expand-file-name file-A)))
- (setq file-B (ediff-convert-standard-filename (expand-file-name file-B)))
- (if (stringp file-C)
- (setq file-C
- (ediff-convert-standard-filename (expand-file-name file-C))))
- (if (stringp merge-buffer-file)
- (progn
- (setq merge-buffer-file
- (ediff-convert-standard-filename
- (expand-file-name merge-buffer-file)))
- ;; check the directory exists
- (or (file-exists-p (file-name-directory merge-buffer-file))
- (error "Directory %s given as place to save the merge doesn't exist"
- (abbreviate-file-name
- (file-name-directory merge-buffer-file))))
- (if (and (file-exists-p merge-buffer-file)
- (file-directory-p merge-buffer-file))
- (error "The merge buffer file %s must not be a directory"
- (abbreviate-file-name merge-buffer-file)))
- ))
- (let* ((control-buffer-name
- (ediff-unique-buffer-name "*Ediff Control Panel" "*"))
- (control-buffer (ediff-with-current-buffer buffer-A
- (get-buffer-create control-buffer-name))))
- (ediff-with-current-buffer control-buffer
- (ediff-mode)
-
- (make-local-variable 'ediff-use-long-help-message)
- (make-local-variable 'ediff-prefer-iconified-control-frame)
- (make-local-variable 'ediff-split-window-function)
- (make-local-variable 'ediff-default-variant)
- (make-local-variable 'ediff-merge-window-share)
- (make-local-variable 'ediff-window-setup-function)
- (make-local-variable 'ediff-keep-variants)
-
- (make-local-variable 'window-min-height)
- (setq window-min-height 2)
-
- (if (featurep 'xemacs)
- (make-local-hook 'ediff-after-quit-hook-internal))
-
- ;; unwrap set up parameters passed as argument
- (while setup-parameters
- (set (car (car setup-parameters)) (cdr (car setup-parameters)))
- (setq setup-parameters (cdr setup-parameters)))
-
- ;; set variables classifying the current ediff job
- ;; must come AFTER setup-parameters
- (setq ediff-3way-comparison-job (ediff-3way-comparison-job)
- ediff-merge-job (ediff-merge-job)
- ediff-merge-with-ancestor-job (ediff-merge-with-ancestor-job)
- ediff-3way-job (ediff-3way-job)
- ediff-diff3-job (ediff-diff3-job)
- ediff-narrow-job (ediff-narrow-job)
- ediff-windows-job (ediff-windows-job)
- ediff-word-mode-job (ediff-word-mode-job))
-
- ;; Don't delete variants in case of ediff-buffer-* jobs without asking.
- ;; This is because one may loose work---dangerous.
- (if (string-match "buffer" (symbol-name ediff-job-name))
- (setq ediff-keep-variants t))
-
- (if (featurep 'xemacs)
- (make-local-hook 'pre-command-hook))
-
- (if (ediff-window-display-p)
- (add-hook 'pre-command-hook 'ediff-spy-after-mouse nil 'local))
- (setq ediff-mouse-pixel-position (mouse-pixel-position))
-
- ;; adjust for merge jobs
- (if ediff-merge-job
- (let ((buf
- ;; If default variant is `combined', the right stuff is
- ;; inserted by ediff-do-merge
- ;; Note: at some point, we tried to put ancestor buffer here
- ;; (which is currently buffer C. This didn't work right
- ;; because the merge buffer will contain lossage: diff regions
- ;; in the ancestor, which correspond to revisions that agree
- ;; in both buf A and B.
- (cond ((eq ediff-default-variant 'default-B)
- buffer-B)
- (t buffer-A))))
-
- (setq ediff-split-window-function
- ediff-merge-split-window-function)
-
- ;; remember the ancestor buffer, if any
- (setq ediff-ancestor-buffer buffer-C)
-
- (setq buffer-C
- (get-buffer-create
- (ediff-unique-buffer-name "*ediff-merge" "*")))
- (with-current-buffer buffer-C
- (insert-buffer-substring buf)
- (goto-char (point-min))
- (funcall (ediff-with-current-buffer buf major-mode))
- (widen) ; merge buffer is always widened
- (add-hook 'local-write-file-hooks 'ediff-set-merge-mode nil t)
- )))
- (setq buffer-read-only nil
- ediff-buffer-A buffer-A
- ediff-buffer-B buffer-B
- ediff-buffer-C buffer-C
- ediff-control-buffer control-buffer)
-
- (ediff-choose-syntax-table)
-
- (setq ediff-control-buffer-suffix
- (if (string-match "<[0-9]*>" control-buffer-name)
- (substring control-buffer-name
- (match-beginning 0) (match-end 0))
- "")
- ediff-control-buffer-number
- (max
- 0
- (1-
- (string-to-number
- (substring
- ediff-control-buffer-suffix
- (or
- (string-match "[0-9]+" ediff-control-buffer-suffix)
- 0))))))
-
- (setq ediff-error-buffer
- (get-buffer-create (ediff-unique-buffer-name "*ediff-errors" "*")))
-
- (with-current-buffer ediff-error-buffer
- (setq buffer-undo-list t))
-
- (ediff-with-current-buffer buffer-A (ediff-strip-mode-line-format))
- (ediff-with-current-buffer buffer-B (ediff-strip-mode-line-format))
- (if ediff-3way-job
- (ediff-with-current-buffer buffer-C (ediff-strip-mode-line-format)))
- (if (ediff-buffer-live-p ediff-ancestor-buffer)
- (ediff-with-current-buffer ediff-ancestor-buffer
- (ediff-strip-mode-line-format)))
-
- (ediff-save-protected-variables) ; save variables to be restored on exit
-
- ;; ediff-setup-diff-regions-function must be set after setup
- ;; parameters are processed.
- (setq ediff-setup-diff-regions-function
- (if ediff-diff3-job
- 'ediff-setup-diff-regions3
- 'ediff-setup-diff-regions))
-
- (setq ediff-wide-bounds
- (list (ediff-make-bullet-proof-overlay
- '(point-min) '(point-max) ediff-buffer-A)
- (ediff-make-bullet-proof-overlay
- '(point-min) '(point-max) ediff-buffer-B)
- (ediff-make-bullet-proof-overlay
- '(point-min) '(point-max) ediff-buffer-C)))
-
- ;; This has effect only on ediff-windows/regions
- ;; In all other cases, ediff-visible-region sets visibility bounds to
- ;; ediff-wide-bounds, and ediff-narrow-bounds are ignored.
- (if ediff-start-narrowed
- (setq ediff-visible-bounds ediff-narrow-bounds)
- (setq ediff-visible-bounds ediff-wide-bounds))
-
- (ediff-set-keys) ; comes after parameter setup
-
- ;; set up ediff-narrow-bounds, if not set
- (or ediff-narrow-bounds
- (setq ediff-narrow-bounds ediff-wide-bounds))
-
- ;; All these must be inside ediff-with-current-buffer control-buffer,
- ;; since these vars are local to control-buffer
- ;; These won't run if there are errors in diff
- (ediff-with-current-buffer ediff-buffer-A
- (ediff-nuke-selective-display)
- (run-hooks 'ediff-prepare-buffer-hook)
- (if (ediff-with-current-buffer control-buffer ediff-merge-job)
- (setq buffer-read-only t))
- ;; add control-buffer to the list of sessions--no longer used, but may
- ;; be used again in the future
- (or (memq control-buffer ediff-this-buffer-ediff-sessions)
- (setq ediff-this-buffer-ediff-sessions
- (cons control-buffer ediff-this-buffer-ediff-sessions)))
- (if ediff-make-buffers-readonly-at-startup
- (setq buffer-read-only t))
- )
-
- (ediff-with-current-buffer ediff-buffer-B
- (ediff-nuke-selective-display)
- (run-hooks 'ediff-prepare-buffer-hook)
- (if (ediff-with-current-buffer control-buffer ediff-merge-job)
- (setq buffer-read-only t))
- ;; add control-buffer to the list of sessions
- (or (memq control-buffer ediff-this-buffer-ediff-sessions)
- (setq ediff-this-buffer-ediff-sessions
- (cons control-buffer ediff-this-buffer-ediff-sessions)))
- (if ediff-make-buffers-readonly-at-startup
- (setq buffer-read-only t))
- )
-
- (if ediff-3way-job
- (ediff-with-current-buffer ediff-buffer-C
- (ediff-nuke-selective-display)
- ;; the merge bufer should never be narrowed
- ;; (it can happen if it is on rmail-mode or similar)
- (if (ediff-with-current-buffer control-buffer ediff-merge-job)
- (widen))
- (run-hooks 'ediff-prepare-buffer-hook)
- ;; add control-buffer to the list of sessions
- (or (memq control-buffer ediff-this-buffer-ediff-sessions)
- (setq ediff-this-buffer-ediff-sessions
- (cons control-buffer
- ediff-this-buffer-ediff-sessions)))
- (if ediff-make-buffers-readonly-at-startup
- (setq buffer-read-only t)
- (setq buffer-read-only nil))
- ))
-
- (if (ediff-buffer-live-p ediff-ancestor-buffer)
- (ediff-with-current-buffer ediff-ancestor-buffer
- (ediff-nuke-selective-display)
- (setq buffer-read-only t)
- (run-hooks 'ediff-prepare-buffer-hook)
- (or (memq control-buffer ediff-this-buffer-ediff-sessions)
- (setq ediff-this-buffer-ediff-sessions
- (cons control-buffer
- ediff-this-buffer-ediff-sessions)))
- ))
-
- ;; the following must be after setting up ediff-narrow-bounds AND after
- ;; nuking selective display
- (funcall ediff-setup-diff-regions-function file-A file-B file-C)
- (setq ediff-number-of-differences (length ediff-difference-vector-A))
- (setq ediff-current-difference -1)
-
- (ediff-make-current-diff-overlay 'A)
- (ediff-make-current-diff-overlay 'B)
- (if ediff-3way-job
- (ediff-make-current-diff-overlay 'C))
- (if ediff-merge-with-ancestor-job
- (ediff-make-current-diff-overlay 'Ancestor))
-
- (ediff-setup-windows buffer-A buffer-B buffer-C control-buffer)
-
- (let ((shift-A (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type
- 'A ediff-narrow-bounds)))
- (shift-B (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type
- 'B ediff-narrow-bounds)))
- (shift-C (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type
- 'C ediff-narrow-bounds))))
- ;; position point in buf A
- (save-excursion
- (select-window ediff-window-A)
- (goto-char shift-A))
- ;; position point in buf B
- (save-excursion
- (select-window ediff-window-B)
- (goto-char shift-B))
- (if ediff-3way-job
- (save-excursion
- (select-window ediff-window-C)
- (goto-char shift-C)))
- )
-
- (select-window ediff-control-window)
- (ediff-visible-region)
-
- (run-hooks 'startup-hooks)
- (ediff-arrange-autosave-in-merge-jobs merge-buffer-file)
-
- (ediff-refresh-mode-lines)
- (setq buffer-read-only t)
- (setq ediff-session-registry
- (cons control-buffer ediff-session-registry))
- (ediff-update-registry)
- (if (ediff-buffer-live-p ediff-meta-buffer)
- (ediff-update-meta-buffer
- ediff-meta-buffer nil ediff-meta-session-number))
- (run-hooks 'ediff-startup-hook)
- ) ; eval in control-buffer
- control-buffer))
-
-
-;; This function assumes that we are in the window where control buffer is
-;; to reside.
-(defun ediff-setup-control-buffer (ctl-buf)
- "Set up window for control buffer."
- (if (window-dedicated-p (selected-window))
- (set-buffer ctl-buf) ; we are in control frame but just in case
- (switch-to-buffer ctl-buf))
- (let ((window-min-height 2))
- (erase-buffer)
- (ediff-set-help-message)
- (insert ediff-help-message)
- (shrink-window-if-larger-than-buffer)
- (or (ediff-multiframe-setup-p)
- (ediff-indent-help-message))
- (ediff-set-help-overlays)
-
- (set-buffer-modified-p nil)
- (ediff-refresh-mode-lines)
- (setq ediff-control-window (selected-window))
- (setq ediff-window-config-saved
- (format "%S%S%S%S%S%S%S"
- ediff-control-window
- ediff-window-A
- ediff-window-B
- ediff-window-C
- ediff-split-window-function
- (ediff-multiframe-setup-p)
- ediff-wide-display-p))
-
- (set-window-dedicated-p (selected-window) t)
- ;; In multiframe, toolbar is set in ediff-setup-control-frame
- (if (not (ediff-multiframe-setup-p))
- (ediff-make-bottom-toolbar)) ; this checks if toolbar is requested
- (goto-char (point-min))
- (skip-chars-forward ediff-whitespace)))
-
-;; This executes in control buffer and sets auto-save, visited file name, etc,
-;; in the merge buffer
-(defun ediff-arrange-autosave-in-merge-jobs (merge-buffer-file)
- (if (not ediff-merge-job)
- ()
- (if (stringp merge-buffer-file)
- (setq ediff-autostore-merges t
- ediff-merge-store-file merge-buffer-file))
- (if (stringp ediff-merge-store-file)
- (progn
- ;; save before leaving ctl buffer
- (ediff-verify-file-merge-buffer ediff-merge-store-file)
- (setq merge-buffer-file ediff-merge-store-file)
- (ediff-with-current-buffer ediff-buffer-C
- (set-visited-file-name merge-buffer-file))))
- (ediff-with-current-buffer ediff-buffer-C
- (setq buffer-offer-save t) ; ask before killing buffer
- ;; make sure the contents is auto-saved
- (auto-save-mode 1))
- ))
-
-\f
-;;; Commands for working with Ediff
-
-(defun ediff-update-diffs ()
- "Recompute difference regions in buffers A, B, and C.
-Buffers are not synchronized with their respective files, so changes done
-to these buffers are not saved at this point---the user can do this later,
-if necessary."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (if (and (ediff-buffer-live-p ediff-ancestor-buffer)
- (not
- (y-or-n-p
- "Ancestor buffer will not be used. Recompute diffs anyway? ")))
- (error "Recomputation of differences canceled"))
-
- (let ((point-A (ediff-with-current-buffer ediff-buffer-A (point)))
- ;;(point-B (ediff-with-current-buffer ediff-buffer-B (point)))
- (tmp-buffer (get-buffer-create ediff-tmp-buffer))
- (buf-A-file-name (buffer-file-name ediff-buffer-A))
- (buf-B-file-name (buffer-file-name ediff-buffer-B))
- ;; (null ediff-buffer-C) is no problem, as we later check if
- ;; ediff-buffer-C is alive
- (buf-C-file-name (buffer-file-name ediff-buffer-C))
- (overl-A (ediff-get-value-according-to-buffer-type
- 'A ediff-narrow-bounds))
- (overl-B (ediff-get-value-according-to-buffer-type
- 'B ediff-narrow-bounds))
- (overl-C (ediff-get-value-according-to-buffer-type
- 'C ediff-narrow-bounds))
- beg-A end-A beg-B end-B beg-C end-C
- file-A file-B file-C)
-
- (if (stringp buf-A-file-name)
- (setq buf-A-file-name (file-name-nondirectory buf-A-file-name)))
- (if (stringp buf-B-file-name)
- (setq buf-B-file-name (file-name-nondirectory buf-B-file-name)))
- (if (stringp buf-C-file-name)
- (setq buf-C-file-name (file-name-nondirectory buf-C-file-name)))
-
- (ediff-unselect-and-select-difference -1)
-
- (setq beg-A (ediff-overlay-start overl-A)
- beg-B (ediff-overlay-start overl-B)
- beg-C (ediff-overlay-start overl-C)
- end-A (ediff-overlay-end overl-A)
- end-B (ediff-overlay-end overl-B)
- end-C (ediff-overlay-end overl-C))
-
- (if ediff-word-mode
- (progn
- (ediff-wordify beg-A end-A ediff-buffer-A tmp-buffer)
- (setq file-A (ediff-make-temp-file tmp-buffer "regA"))
- (ediff-wordify beg-B end-B ediff-buffer-B tmp-buffer)
- (setq file-B (ediff-make-temp-file tmp-buffer "regB"))
- (if ediff-3way-job
- (progn
- (ediff-wordify beg-C end-C ediff-buffer-C tmp-buffer)
- (setq file-C (ediff-make-temp-file tmp-buffer "regC"))))
- )
- ;; not word-mode
- (setq file-A (ediff-make-temp-file ediff-buffer-A buf-A-file-name))
- (setq file-B (ediff-make-temp-file ediff-buffer-B buf-B-file-name))
- (if ediff-3way-job
- (setq file-C (ediff-make-temp-file ediff-buffer-C buf-C-file-name)))
- )
-
- (ediff-clear-diff-vector 'ediff-difference-vector-A 'fine-diffs-also)
- (ediff-clear-diff-vector 'ediff-difference-vector-B 'fine-diffs-also)
- (ediff-clear-diff-vector 'ediff-difference-vector-C 'fine-diffs-also)
- (ediff-clear-diff-vector
- 'ediff-difference-vector-Ancestor 'fine-diffs-also)
- ;; let them garbage collect. we can't use the ancestor after recomputing
- ;; the diffs.
- (setq ediff-difference-vector-Ancestor nil
- ediff-ancestor-buffer nil
- ediff-state-of-merge nil)
-
- (setq ediff-killed-diffs-alist nil) ; invalidate saved killed diff regions
-
- ;; In case of merge job, fool it into thinking that it is just doing
- ;; comparison
- (let ((ediff-setup-diff-regions-function ediff-setup-diff-regions-function)
- (ediff-3way-comparison-job ediff-3way-comparison-job)
- (ediff-merge-job ediff-merge-job)
- (ediff-merge-with-ancestor-job ediff-merge-with-ancestor-job)
- (ediff-job-name ediff-job-name))
- (if ediff-merge-job
- (setq ediff-setup-diff-regions-function 'ediff-setup-diff-regions3
- ediff-3way-comparison-job t
- ediff-merge-job nil
- ediff-merge-with-ancestor-job nil
- ediff-job-name 'ediff-files3))
- (funcall ediff-setup-diff-regions-function file-A file-B file-C))
-
- (setq ediff-number-of-differences (length ediff-difference-vector-A))
- (delete-file file-A)
- (delete-file file-B)
- (if file-C
- (delete-file file-C))
-
- (if ediff-3way-job
- (ediff-set-state-of-all-diffs-in-all-buffers ediff-control-buffer))
-
- (ediff-jump-to-difference (ediff-diff-at-point 'A point-A))
- (message "")
- ))
-
-;; Not bound to any key---to dangerous. A user can do it if necessary.
-(defun ediff-revert-buffers-then-recompute-diffs (noconfirm)
- "Revert buffers A, B and C. Then rerun Ediff on file A and file B."
- (interactive "P")
- (ediff-barf-if-not-control-buffer)
- (let ((bufA ediff-buffer-A)
- (bufB ediff-buffer-B)
- (bufC ediff-buffer-C)
- (ctl-buf ediff-control-buffer)
- (keep-variants ediff-keep-variants)
- (ancestor-buf ediff-ancestor-buffer)
- (ancestor-job ediff-merge-with-ancestor-job)
- (merge ediff-merge-job)
- (comparison ediff-3way-comparison-job))
- (ediff-with-current-buffer bufA
- (revert-buffer t noconfirm))
- (ediff-with-current-buffer bufB
- (revert-buffer t noconfirm))
- ;; this should only be executed in a 3way comparison, not in merge
- (if comparison
- (ediff-with-current-buffer bufC
- (revert-buffer t noconfirm)))
- (if merge
- (progn
- (set-buffer ctl-buf)
- ;; the argument says whether to reverse the meaning of
- ;; ediff-keep-variants, i.e., ediff-really-quit runs here with
- ;; variants kept.
- (ediff-really-quit (not keep-variants))
- (kill-buffer bufC)
- (if ancestor-job
- (ediff-merge-buffers-with-ancestor bufA bufB ancestor-buf)
- (ediff-merge-buffers bufA bufB)))
- (ediff-update-diffs))))
-
-
-;; optional NO-REHIGHLIGHT says to not rehighlight buffers
-(defun ediff-recenter (&optional no-rehighlight)
- "Bring the highlighted region of all buffers being compared into view.
-Reestablish the default three-window display."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (let (buffer-read-only)
- (if (and (ediff-buffer-live-p ediff-buffer-A)
- (ediff-buffer-live-p ediff-buffer-B)
- (or (not ediff-3way-job)
- (ediff-buffer-live-p ediff-buffer-C)))
- (ediff-setup-windows
- ediff-buffer-A ediff-buffer-B ediff-buffer-C ediff-control-buffer)
- (or (eq this-command 'ediff-quit)
- (message ediff-KILLED-VITAL-BUFFER
- (beep 1)))
- ))
-
- ;; set visibility range appropriate to this invocation of Ediff.
- (ediff-visible-region)
- ;; raise
- (if (and (ediff-window-display-p)
- (symbolp this-command)
- (symbolp last-command)
- ;; Either one of the display-changing commands
- (or (memq this-command
- '(ediff-recenter
- ediff-dir-action ediff-registry-action
- ediff-patch-action
- ediff-toggle-wide-display ediff-toggle-multiframe))
- ;; Or one of the movement cmds and prev cmd was an Ediff cmd
- ;; This avoids raising frames unnecessarily.
- (and (memq this-command
- '(ediff-next-difference
- ediff-previous-difference
- ediff-jump-to-difference
- ediff-jump-to-difference-at-point))
- (not (string-match "^ediff-" (symbol-name last-command)))
- )))
- (progn
- (if (window-live-p ediff-window-A)
- (raise-frame (window-frame ediff-window-A)))
- (if (window-live-p ediff-window-B)
- (raise-frame (window-frame ediff-window-B)))
- (if (window-live-p ediff-window-C)
- (raise-frame (window-frame ediff-window-C)))))
- (if (and (ediff-window-display-p)
- (frame-live-p ediff-control-frame)
- (not ediff-use-long-help-message)
- (not (ediff-frame-iconified-p ediff-control-frame)))
- (raise-frame ediff-control-frame))
-
- ;; Redisplay whatever buffers are showing, if there is a selected difference
- (let ((control-frame ediff-control-frame)
- (control-buf ediff-control-buffer))
- (if (and (ediff-buffer-live-p ediff-buffer-A)
- (ediff-buffer-live-p ediff-buffer-B)
- (or (not ediff-3way-job)
- (ediff-buffer-live-p ediff-buffer-C)))
- (progn
- (or no-rehighlight
- (ediff-select-difference ediff-current-difference))
-
- (ediff-recenter-one-window 'A)
- (ediff-recenter-one-window 'B)
- (if ediff-3way-job
- (ediff-recenter-one-window 'C))
-
- (ediff-with-current-buffer control-buf
- (ediff-recenter-ancestor) ; check if ancestor is alive
-
- (if (and (ediff-multiframe-setup-p)
- (not ediff-use-long-help-message)
- (not (ediff-frame-iconified-p ediff-control-frame)))
- ;; never grab mouse on quit in this place
- (ediff-reset-mouse
- control-frame
- (eq this-command 'ediff-quit))))
- ))
-
- (or no-rehighlight
- (ediff-restore-highlighting))
- (ediff-with-current-buffer control-buf (ediff-refresh-mode-lines))
- ))
-
-;; this function returns to the window it was called from
-;; (which was the control window)
-(defun ediff-recenter-one-window (buf-type)
- (if (ediff-valid-difference-p)
- ;; context must be saved before switching to windows A/B/C
- (let* ((ctl-wind (selected-window))
- (shift (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type
- buf-type ediff-narrow-bounds)))
- (job-name ediff-job-name)
- (control-buf ediff-control-buffer)
- (window-name (ediff-get-symbol-from-alist
- buf-type ediff-window-alist))
- (window (if (window-live-p (symbol-value window-name))
- (symbol-value window-name))))
-
- (if (and window ediff-windows-job)
- (set-window-start window shift))
- (if window
- (progn
- (select-window window)
- (ediff-deactivate-mark)
- (ediff-position-region
- (ediff-get-diff-posn buf-type 'beg nil control-buf)
- (ediff-get-diff-posn buf-type 'end nil control-buf)
- (ediff-get-diff-posn buf-type 'beg nil control-buf)
- job-name
- )))
- (select-window ctl-wind)
- )))
-
-(defun ediff-recenter-ancestor ()
- ;; do half-hearted job by recentering the ancestor buffer, if it is alive and
- ;; visible.
- (if (and (ediff-buffer-live-p ediff-ancestor-buffer)
- (ediff-valid-difference-p))
- (let ((window (ediff-get-visible-buffer-window ediff-ancestor-buffer))
- (ctl-wind (selected-window))
- (job-name ediff-job-name)
- (ctl-buf ediff-control-buffer))
- (ediff-with-current-buffer ediff-ancestor-buffer
- (goto-char (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf))
- (if window
- (progn
- (select-window window)
- (ediff-position-region
- (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf)
- (ediff-get-diff-posn 'Ancestor 'end nil ctl-buf)
- (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf)
- job-name))))
- (select-window ctl-wind)
- )))
-
-
-;; This will have to be refined for 3way jobs
-(defun ediff-toggle-split ()
- "Toggle vertical/horizontal window split.
-Does nothing if file-A and file-B are in different frames."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (let* ((wind-A (if (window-live-p ediff-window-A) ediff-window-A))
- (wind-B (if (window-live-p ediff-window-B) ediff-window-B))
- (wind-C (if (window-live-p ediff-window-C) ediff-window-C))
- (frame-A (if wind-A (window-frame wind-A)))
- (frame-B (if wind-B (window-frame wind-B)))
- (frame-C (if wind-C (window-frame wind-C))))
- (if (or (eq frame-A frame-B)
- (not (frame-live-p frame-A))
- (not (frame-live-p frame-B))
- (if ediff-3way-comparison-job
- (or (not (frame-live-p frame-C))
- (eq frame-A frame-C) (eq frame-B frame-C))))
- (setq ediff-split-window-function
- (if (eq ediff-split-window-function 'split-window-vertically)
- 'split-window-horizontally
- 'split-window-vertically))
- (message "Buffers being compared are in different frames"))
- (ediff-recenter 'no-rehighlight)))
-
-(defun ediff-toggle-hilit ()
- "Switch between highlighting using ASCII flags and highlighting using faces.
-On a dumb terminal, switches between ASCII highlighting and no highlighting."
- (interactive)
- (ediff-barf-if-not-control-buffer)
-
- (ediff-unselect-and-select-difference
- ediff-current-difference 'unselect-only)
- ;; cycle through highlighting
- (cond ((and ediff-use-faces
- (ediff-has-face-support-p)
- ediff-highlight-all-diffs)
- (message "Unhighlighting unselected difference regions")
- (setq ediff-highlight-all-diffs nil
- ediff-highlighting-style 'face))
- ((or (and ediff-use-faces (ediff-has-face-support-p)
- (eq ediff-highlighting-style 'face)) ; has face support
- (and (not (ediff-has-face-support-p)) ; no face support
- (eq ediff-highlighting-style 'off)))
- (message "Highlighting with ASCII flags")
- (setq ediff-highlighting-style 'ascii
- ediff-highlight-all-diffs nil
- ediff-use-faces nil))
- ((eq ediff-highlighting-style 'ascii)
- (message "ASCII highlighting flags removed")
- (setq ediff-highlighting-style 'off
- ediff-highlight-all-diffs nil))
- ((ediff-has-face-support-p) ; catch-all for cases with face support
- (message "Re-highlighting all difference regions")
- (setq ediff-use-faces t
- ediff-highlighting-style 'face
- ediff-highlight-all-diffs t)))
-
- (if (and ediff-use-faces ediff-highlight-all-diffs)
- (ediff-paint-background-regions)
- (ediff-paint-background-regions 'unhighlight))
-
- (ediff-unselect-and-select-difference
- ediff-current-difference 'select-only))
-
-
-(defun ediff-toggle-autorefine ()
- "Toggle auto-refine mode."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (if ediff-word-mode
- (error "No fine differences in this mode"))
- (cond ((eq ediff-auto-refine 'nix)
- (setq ediff-auto-refine 'on)
- (ediff-make-fine-diffs ediff-current-difference 'noforce)
- (message "Auto-refining is ON"))
- ((eq ediff-auto-refine 'on)
- (message "Auto-refining is OFF")
- (setq ediff-auto-refine 'off))
- (t ;; nix 'em
- (ediff-set-fine-diff-properties ediff-current-difference 'default)
- (message "Refinements are HIDDEN")
- (setq ediff-auto-refine 'nix))
- ))
-
-(defun ediff-show-ancestor ()
- "Show the ancestor buffer in a suitable window."
- (interactive)
- (ediff-recenter)
- (or (ediff-buffer-live-p ediff-ancestor-buffer)
- (if ediff-merge-with-ancestor-job
- (error "Lost connection to ancestor buffer...sorry")
- (error "Not merging with ancestor")))
- (let (wind)
- (cond ((setq wind (ediff-get-visible-buffer-window ediff-ancestor-buffer))
- (raise-frame (window-frame wind)))
- (t (set-window-buffer ediff-window-C ediff-ancestor-buffer)))))
-
-(defun ediff-make-or-kill-fine-diffs (arg)
- "Compute fine diffs. With negative prefix arg, kill fine diffs.
-In both cases, operates on the current difference region."
- (interactive "P")
- (ediff-barf-if-not-control-buffer)
- (cond ((eq arg '-)
- (ediff-clear-fine-differences ediff-current-difference))
- ((and (numberp arg) (< arg 0))
- (ediff-clear-fine-differences ediff-current-difference))
- (t (ediff-make-fine-diffs))))
-
-
-(defun ediff-toggle-help ()
- "Toggle short/long help message."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (let (buffer-read-only)
- (erase-buffer)
- (setq ediff-use-long-help-message (not ediff-use-long-help-message))
- (ediff-set-help-message))
- ;; remember the icon status of the control frame when the user requested
- ;; full control message
- (if (and ediff-use-long-help-message (ediff-multiframe-setup-p))
- (setq ediff-prefer-iconified-control-frame
- (ediff-frame-iconified-p ediff-control-frame)))
-
- (setq ediff-window-config-saved "") ; force redisplay
- (ediff-recenter 'no-rehighlight))
-
-
-;; If BUF, this is the buffer to toggle, not current buffer.
-(defun ediff-toggle-read-only (&optional buf)
- "Toggle read-only in current buffer.
-If buffer is under version control and locked, check it out first.
-If optional argument BUF is specified, toggle read-only in that buffer instead
-of the current buffer."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (let ((ctl-buf (if (null buf) (current-buffer)))
- (buf-type (ediff-char-to-buftype (ediff-last-command-char))))
- (or buf (ediff-recenter))
- (or buf
- (setq buf (ediff-get-buffer buf-type)))
-
- (ediff-with-current-buffer buf ; eval in buf A/B/C
- (let* ((file (buffer-file-name buf))
- (file-writable (and file
- (file-exists-p file)
- (file-writable-p file)))
- (toggle-ro-cmd (cond (ediff-toggle-read-only-function)
- ((ediff-file-checked-out-p file)
- 'toggle-read-only)
- (file-writable 'toggle-read-only)
- (t (key-binding "\C-x\C-q")))))
- ;; If the file is checked in, make sure we don't make buffer modifiable
- ;; without warning the user. The user can fool our checks by making the
- ;; buffer non-RO without checking the file out. We regard this as a
- ;; user problem.
- (if (and (ediff-file-checked-in-p file)
- ;; If ctl-buf is null, this means we called this
- ;; non-interactively, in which case don't ask questions
- ctl-buf)
- (cond ((not buffer-read-only)
- (setq toggle-ro-cmd 'toggle-read-only))
- ((and (or (beep 1) t) ; always beep
- (y-or-n-p
- (format
- "File %s is under version control. Check it out? "
- (ediff-abbreviate-file-name file))))
- ;; if we checked the file out, we should also change the
- ;; original state of buffer-read-only to nil. If we don't
- ;; do this, the mode line will show %%, since the file was
- ;; RO before ediff started, so the user will think the file
- ;; is checked in.
- (ediff-with-current-buffer ctl-buf
- (ediff-change-saved-variable
- 'buffer-read-only nil buf-type)))
- (t
- (setq toggle-ro-cmd 'toggle-read-only)
- (beep 1) (beep 1)
- (message
- "Boy, this is risky! Don't modify this file...")
- (sit-for 3)))) ; let the user see the warning
- (if (and toggle-ro-cmd
- (string-match "toggle-read-only" (symbol-name toggle-ro-cmd)))
- (save-excursion
- (save-window-excursion
- (select-window (ediff-get-visible-buffer-window buf))
- (command-execute toggle-ro-cmd)))
- (error "Don't know how to toggle read-only in buffer %S" buf))
-
- ;; Check if we made the current buffer updatable, but its file is RO.
- ;; Signal a warning in this case.
- (if (and file (not buffer-read-only)
- (eq this-command 'ediff-toggle-read-only)
- (file-exists-p file)
- (not (file-writable-p file)))
- (progn
- (beep 1)
- (message "Warning: file %s is read-only"
- (ediff-abbreviate-file-name file))))
- ))))
-
-;; checkout if visited file is checked in
-(defun ediff-maybe-checkout (buf)
- (let ((file (expand-file-name (buffer-file-name buf)))
- (checkout-function (key-binding "\C-x\C-q")))
- (if (and (ediff-file-checked-in-p file)
- (or (beep 1) t)
- (y-or-n-p
- (format
- "File %s is under version control. Check it out? "
- (ediff-abbreviate-file-name file))))
- (ediff-with-current-buffer buf
- (command-execute checkout-function)))))
-
-
-;; This is a simple-minded check for whether a file is under version control.
-;; If file,v exists but file doesn't, this file is considered to be not checked
-;; in and not checked out for the purpose of patching (since patch won't be
-;; able to read such a file anyway).
-;; FILE is a string representing file name
-;;(defun ediff-file-under-version-control (file)
-;; (let* ((filedir (file-name-directory file))
-;; (file-nondir (file-name-nondirectory file))
-;; (trial (concat file-nondir ",v"))
-;; (full-trial (concat filedir trial))
-;; (full-rcs-trial (concat filedir "RCS/" trial)))
-;; (and (stringp file)
-;; (file-exists-p file)
-;; (or
-;; (and
-;; (file-exists-p full-trial)
-;; ;; in FAT FS, `file,v' and `file' may turn out to be the same!
-;; ;; don't be fooled by this!
-;; (not (equal (file-attributes file)
-;; (file-attributes full-trial))))
-;; ;; check if a version is in RCS/ directory
-;; (file-exists-p full-rcs-trial)))
-;; ))
-
-
-(defun ediff-file-checked-out-p (file)
- (or (not (featurep 'vc-hooks))
- (and (vc-backend file)
- (if (fboundp 'vc-state)
- (or (memq (vc-state file) '(edited needs-merge))
- (stringp (vc-state file)))
- ;; XEmacs has no vc-state
- (when (featurep 'xemacs) (vc-locking-user file)))
- )))
-
-(defun ediff-file-checked-in-p (file)
- (and (featurep 'vc-hooks)
- ;; Only RCS and SCCS files are considered checked in
- (memq (vc-backend file) '(RCS SCCS))
- (if (fboundp 'vc-state)
- (and
- (not (memq (vc-state file) '(edited needs-merge)))
- (not (stringp (vc-state file))))
- ;; XEmacs has no vc-state
- (when (featurep 'xemacs) (not (vc-locking-user file))))
- ))
-
-(defun ediff-file-compressed-p (file)
- (condition-case nil
- (require 'jka-compr)
- (error))
- (if (featurep 'jka-compr)
- (string-match (jka-compr-build-file-regexp) file)))
-
-
-(defun ediff-swap-buffers ()
- "Rotate the display of buffers A, B, and C."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (if (and (window-live-p ediff-window-A) (window-live-p ediff-window-B))
- (let ((buf ediff-buffer-A)
- (values ediff-buffer-values-orig-A)
- (diff-vec ediff-difference-vector-A)
- (hide-regexp ediff-regexp-hide-A)
- (focus-regexp ediff-regexp-focus-A)
- (wide-visibility-p (eq ediff-visible-bounds ediff-wide-bounds))
- (overlay (if (ediff-has-face-support-p)
- ediff-current-diff-overlay-A)))
- (if ediff-3way-comparison-job
- (progn
- (set-window-buffer ediff-window-A ediff-buffer-C)
- (set-window-buffer ediff-window-B ediff-buffer-A)
- (set-window-buffer ediff-window-C ediff-buffer-B)
- )
- (set-window-buffer ediff-window-A ediff-buffer-B)
- (set-window-buffer ediff-window-B ediff-buffer-A))
- ;; swap diff buffers
- (if ediff-3way-comparison-job
- (setq ediff-buffer-A ediff-buffer-C
- ediff-buffer-C ediff-buffer-B
- ediff-buffer-B buf)
- (setq ediff-buffer-A ediff-buffer-B
- ediff-buffer-B buf))
-
- ;; swap saved buffer characteristics
- (if ediff-3way-comparison-job
- (setq ediff-buffer-values-orig-A ediff-buffer-values-orig-C
- ediff-buffer-values-orig-C ediff-buffer-values-orig-B
- ediff-buffer-values-orig-B values)
- (setq ediff-buffer-values-orig-A ediff-buffer-values-orig-B
- ediff-buffer-values-orig-B values))
-
- ;; swap diff vectors
- (if ediff-3way-comparison-job
- (setq ediff-difference-vector-A ediff-difference-vector-C
- ediff-difference-vector-C ediff-difference-vector-B
- ediff-difference-vector-B diff-vec)
- (setq ediff-difference-vector-A ediff-difference-vector-B
- ediff-difference-vector-B diff-vec))
-
- ;; swap hide/focus regexp
- (if ediff-3way-comparison-job
- (setq ediff-regexp-hide-A ediff-regexp-hide-C
- ediff-regexp-hide-C ediff-regexp-hide-B
- ediff-regexp-hide-B hide-regexp
- ediff-regexp-focus-A ediff-regexp-focus-C
- ediff-regexp-focus-C ediff-regexp-focus-B
- ediff-regexp-focus-B focus-regexp)
- (setq ediff-regexp-hide-A ediff-regexp-hide-B
- ediff-regexp-hide-B hide-regexp
- ediff-regexp-focus-A ediff-regexp-focus-B
- ediff-regexp-focus-B focus-regexp))
-
- ;; The following is needed for XEmacs, since there one can't move
- ;; overlay to another buffer. In Emacs, this swap is redundant.
- (if (ediff-has-face-support-p)
- (if ediff-3way-comparison-job
- (setq ediff-current-diff-overlay-A ediff-current-diff-overlay-C
- ediff-current-diff-overlay-C ediff-current-diff-overlay-B
- ediff-current-diff-overlay-B overlay)
- (setq ediff-current-diff-overlay-A ediff-current-diff-overlay-B
- ediff-current-diff-overlay-B overlay)))
-
- ;; swap wide bounds
- (setq ediff-wide-bounds
- (cond (ediff-3way-comparison-job
- (list (nth 2 ediff-wide-bounds)
- (nth 0 ediff-wide-bounds)
- (nth 1 ediff-wide-bounds)))
- (ediff-3way-job
- (list (nth 1 ediff-wide-bounds)
- (nth 0 ediff-wide-bounds)
- (nth 2 ediff-wide-bounds)))
- (t
- (list (nth 1 ediff-wide-bounds)
- (nth 0 ediff-wide-bounds)))))
- ;; swap narrow bounds
- (setq ediff-narrow-bounds
- (cond (ediff-3way-comparison-job
- (list (nth 2 ediff-narrow-bounds)
- (nth 0 ediff-narrow-bounds)
- (nth 1 ediff-narrow-bounds)))
- (ediff-3way-job
- (list (nth 1 ediff-narrow-bounds)
- (nth 0 ediff-narrow-bounds)
- (nth 2 ediff-narrow-bounds)))
- (t
- (list (nth 1 ediff-narrow-bounds)
- (nth 0 ediff-narrow-bounds)))))
- (if wide-visibility-p
- (setq ediff-visible-bounds ediff-wide-bounds)
- (setq ediff-visible-bounds ediff-narrow-bounds))
- ))
- (if ediff-3way-job
- (ediff-set-state-of-all-diffs-in-all-buffers ediff-control-buffer))
- (ediff-recenter 'no-rehighlight)
- )
-
-
-(defun ediff-toggle-wide-display ()
- "Toggle wide/regular display.
-This is especially useful when comparing buffers side-by-side."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (or (ediff-window-display-p)
- (error "%sEmacs is not running as a window application"
- (if (featurep 'emacs) "" "X")))
- (ediff-recenter 'no-rehighlight) ; make sure buffs are displayed in windows
- (let ((ctl-buf ediff-control-buffer))
- (setq ediff-wide-display-p (not ediff-wide-display-p))
- (if (not ediff-wide-display-p)
- (ediff-with-current-buffer ctl-buf
- (modify-frame-parameters
- ediff-wide-display-frame ediff-wide-display-orig-parameters)
- ;;(sit-for (if (featurep 'xemacs) 0.4 0))
- ;; restore control buf, since ctl window may have been deleted
- ;; during resizing
- (set-buffer ctl-buf)
- (setq ediff-wide-display-orig-parameters nil
- ediff-window-B nil) ; force update of window config
- (ediff-recenter 'no-rehighlight))
- (funcall ediff-make-wide-display-function)
- ;;(sit-for (if (featurep 'xemacs) 0.4 0))
- (ediff-with-current-buffer ctl-buf
- (setq ediff-window-B nil) ; force update of window config
- (ediff-recenter 'no-rehighlight)))))
-
-;;;###autoload
-(defun ediff-toggle-multiframe ()
- "Switch from multiframe display to single-frame display and back.
-To change the default, set the variable `ediff-window-setup-function',
-which see."
- (interactive)
- (let (window-setup-func)
- (or (ediff-window-display-p)
- (error "%sEmacs is not running as a window application"
- (if (featurep 'emacs) "" "X")))
-
- (cond ((eq ediff-window-setup-function 'ediff-setup-windows-multiframe)
- (setq ediff-multiframe nil)
- (setq window-setup-func 'ediff-setup-windows-plain))
- ((eq ediff-window-setup-function 'ediff-setup-windows-plain)
- (if (ediff-in-control-buffer-p)
- (ediff-kill-bottom-toolbar))
- (if (and (ediff-buffer-live-p ediff-control-buffer)
- (window-live-p ediff-control-window))
- (set-window-dedicated-p ediff-control-window nil))
- (setq ediff-multiframe t)
- (setq window-setup-func 'ediff-setup-windows-multiframe))
- (t
- (if (and (ediff-buffer-live-p ediff-control-buffer)
- (window-live-p ediff-control-window))
- (set-window-dedicated-p ediff-control-window nil))
- (setq ediff-multiframe t)
- (setq window-setup-func 'ediff-setup-windows-multiframe))
- )
-
- ;; change default
- (setq-default ediff-window-setup-function window-setup-func)
- ;; change in all active ediff sessions
- (mapc (lambda(buf) (ediff-with-current-buffer buf
- (setq ediff-window-setup-function window-setup-func
- ediff-window-B nil)))
- ediff-session-registry)
- (if (ediff-in-control-buffer-p)
- (progn
- (set-window-dedicated-p (selected-window) nil)
- (ediff-recenter 'no-rehighlight)))))
-
-
-;;;###autoload
-(defun ediff-toggle-use-toolbar ()
- "Enable or disable Ediff toolbar.
-Works only in versions of Emacs that support toolbars.
-To change the default, set the variable `ediff-use-toolbar-p', which see."
- (interactive)
- (if (featurep 'ediff-tbar)
- (progn
- (or (ediff-window-display-p)
- (error "%sEmacs is not running as a window application"
- (if (featurep 'emacs) "" "X")))
- (if (ediff-use-toolbar-p)
- (ediff-kill-bottom-toolbar))
- ;; do this only after killing the toolbar
- (setq ediff-use-toolbar-p (not ediff-use-toolbar-p))
-
- (mapc (lambda(buf)
- (ediff-with-current-buffer buf
- ;; force redisplay
- (setq ediff-window-config-saved "")
- ))
- ediff-session-registry)
- (if (ediff-in-control-buffer-p)
- (ediff-recenter 'no-rehighlight)))))
-
-
-;; if was using toolbar, kill it
-(defun ediff-kill-bottom-toolbar ()
- ;; Using ctl-buffer or ediff-control-window for LOCALE does not
- ;; work properly in XEmacs 19.14: we have to use
- ;;(selected-frame).
- ;; The problem with this is that any previous bottom-toolbar
- ;; will not re-appear after our cleanup here. Is there a way
- ;; to do "push" and "pop" toolbars ? --marcpa
- (if (featurep 'xemacs)
- (when (ediff-use-toolbar-p)
- (set-specifier bottom-toolbar (list (selected-frame) nil))
- (set-specifier bottom-toolbar-visible-p (list (selected-frame) nil)))))
-
-;; If wants to use toolbar, make it.
-;; If not, zero the toolbar for XEmacs.
-;; Do nothing for Emacs.
-(defun ediff-make-bottom-toolbar (&optional frame)
- (when (ediff-window-display-p)
- (setq frame (or frame (selected-frame)))
- (if (featurep 'xemacs)
- (cond ((ediff-use-toolbar-p) ; this checks for XEmacs
- (set-specifier
- bottom-toolbar
- (list frame (if (ediff-3way-comparison-job)
- ediff-toolbar-3way ediff-toolbar)))
- (set-specifier bottom-toolbar-visible-p (list frame t))
- (set-specifier bottom-toolbar-height
- (list frame ediff-toolbar-height)))
- ((ediff-has-toolbar-support-p)
- (set-specifier bottom-toolbar-height (list frame 0)))))))
-
-;; Merging
-
-(defun ediff-toggle-show-clashes-only ()
- "Toggle the mode that shows only the merge regions where both variants differ from the ancestor."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (if (not ediff-merge-with-ancestor-job)
- (error "This command makes sense only when merging with an ancestor"))
- (setq ediff-show-clashes-only (not ediff-show-clashes-only))
- (if ediff-show-clashes-only
- (message "Focus on regions where both buffers differ from the ancestor")
- (message "Canceling focus on regions where changes clash")))
-
-(defun ediff-toggle-skip-changed-regions ()
- "Toggle the mode that skips the merge regions that differ from the default."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (setq ediff-skip-merge-regions-that-differ-from-default
- (not ediff-skip-merge-regions-that-differ-from-default))
- (if ediff-skip-merge-regions-that-differ-from-default
- (message "Skipping regions that differ from default setting")
- (message "Showing regions that differ from default setting")))
-
-
-
-;; Widening/narrowing
-
-(defun ediff-toggle-narrow-region ()
- "Toggle narrowing in buffers A, B, and C.
-Used in ediff-windows/regions only."
- (interactive)
- (if (eq ediff-buffer-A ediff-buffer-B)
- (error ediff-NO-DIFFERENCES))
- (if (eq ediff-visible-bounds ediff-wide-bounds)
- (setq ediff-visible-bounds ediff-narrow-bounds)
- (setq ediff-visible-bounds ediff-wide-bounds))
- (ediff-recenter 'no-rehighlight))
-
-;; Narrow bufs A/B/C to ediff-visible-bounds. If this is currently set to
-;; ediff-wide-bounds, then this actually widens.
-;; This function does nothing if job-name is not
-;; ediff-regions-wordwise/linewise or ediff-windows-wordwise/linewise.
-;; Does nothing if buffer-A = buffer-B since we can't narrow
-;; to two different regions in one buffer.
-(defun ediff-visible-region ()
- (if (or (eq ediff-buffer-A ediff-buffer-B)
- (eq ediff-buffer-A ediff-buffer-C)
- (eq ediff-buffer-C ediff-buffer-B))
- ()
- ;; If ediff-*-regions/windows, ediff-visible-bounds is already set
- ;; Otherwise, always use full range.
- (if (not ediff-narrow-job)
- (setq ediff-visible-bounds ediff-wide-bounds))
- (let ((overl-A (ediff-get-value-according-to-buffer-type
- 'A ediff-visible-bounds))
- (overl-B (ediff-get-value-according-to-buffer-type
- 'B ediff-visible-bounds))
- (overl-C (ediff-get-value-according-to-buffer-type
- 'C ediff-visible-bounds))
- )
- (ediff-with-current-buffer ediff-buffer-A
- (if (ediff-overlay-buffer overl-A)
- (narrow-to-region
- (ediff-overlay-start overl-A) (ediff-overlay-end overl-A))))
- (ediff-with-current-buffer ediff-buffer-B
- (if (ediff-overlay-buffer overl-B)
- (narrow-to-region
- (ediff-overlay-start overl-B) (ediff-overlay-end overl-B))))
-
- (if (and ediff-3way-job (ediff-overlay-buffer overl-C))
- (ediff-with-current-buffer ediff-buffer-C
- (narrow-to-region
- (ediff-overlay-start overl-C) (ediff-overlay-end overl-C))))
- )))
-
-
-;; Window scrolling operations
-
-;; Performs some operation on the two file windows (if they are showing).
-;; Traps all errors on the operation in windows A/B/C.
-;; Usually, errors come from scrolling off the
-;; beginning or end of the buffer, and this gives error messages.
-(defun ediff-operate-on-windows (operation arg)
-
- ;; make sure windows aren't dead
- (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B)))
- (ediff-recenter 'no-rehighlight))
- (if (not (and (ediff-buffer-live-p ediff-buffer-A)
- (ediff-buffer-live-p ediff-buffer-B)
- (or (not ediff-3way-job) ediff-buffer-C)
- ))
- (error ediff-KILLED-VITAL-BUFFER))
-
- (let* ((wind (selected-window))
- (wind-A ediff-window-A)
- (wind-B ediff-window-B)
- (wind-C ediff-window-C)
- (coefA (ediff-get-region-size-coefficient 'A operation))
- (coefB (ediff-get-region-size-coefficient 'B operation))
- (three-way ediff-3way-job)
- (coefC (if three-way
- (ediff-get-region-size-coefficient 'C operation))))
-
- (select-window wind-A)
- (condition-case nil
- (funcall operation (round (* coefA arg)))
- (error))
- (select-window wind-B)
- (condition-case nil
- (funcall operation (round (* coefB arg)))
- (error))
- (if three-way
- (progn
- (select-window wind-C)
- (condition-case nil
- (funcall operation (round (* coefC arg)))
- (error))))
- (select-window wind)))
-
-(defun ediff-scroll-vertically (&optional arg)
- "Vertically scroll buffers A, B \(and C if appropriate\).
-With optional argument ARG, scroll ARG lines; otherwise scroll by nearly
-the one half of the height of window-A."
- (interactive "P")
- (ediff-barf-if-not-control-buffer)
-
- ;; make sure windows aren't dead
- (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B)))
- (ediff-recenter 'no-rehighlight))
- (if (not (and (ediff-buffer-live-p ediff-buffer-A)
- (ediff-buffer-live-p ediff-buffer-B)
- (or (not ediff-3way-job)
- (ediff-buffer-live-p ediff-buffer-C))
- ))
- (error ediff-KILLED-VITAL-BUFFER))
-
- (ediff-operate-on-windows
- (if (memq (ediff-last-command-char) '(?v ?\C-v))
- 'scroll-up
- 'scroll-down)
- ;; calculate argument to scroll-up/down
- ;; if there is an explicit argument
- (if (and arg (not (equal arg '-)))
- ;; use it
- (prefix-numeric-value arg)
- ;; if not, see if we can determine a default amount (the window height)
- (let (default-amount)
- (setq default-amount
- (- (/ (min (window-height ediff-window-A)
- (window-height ediff-window-B)
- (if ediff-3way-job
- (window-height ediff-window-C)
- 500)) ; some large number
- 2)
- 1 next-screen-context-lines))
- ;; window found
- (if arg
- ;; C-u as argument means half of default amount
- (/ default-amount 2)
- ;; no argument means default amount
- default-amount)))))
-
-
-(defun ediff-scroll-horizontally (&optional arg)
- "Horizontally scroll buffers A, B \(and C if appropriate\).
-If an argument is given, that is how many columns are scrolled, else nearly
-the width of the A/B/C windows."
- (interactive "P")
- (ediff-barf-if-not-control-buffer)
-
- ;; make sure windows aren't dead
- (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B)))
- (ediff-recenter 'no-rehighlight))
- (if (not (and (ediff-buffer-live-p ediff-buffer-A)
- (ediff-buffer-live-p ediff-buffer-B)
- (or (not ediff-3way-job)
- (ediff-buffer-live-p ediff-buffer-C))
- ))
- (error ediff-KILLED-VITAL-BUFFER))
-
- (ediff-operate-on-windows
- ;; Arrange for scroll-left and scroll-right being called
- ;; interactively so that they set the window's min_hscroll.
- ;; Otherwise, automatic hscrolling will undo the effect of
- ;; hscrolling.
- (if (= (ediff-last-command-char) ?<)
- (lambda (arg)
- (let ((prefix-arg arg))
- (call-interactively 'scroll-left)))
- (lambda (arg)
- (let ((prefix-arg arg))
- (call-interactively 'scroll-right))))
- ;; calculate argument to scroll-left/right
- ;; if there is an explicit argument
- (if (and arg (not (equal arg '-)))
- ;; use it
- (prefix-numeric-value arg)
- ;; if not, see if we can determine a default amount
- ;; (half the window width)
- (if (null ediff-control-window)
- ;; no control window, use nil
- nil
- (let ((default-amount
- (- (/ (min (window-width ediff-window-A)
- (window-width ediff-window-B)
- (if ediff-3way-comparison-job
- (window-width ediff-window-C)
- 500) ; some large number
- )
- 2)
- 3)))
- ;; window found
- (if arg
- ;; C-u as argument means half of default amount
- (/ default-amount 2)
- ;; no argument means default amount
- default-amount))))))
-
-
-;;BEG, END show the region to be positioned.
-;;JOB-NAME holds ediff-job-name. The ediff-windows job positions regions
-;;differently.
-(defun ediff-position-region (beg end pos job-name)
- (if (> end (point-max))
- (setq end (point-max)))
- (if ediff-windows-job
- (if (pos-visible-in-window-p end)
- () ; do nothing, wind is already positioned
- ;; at this point, windows are positioned at the beginning of the
- ;; file regions (not diff-regions) being compared.
- (save-excursion
- (move-to-window-line (- (window-height) 2))
- (let ((amount (+ 2 (count-lines (point) end))))
- (scroll-up amount))))
- (set-window-start (selected-window) beg)
- (if (pos-visible-in-window-p end)
- ;; Determine the number of lines that the region occupies
- (let ((lines 0)
- (prev-point 0))
- (while ( and (> end (progn
- (move-to-window-line lines)
- (point)))
- ;; `end' may be beyond the window bottom, so check
- ;; that we are making progress
- (< prev-point (point)))
- (setq prev-point (point))
- (setq lines (1+ lines)))
- ;; And position the beginning on the right line
- (goto-char beg)
- (recenter (/ (1+ (max (- (1- (window-height (selected-window)))
- lines)
- 1)
- )
- 2))))
- (goto-char pos)
- ))
-
-;; get number of lines from window start to region end
-(defun ediff-get-lines-to-region-end (buf-type &optional n ctl-buf)
- (or n (setq n ediff-current-difference))
- (or ctl-buf (setq ctl-buf ediff-control-buffer))
- (ediff-with-current-buffer ctl-buf
- (let* ((buf (ediff-get-buffer buf-type))
- (wind (eval (ediff-get-symbol-from-alist
- buf-type ediff-window-alist)))
- (beg (window-start wind))
- (end (ediff-get-diff-posn buf-type 'end))
- lines)
- (ediff-with-current-buffer buf
- (if (< beg end)
- (setq lines (count-lines beg end))
- (setq lines 0))
- lines
- ))))
-
-;; Calculate the number of lines from window end to the start of diff region
-(defun ediff-get-lines-to-region-start (buf-type &optional diff-num ctl-buf)
- (or diff-num (setq diff-num ediff-current-difference))
- (or ctl-buf (setq ctl-buf ediff-control-buffer))
- (ediff-with-current-buffer ctl-buf
- (let* ((buf (ediff-get-buffer buf-type))
- (wind (eval (ediff-get-symbol-from-alist
- buf-type ediff-window-alist)))
- (end (or (window-end wind) (window-end wind t)))
- (beg (ediff-get-diff-posn buf-type 'beg diff-num)))
- (ediff-with-current-buffer buf
- (if (< beg end)
- (count-lines (max beg (point-min)) (min end (point-max))) 0))
- )))
-
-
-;; region size coefficient is a coefficient by which to adjust scrolling
-;; up/down of the window displaying buffer of type BUFTYPE.
-;; The purpose of this coefficient is to make the windows scroll in sync, so
-;; that it won't happen that one diff region is scrolled off while the other is
-;; still seen.
-;;
-;; If the difference region is invalid, the coefficient is 1
-(defun ediff-get-region-size-coefficient (buf-type op &optional n ctl-buf)
- (ediff-with-current-buffer (or ctl-buf ediff-control-buffer)
- (if (ediff-valid-difference-p n)
- (let* ((func (cond ((eq op 'scroll-down)
- 'ediff-get-lines-to-region-start)
- ((eq op 'scroll-up)
- 'ediff-get-lines-to-region-end)
- (t '(lambda (a b c) 0))))
- (max-lines (max (funcall func 'A n ctl-buf)
- (funcall func 'B n ctl-buf)
- (if (ediff-buffer-live-p ediff-buffer-C)
- (funcall func 'C n ctl-buf)
- 0))))
- ;; this covers the horizontal coefficient as well:
- ;; if max-lines = 0 then coef = 1
- (if (> max-lines 0)
- (/ (+ (funcall func buf-type n ctl-buf) 0.0)
- (+ max-lines 0.0))
- 1))
- 1)))
-
-
-(defun ediff-next-difference (&optional arg)
- "Advance to the next difference.
-With a prefix argument, go forward that many differences."
- (interactive "p")
- (ediff-barf-if-not-control-buffer)
- (if (< ediff-current-difference ediff-number-of-differences)
- (let ((n (min ediff-number-of-differences
- (+ ediff-current-difference (or arg 1))))
- non-clash-skip skip-changed regexp-skip)
-
- (ediff-visible-region)
- (or (>= n ediff-number-of-differences)
- (setq regexp-skip (funcall ediff-skip-diff-region-function n))
- ;; this won't exec if regexp-skip is t
- (setq non-clash-skip (ediff-merge-region-is-non-clash-to-skip n)
- skip-changed
- (ediff-skip-merge-region-if-changed-from-default-p n))
- (ediff-install-fine-diff-if-necessary n))
- ;; Skip loop
- (while (and (< n ediff-number-of-differences)
- (or
- ;; regexp skip
- regexp-skip
- ;; skip clashes, if necessary
- non-clash-skip
- ;; skip processed regions
- skip-changed
- ;; skip difference regions that differ in white space
- (and ediff-ignore-similar-regions
- (ediff-merge-region-is-non-clash n)
- (or (eq (ediff-no-fine-diffs-p n) t)
- (and (ediff-merge-job)
- (eq (ediff-no-fine-diffs-p n) 'C)))
- )))
- (setq n (1+ n))
- (if (= 0 (mod n 20))
- (message "Skipped over region %d and counting ..." n))
- (or (>= n ediff-number-of-differences)
- (setq regexp-skip (funcall ediff-skip-diff-region-function n))
- ;; this won't exec if regexp-skip is t
- (setq non-clash-skip (ediff-merge-region-is-non-clash-to-skip n)
- skip-changed
- (ediff-skip-merge-region-if-changed-from-default-p n))
- (ediff-install-fine-diff-if-necessary n))
- )
- (message "")
- (ediff-unselect-and-select-difference n)
- ) ; let
- (ediff-visible-region)
- (error "At end of the difference list")))
-
-(defun ediff-previous-difference (&optional arg)
- "Go to the previous difference.
-With a prefix argument, go back that many differences."
- (interactive "p")
- (ediff-barf-if-not-control-buffer)
- (if (> ediff-current-difference -1)
- (let ((n (max -1 (- ediff-current-difference (or arg 1))))
- non-clash-skip skip-changed regexp-skip)
-
- (ediff-visible-region)
- (or (< n 0)
- (setq regexp-skip (funcall ediff-skip-diff-region-function n))
- ;; this won't exec if regexp-skip is t
- (setq non-clash-skip (ediff-merge-region-is-non-clash-to-skip n)
- skip-changed
- (ediff-skip-merge-region-if-changed-from-default-p n))
- (ediff-install-fine-diff-if-necessary n))
- (while (and (> n -1)
- (or
- ;; regexp skip
- regexp-skip
- ;; skip clashes, if necessary
- non-clash-skip
- ;; skipp changed regions
- skip-changed
- ;; skip difference regions that differ in white space
- (and ediff-ignore-similar-regions
- (ediff-merge-region-is-non-clash n)
- (or (eq (ediff-no-fine-diffs-p n) t)
- (and (ediff-merge-job)
- (eq (ediff-no-fine-diffs-p n) 'C)))
- )))
- (if (= 0 (mod (1+ n) 20))
- (message "Skipped over region %d and counting ..." (1+ n)))
- (setq n (1- n))
- (or (< n 0)
- (setq regexp-skip (funcall ediff-skip-diff-region-function n))
- ;; this won't exec if regexp-skip is t
- (setq non-clash-skip (ediff-merge-region-is-non-clash-to-skip n)
- skip-changed
- (ediff-skip-merge-region-if-changed-from-default-p n))
- (ediff-install-fine-diff-if-necessary n))
- )
- (message "")
- (ediff-unselect-and-select-difference n)
- ) ; let
- (ediff-visible-region)
- (error "At beginning of the difference list")))
-
-;; The diff number is as perceived by the user (i.e., 1+ the internal
-;; representation)
-(defun ediff-jump-to-difference (difference-number)
- "Go to the difference specified as a prefix argument.
-If the prefix is negative, count differences from the end."
- (interactive "p")
- (ediff-barf-if-not-control-buffer)
- (setq difference-number
- (cond ((< difference-number 0)
- (+ ediff-number-of-differences difference-number))
- ((> difference-number 0) (1- difference-number))
- (t -1)))
- ;; -1 is allowed by ediff-unselect-and-select-difference --- it is the
- ;; position before the first one.
- (if (and (>= difference-number -1)
- (<= difference-number ediff-number-of-differences))
- (ediff-unselect-and-select-difference difference-number)
- (error ediff-BAD-DIFF-NUMBER
- this-command (1+ difference-number) ediff-number-of-differences)))
-
-(defun ediff-jump-to-difference-at-point (arg)
- "Go to difference closest to the point in buffer A, B, or C.
-The buffer depends on last command character \(a, b, or c\) that invoked this
-command. For instance, if the command was `ga' then the point value in buffer
-A is used.
-With a prefix argument, synchronize all files around the current point position
-in the specified buffer."
- (interactive "P")
- (ediff-barf-if-not-control-buffer)
- (let* ((buf-type (ediff-char-to-buftype (ediff-last-command-char)))
- (buffer (ediff-get-buffer buf-type))
- (pt (ediff-with-current-buffer buffer (point)))
- (diff-no (ediff-diff-at-point buf-type nil (if arg 'after)))
- (past-last-diff (< ediff-number-of-differences diff-no))
- (beg (if past-last-diff
- (ediff-with-current-buffer buffer (point-max))
- (ediff-get-diff-posn buf-type 'beg (1- diff-no))))
- ctl-wind wind-A wind-B wind-C
- shift)
- (if past-last-diff
- (ediff-jump-to-difference -1)
- (ediff-jump-to-difference diff-no))
- (setq ctl-wind (selected-window)
- wind-A ediff-window-A
- wind-B ediff-window-B
- wind-C ediff-window-C)
- (if arg
- (progn
- (ediff-with-current-buffer buffer
- (setq shift (- beg pt)))
- (select-window wind-A)
- (if past-last-diff (goto-char (point-max)))
- (condition-case nil
- (backward-char shift) ; noerror, if beginning of buffer
- (error))
- (recenter)
- (select-window wind-B)
- (if past-last-diff (goto-char (point-max)))
- (condition-case nil
- (backward-char shift) ; noerror, if beginning of buffer
- (error))
- (recenter)
- (if (window-live-p wind-C)
- (progn
- (select-window wind-C)
- (if past-last-diff (goto-char (point-max)))
- (condition-case nil
- (backward-char shift) ; noerror, if beginning of buffer
- (error))
- (recenter)
- ))
- (select-window ctl-wind)
- ))
- ))
-
-
-;; find region most related to the current point position (or POS, if given)
-;; returns diff number as seen by the user (i.e., 1+ the internal
-;; representation)
-;; The optional argument WHICH-DIFF can be `after' or `before'. If `after',
-;; find the diff after the point. If `before', find the diff before the
-;; point. If the point is inside a diff, return that diff.
-(defun ediff-diff-at-point (buf-type &optional pos which-diff)
- (let ((buffer (ediff-get-buffer buf-type))
- (ctl-buffer ediff-control-buffer)
- (max-dif-num (1- ediff-number-of-differences))
- (diff-no -1)
- (prev-beg 0)
- (prev-end 0)
- (beg 0)
- (end 0))
-
- (ediff-with-current-buffer buffer
- (setq pos (or pos (point)))
- (while (and (or (< pos prev-beg) (> pos beg))
- (< diff-no max-dif-num))
- (setq diff-no (1+ diff-no))
- (setq prev-beg beg
- prev-end end)
- (setq beg (ediff-get-diff-posn buf-type 'beg diff-no ctl-buffer)
- end (ediff-get-diff-posn buf-type 'end diff-no ctl-buffer))
- )
-
- ;; boost diff-no by 1, if past the last diff region
- (if (and (memq which-diff '(after before))
- (> pos beg) (= diff-no max-dif-num))
- (setq diff-no (1+ diff-no)))
-
- (cond ((eq which-diff 'after) (1+ diff-no))
- ((eq which-diff 'before) diff-no)
- ((< (abs (count-lines pos (max 1 prev-end)))
- (abs (count-lines pos (max 1 beg))))
- diff-no) ; choose prev difference
- (t
- (1+ diff-no))) ; choose next difference
- )))
-
-\f
-;;; Copying diffs.
-
-(defun ediff-diff-to-diff (arg &optional keys)
- "Copy buffer-X'th difference region to buffer Y \(X,Y are A, B, or C\).
-If numerical prefix argument, copy the difference specified in the arg.
-Otherwise, copy the difference given by `ediff-current-difference'.
-This command assumes it is bound to a 2-character key sequence, `ab', `ba',
-`ac', etc., which is used to determine the types of buffers to be used for
-copying difference regions. The first character in the sequence specifies
-the source buffer and the second specifies the target.
-
-If the second optional argument, a 2-character string, is given, use it to
-determine the source and the target buffers instead of the command keys."
- (interactive "P")
- (ediff-barf-if-not-control-buffer)
- (or keys (setq keys (this-command-keys)))
- (if (eq arg '-) (setq arg -1)) ; translate neg arg to -1
- (if (numberp arg) (ediff-jump-to-difference arg))
-
- (let* ((key1 (aref keys 0))
- (key2 (aref keys 1))
- (char1 (ediff-event-key key1))
- (char2 (ediff-event-key key2))
- ediff-verbose-p)
- (ediff-copy-diff ediff-current-difference
- (ediff-char-to-buftype char1)
- (ediff-char-to-buftype char2))
- ;; recenter with rehighlighting, but no messages
- (ediff-recenter)))
-
-(defun ediff-copy-A-to-B (arg)
- "Copy ARGth difference region from buffer A to B.
-ARG is a prefix argument. If nil, copy the current difference region."
- (interactive "P")
- (ediff-diff-to-diff arg "ab"))
-
-(defun ediff-copy-B-to-A (arg)
- "Copy ARGth difference region from buffer B to A.
-ARG is a prefix argument. If nil, copy the current difference region."
- (interactive "P")
- (ediff-diff-to-diff arg "ba"))
-
-(defun ediff-copy-A-to-C (arg)
- "Copy ARGth difference region from buffer A to buffer C.
-ARG is a prefix argument. If nil, copy the current difference region."
- (interactive "P")
- (ediff-diff-to-diff arg "ac"))
-
-(defun ediff-copy-B-to-C (arg)
- "Copy ARGth difference region from buffer B to buffer C.
-ARG is a prefix argument. If nil, copy the current difference region."
- (interactive "P")
- (ediff-diff-to-diff arg "bc"))
-
-(defun ediff-copy-C-to-B (arg)
- "Copy ARGth difference region from buffer C to B.
-ARG is a prefix argument. If nil, copy the current difference region."
- (interactive "P")
- (ediff-diff-to-diff arg "cb"))
-
-(defun ediff-copy-C-to-A (arg)
- "Copy ARGth difference region from buffer C to A.
-ARG is a prefix argument. If nil, copy the current difference region."
- (interactive "P")
- (ediff-diff-to-diff arg "ca"))
-
-
-
-;; Copy diff N from FROM-BUF-TYPE \(given as A, B or C\) to TO-BUF-TYPE.
-;; If optional DO-NOT-SAVE is non-nil, do not save the old value of the
-;; target diff. This is used in merging, when constructing the merged
-;; version.
-(defun ediff-copy-diff (n from-buf-type to-buf-type
- &optional batch-invocation reg-to-copy)
- (let* ((to-buf (ediff-get-buffer to-buf-type))
- ;;(from-buf (if (not reg-to-copy) (ediff-get-buffer from-buf-type)))
- (ctrl-buf ediff-control-buffer)
- (saved-p t)
- (three-way ediff-3way-job)
- messg
- ediff-verbose-p
- reg-to-delete reg-to-delete-beg reg-to-delete-end)
-
- (setq reg-to-delete-beg
- (ediff-get-diff-posn to-buf-type 'beg n ctrl-buf))
- (setq reg-to-delete-end
- (ediff-get-diff-posn to-buf-type 'end n ctrl-buf))
-
- (if reg-to-copy
- (setq from-buf-type nil)
- (setq reg-to-copy (ediff-get-region-contents n from-buf-type ctrl-buf)))
-
- (setq reg-to-delete (ediff-get-region-contents
- n to-buf-type ctrl-buf
- reg-to-delete-beg reg-to-delete-end))
-
- (if (string= reg-to-delete reg-to-copy)
- (setq saved-p nil) ; don't copy identical buffers
- ;; seems ok to copy
- (if (or batch-invocation (ediff-test-save-region n to-buf-type))
- (condition-case conds
- (progn
- (ediff-with-current-buffer to-buf
- ;; to prevent flags from interfering if buffer is writable
- (let ((inhibit-read-only (null buffer-read-only)))
-
- (goto-char reg-to-delete-end)
- (insert reg-to-copy)
-
- (if (> reg-to-delete-end reg-to-delete-beg)
- (kill-region reg-to-delete-beg reg-to-delete-end))
- ))
- (or batch-invocation
- (setq
- messg
- (ediff-save-diff-region n to-buf-type reg-to-delete))))
- (error (message "ediff-copy-diff: %s %s"
- (car conds)
- (mapconcat 'prin1-to-string (cdr conds) " "))
- (beep 1)
- (sit-for 2) ; let the user see the error msg
- (setq saved-p nil)
- )))
- )
-
- ;; adjust state of difference in case 3-way and diff was copied ok
- (if (and saved-p three-way)
- (ediff-set-state-of-diff-in-all-buffers n ctrl-buf))
-
- (if batch-invocation
- (ediff-clear-fine-differences n)
- ;; If diff3 job, we should recompute fine diffs so we clear them
- ;; before reinserting flags (and thus before ediff-recenter).
- (if (and saved-p three-way)
- (ediff-clear-fine-differences n))
-
- (ediff-refresh-mode-lines)
-
- ;; For diff2 jobs, don't recompute fine diffs, since we know there
- ;; aren't any. So we clear diffs after ediff-recenter.
- (if (and saved-p (not three-way))
- (ediff-clear-fine-differences n))
- ;; Make sure that the message about saving and how to restore is seen
- ;; by the user
- (message "%s" messg))
- ))
-
-;; Save Nth diff of buffer BUF-TYPE \(A, B, or C\).
-;; That is to say, the Nth diff on the `ediff-killed-diffs-alist'. REG
-;; is the region to save. It is redundant here, but is passed anyway, for
-;; convenience.
-(defun ediff-save-diff-region (n buf-type reg)
- (let* ((n-th-diff-saved (assoc n ediff-killed-diffs-alist))
- (buf (ediff-get-buffer buf-type))
- (this-buf-n-th-diff-saved (assoc buf (cdr n-th-diff-saved))))
-
- (if this-buf-n-th-diff-saved
- ;; either nothing saved for n-th diff and buffer or we OK'ed
- ;; overriding
- (setcdr this-buf-n-th-diff-saved reg)
- (if n-th-diff-saved ;; n-th diff saved, but for another buffer
- (nconc n-th-diff-saved (list (cons buf reg)))
- (setq ediff-killed-diffs-alist ;; create record for n-th diff
- (cons (list n (cons buf reg))
- ediff-killed-diffs-alist))))
- (message "Saving old diff region #%d of buffer %S. To recover, type `r%s'"
- (1+ n) buf-type
- (if ediff-merge-job
- "" (downcase (symbol-name buf-type))))
- ))
-
-;; Test if saving Nth difference region of buffer BUF-TYPE is possible.
-(defun ediff-test-save-region (n buf-type)
- (let* ((n-th-diff-saved (assoc n ediff-killed-diffs-alist))
- (buf (ediff-get-buffer buf-type))
- (this-buf-n-th-diff-saved (assoc buf (cdr n-th-diff-saved))))
-
- (if this-buf-n-th-diff-saved
- (if (yes-or-no-p
- (format
- "You've previously copied diff region %d to buffer %S. Confirm? "
- (1+ n) buf-type))
- t
- (error "Quit"))
- t)))
-
-(defun ediff-pop-diff (n buf-type)
- "Pop last killed Nth diff region from buffer BUF-TYPE."
- (let* ((n-th-record (assoc n ediff-killed-diffs-alist))
- (buf (ediff-get-buffer buf-type))
- (saved-rec (assoc buf (cdr n-th-record)))
- (three-way ediff-3way-job)
- (ctl-buf ediff-control-buffer)
- ediff-verbose-p
- saved-diff reg-beg reg-end recovered)
-
- (if (cdr saved-rec)
- (setq saved-diff (cdr saved-rec))
- (if (> ediff-number-of-differences 0)
- (error "Nothing saved for diff %d in buffer %S" (1+ n) buf-type)
- (error ediff-NO-DIFFERENCES)))
-
- (setq reg-beg (ediff-get-diff-posn buf-type 'beg n ediff-control-buffer))
- (setq reg-end (ediff-get-diff-posn buf-type 'end n ediff-control-buffer))
-
- (condition-case conds
- (ediff-with-current-buffer buf
- (let ((inhibit-read-only (null buffer-read-only)))
-
- (goto-char reg-end)
- (insert saved-diff)
-
- (if (> reg-end reg-beg)
- (kill-region reg-beg reg-end))
-
- (setq recovered t)
- ))
- (error (message "ediff-pop-diff: %s %s"
- (car conds)
- (mapconcat 'prin1-to-string (cdr conds) " "))
- (beep 1)))
-
- ;; Clearing fine diffs is necessary for
- ;; ediff-unselect-and-select-difference to properly recompute them. We
- ;; can't rely on ediff-copy-diff to clear this vector, as the user might
- ;; have modified diff regions after copying and, thus, may have recomputed
- ;; fine diffs.
- (if recovered
- (ediff-clear-fine-differences n))
-
- ;; adjust state of difference
- (if (and three-way recovered)
- (ediff-set-state-of-diff-in-all-buffers n ctl-buf))
-
- (ediff-refresh-mode-lines)
-
- (if recovered
- (progn
- (setq n-th-record (delq saved-rec n-th-record))
- (message "Diff region %d in buffer %S restored" (1+ n) buf-type)
- ))
- ))
-
-(defun ediff-restore-diff (arg &optional key)
- "Restore ARGth diff from `ediff-killed-diffs-alist'.
-ARG is a prefix argument. If ARG is nil, restore the current-difference.
-If the second optional argument, a character, is given, use it to
-determine the target buffer instead of (ediff-last-command-char)"
- (interactive "P")
- (ediff-barf-if-not-control-buffer)
- (if (numberp arg)
- (ediff-jump-to-difference arg))
- (ediff-pop-diff ediff-current-difference
- (ediff-char-to-buftype (or key (ediff-last-command-char))))
- ;; recenter with rehighlighting, but no messages
- (let (ediff-verbose-p)
- (ediff-recenter)))
-
-(defun ediff-restore-diff-in-merge-buffer (arg)
- "Restore ARGth diff in the merge buffer.
-ARG is a prefix argument. If nil, restore the current diff."
- (interactive "P")
- (ediff-restore-diff arg ?c))
-
-
-(defun ediff-toggle-regexp-match ()
- "Toggle between focusing and hiding of difference regions that match
-a regular expression typed in by the user."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (let ((regexp-A "")
- (regexp-B "")
- (regexp-C "")
- msg-connective alt-msg-connective alt-connective)
- (cond
- ((or (and (eq ediff-skip-diff-region-function
- ediff-focus-on-regexp-matches-function)
- (eq (ediff-last-command-char) ?f))
- (and (eq ediff-skip-diff-region-function
- ediff-hide-regexp-matches-function)
- (eq (ediff-last-command-char) ?h)))
- (message "Selective browsing by regexp turned off")
- (setq ediff-skip-diff-region-function 'ediff-show-all-diffs))
- ((eq (ediff-last-command-char) ?h)
- (setq ediff-skip-diff-region-function ediff-hide-regexp-matches-function
- regexp-A
- (read-string
- (format
- "Ignore A-regions matching this regexp (default %s): "
- ediff-regexp-hide-A))
- regexp-B
- (read-string
- (format
- "Ignore B-regions matching this regexp (default %s): "
- ediff-regexp-hide-B)))
- (if ediff-3way-comparison-job
- (setq regexp-C
- (read-string
- (format
- "Ignore C-regions matching this regexp (default %s): "
- ediff-regexp-hide-C))))
- (if (eq ediff-hide-regexp-connective 'and)
- (setq msg-connective "BOTH"
- alt-msg-connective "ONE OF"
- alt-connective 'or)
- (setq msg-connective "ONE OF"
- alt-msg-connective "BOTH"
- alt-connective 'and))
- (if (y-or-n-p
- (format
- "Ignore regions that match %s regexps, OK? "
- msg-connective))
- (message "Will ignore regions that match %s regexps" msg-connective)
- (setq ediff-hide-regexp-connective alt-connective)
- (message "Will ignore regions that match %s regexps"
- alt-msg-connective))
-
- (or (string= regexp-A "") (setq ediff-regexp-hide-A regexp-A))
- (or (string= regexp-B "") (setq ediff-regexp-hide-B regexp-B))
- (or (string= regexp-C "") (setq ediff-regexp-hide-C regexp-C)))
-
- ((eq (ediff-last-command-char) ?f)
- (setq ediff-skip-diff-region-function
- ediff-focus-on-regexp-matches-function
- regexp-A
- (read-string
- (format
- "Focus on A-regions matching this regexp (default %s): "
- ediff-regexp-focus-A))
- regexp-B
- (read-string
- (format
- "Focus on B-regions matching this regexp (default %s): "
- ediff-regexp-focus-B)))
- (if ediff-3way-comparison-job
- (setq regexp-C
- (read-string
- (format
- "Focus on C-regions matching this regexp (default %s): "
- ediff-regexp-focus-C))))
- (if (eq ediff-focus-regexp-connective 'and)
- (setq msg-connective "BOTH"
- alt-msg-connective "ONE OF"
- alt-connective 'or)
- (setq msg-connective "ONE OF"
- alt-msg-connective "BOTH"
- alt-connective 'and))
- (if (y-or-n-p
- (format
- "Focus on regions that match %s regexps, OK? "
- msg-connective))
- (message "Will focus on regions that match %s regexps"
- msg-connective)
- (setq ediff-focus-regexp-connective alt-connective)
- (message "Will focus on regions that match %s regexps"
- alt-msg-connective))
-
- (or (string= regexp-A "") (setq ediff-regexp-focus-A regexp-A))
- (or (string= regexp-B "") (setq ediff-regexp-focus-B regexp-B))
- (or (string= regexp-C "") (setq ediff-regexp-focus-C regexp-C))))))
-
-(defun ediff-toggle-skip-similar ()
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (if (not (eq ediff-auto-refine 'on))
- (error
- "Can't skip over whitespace regions: first turn auto-refining on"))
- (setq ediff-ignore-similar-regions (not ediff-ignore-similar-regions))
- (if ediff-ignore-similar-regions
- (message
- "Skipping regions that differ only in white space & line breaks")
- (message "Skipping over white-space differences turned off")))
-
-(defun ediff-focus-on-regexp-matches (n)
- "Focus on diffs that match regexp `ediff-regexp-focus-A/B'.
-Regions to be ignored according to this function are those where
-buf A region doesn't match `ediff-regexp-focus-A' and buf B region
-doesn't match `ediff-regexp-focus-B'.
-This function returns nil if the region number N (specified as
-an argument) is not to be ignored and t if region N is to be ignored.
-
-N is a region number used by Ediff internally. It is 1 less
-the number seen by the user."
- (if (ediff-valid-difference-p n)
- (let* ((ctl-buf ediff-control-buffer)
- (regex-A ediff-regexp-focus-A)
- (regex-B ediff-regexp-focus-B)
- (regex-C ediff-regexp-focus-C)
- (reg-A-match (ediff-with-current-buffer ediff-buffer-A
- (save-restriction
- (narrow-to-region
- (ediff-get-diff-posn 'A 'beg n ctl-buf)
- (ediff-get-diff-posn 'A 'end n ctl-buf))
- (goto-char (point-min))
- (re-search-forward regex-A nil t))))
- (reg-B-match (ediff-with-current-buffer ediff-buffer-B
- (save-restriction
- (narrow-to-region
- (ediff-get-diff-posn 'B 'beg n ctl-buf)
- (ediff-get-diff-posn 'B 'end n ctl-buf))
- (re-search-forward regex-B nil t))))
- (reg-C-match (if ediff-3way-comparison-job
- (ediff-with-current-buffer ediff-buffer-C
- (save-restriction
- (narrow-to-region
- (ediff-get-diff-posn 'C 'beg n ctl-buf)
- (ediff-get-diff-posn 'C 'end n ctl-buf))
- (re-search-forward regex-C nil t))))))
- (not (eval (if ediff-3way-comparison-job
- (list ediff-focus-regexp-connective
- reg-A-match reg-B-match reg-C-match)
- (list ediff-focus-regexp-connective
- reg-A-match reg-B-match))))
- )))
-
-(defun ediff-hide-regexp-matches (n)
- "Hide diffs that match regexp `ediff-regexp-hide-A/B/C'.
-Regions to be ignored are those where buf A region matches
-`ediff-regexp-hide-A' and buf B region matches `ediff-regexp-hide-B'.
-This function returns nil if the region number N (specified as
-an argument) is not to be ignored and t if region N is to be ignored.
-
-N is a region number used by Ediff internally. It is 1 less
-the number seen by the user."
- (if (ediff-valid-difference-p n)
- (let* ((ctl-buf ediff-control-buffer)
- (regex-A ediff-regexp-hide-A)
- (regex-B ediff-regexp-hide-B)
- (regex-C ediff-regexp-hide-C)
- (reg-A-match (ediff-with-current-buffer ediff-buffer-A
- (save-restriction
- (narrow-to-region
- (ediff-get-diff-posn 'A 'beg n ctl-buf)
- (ediff-get-diff-posn 'A 'end n ctl-buf))
- (goto-char (point-min))
- (re-search-forward regex-A nil t))))
- (reg-B-match (ediff-with-current-buffer ediff-buffer-B
- (save-restriction
- (narrow-to-region
- (ediff-get-diff-posn 'B 'beg n ctl-buf)
- (ediff-get-diff-posn 'B 'end n ctl-buf))
- (goto-char (point-min))
- (re-search-forward regex-B nil t))))
- (reg-C-match (if ediff-3way-comparison-job
- (ediff-with-current-buffer ediff-buffer-C
- (save-restriction
- (narrow-to-region
- (ediff-get-diff-posn 'C 'beg n ctl-buf)
- (ediff-get-diff-posn 'C 'end n ctl-buf))
- (goto-char (point-min))
- (re-search-forward regex-C nil t))))))
- (eval (if ediff-3way-comparison-job
- (list ediff-hide-regexp-connective
- reg-A-match reg-B-match reg-C-match)
- (list ediff-hide-regexp-connective reg-A-match reg-B-match)))
- )))
-
-
-\f
-;;; Quitting, suspending, etc.
-
-(defun ediff-quit (reverse-default-keep-variants)
- "Finish an Ediff session and exit Ediff.
-Unselects the selected difference, if any, restores the read-only and modified
-flags of the compared file buffers, kills Ediff buffers for this session
-\(but not buffers A, B, C\).
-
-If `ediff-keep-variants' is nil, the user will be asked whether the buffers
-containing the variants should be removed \(if they haven't been modified\).
-If it is t, they will be preserved unconditionally. A prefix argument,
-temporarily reverses the meaning of this variable."
- (interactive "P")
- (ediff-barf-if-not-control-buffer)
- (let ((ctl-buf (current-buffer))
- (ctl-frm (selected-frame))
- (minibuffer-auto-raise t))
- (if (y-or-n-p (format "Quit this Ediff session%s? "
- (if (ediff-buffer-live-p ediff-meta-buffer)
- " & show containing session group" "")))
- (progn
- (message "")
- (set-buffer ctl-buf)
- (ediff-really-quit reverse-default-keep-variants))
- (select-frame ctl-frm)
- (raise-frame ctl-frm)
- (message ""))))
-
-
-;; Perform the quit operations.
-(defun ediff-really-quit (reverse-default-keep-variants)
- (ediff-unhighlight-diffs-totally)
- (ediff-clear-diff-vector 'ediff-difference-vector-A 'fine-diffs-also)
- (ediff-clear-diff-vector 'ediff-difference-vector-B 'fine-diffs-also)
- (ediff-clear-diff-vector 'ediff-difference-vector-C 'fine-diffs-also)
- (ediff-clear-diff-vector 'ediff-difference-vector-Ancestor 'fine-diffs-also)
-
- (ediff-delete-temp-files)
-
- ;; Restore the visibility range. This affects only ediff-*-regions/windows.
- ;; Since for other job names ediff-visible-region sets
- ;; ediff-visible-bounds to ediff-wide-bounds, the settings below are
- ;; ignored for such jobs.
- (if ediff-quit-widened
- (setq ediff-visible-bounds ediff-wide-bounds)
- (setq ediff-visible-bounds ediff-narrow-bounds))
-
- ;; Apply selective display to narrow or widen
- (ediff-visible-region)
- (mapc (lambda (overl)
- (if (ediff-overlayp overl)
- (ediff-delete-overlay overl)))
- ediff-wide-bounds)
- (mapc (lambda (overl)
- (if (ediff-overlayp overl)
- (ediff-delete-overlay overl)))
- ediff-narrow-bounds)
-
- ;; restore buffer mode line id's in buffer-A/B/C
- (let ((control-buffer ediff-control-buffer)
- (meta-buffer ediff-meta-buffer)
- (after-quit-hook-internal ediff-after-quit-hook-internal)
- (session-number ediff-meta-session-number)
- ;; suitable working frame
- (warp-frame (if (and (ediff-window-display-p) (eq ediff-grab-mouse t))
- (cond ((window-live-p ediff-window-A)
- (window-frame ediff-window-A))
- ((window-live-p ediff-window-B)
- (window-frame ediff-window-B))
- (t (next-frame))))))
- (condition-case nil
- (ediff-with-current-buffer ediff-buffer-A
- (setq ediff-this-buffer-ediff-sessions
- (delq control-buffer ediff-this-buffer-ediff-sessions))
- (kill-local-variable 'mode-line-buffer-identification)
- (kill-local-variable 'mode-line-format)
- )
- (error))
-
- (condition-case nil
- (ediff-with-current-buffer ediff-buffer-B
- (setq ediff-this-buffer-ediff-sessions
- (delq control-buffer ediff-this-buffer-ediff-sessions))
- (kill-local-variable 'mode-line-buffer-identification)
- (kill-local-variable 'mode-line-format)
- )
- (error))
-
- (condition-case nil
- (ediff-with-current-buffer ediff-buffer-C
- (setq ediff-this-buffer-ediff-sessions
- (delq control-buffer ediff-this-buffer-ediff-sessions))
- (kill-local-variable 'mode-line-buffer-identification)
- (kill-local-variable 'mode-line-format)
- )
- (error))
-
- (condition-case nil
- (ediff-with-current-buffer ediff-ancestor-buffer
- (setq ediff-this-buffer-ediff-sessions
- (delq control-buffer ediff-this-buffer-ediff-sessions))
- (kill-local-variable 'mode-line-buffer-identification)
- (kill-local-variable 'mode-line-format)
- )
- (error))
-
- (setq ediff-session-registry
- (delq ediff-control-buffer ediff-session-registry))
- (ediff-update-registry)
- ;; restore state of buffers to what it was before ediff
- (ediff-restore-protected-variables)
-
- ;; If the user interrupts (canceling saving the merge buffer), continue
- ;; normally.
- (condition-case nil
- (if (ediff-merge-job)
- (run-hooks 'ediff-quit-merge-hook))
- (quit))
-
- (run-hooks 'ediff-cleanup-hook)
-
- (ediff-janitor
- 'ask
- ;; reverse-default-keep-variants is t if the user quits with a prefix arg
- (if reverse-default-keep-variants
- (not ediff-keep-variants)
- ediff-keep-variants))
-
- ;; one hook here is ediff-cleanup-mess, which kills the control buffer and
- ;; other auxiliary buffers. we made it into a hook to let the users do their
- ;; own cleanup, if needed.
- (run-hooks 'ediff-quit-hook)
- (ediff-update-meta-buffer meta-buffer nil session-number)
-
- ;; warp mouse into a working window
- (setq warp-frame ; if mouse is over a reasonable frame, use it
- (cond ((ediff-good-frame-under-mouse))
- (t warp-frame)))
- (if (and (ediff-window-display-p) (frame-live-p warp-frame) ediff-grab-mouse)
- (set-mouse-position (if (featurep 'emacs)
- warp-frame
- (frame-selected-window warp-frame))
- 2 1))
-
- (run-hooks 'after-quit-hook-internal)
- ))
-
-;; Returns frame under mouse, if this frame is not a minibuffer
-;; frame. Otherwise: nil
-(defun ediff-good-frame-under-mouse ()
- (let ((frame-or-win (car (mouse-position)))
- (buf-name "")
- frame obj-ok)
- (setq obj-ok
- (if (featurep 'emacs)
- (frame-live-p frame-or-win)
- (window-live-p frame-or-win)))
- (if obj-ok
- (setq frame (if (featurep 'emacs) frame-or-win (window-frame frame-or-win))
- buf-name
- (buffer-name (window-buffer (frame-selected-window frame)))))
- (if (string-match "Minibuf" buf-name)
- nil
- frame)))
-
-
-(defun ediff-delete-temp-files ()
- (if (and (stringp ediff-temp-file-A) (file-exists-p ediff-temp-file-A))
- (delete-file ediff-temp-file-A))
- (if (and (stringp ediff-temp-file-B) (file-exists-p ediff-temp-file-B))
- (delete-file ediff-temp-file-B))
- (if (and (stringp ediff-temp-file-C) (file-exists-p ediff-temp-file-C))
- (delete-file ediff-temp-file-C)))
-
-
-;; Kill control buffer, other auxiliary Ediff buffers.
-;; Leave one of the frames split between buffers A/B/C
-(defun ediff-cleanup-mess ()
- (let* ((buff-A ediff-buffer-A)
- (buff-B ediff-buffer-B)
- (buff-C ediff-buffer-C)
- (ctl-buf ediff-control-buffer)
- (ctl-wind (ediff-get-visible-buffer-window ctl-buf))
- (ctl-frame ediff-control-frame)
- (three-way-job ediff-3way-job)
- (main-frame (cond ((window-live-p ediff-window-A)
- (window-frame ediff-window-A))
- ((window-live-p ediff-window-B)
- (window-frame ediff-window-B)))))
-
- (ediff-kill-buffer-carefully ediff-diff-buffer)
- (ediff-kill-buffer-carefully ediff-custom-diff-buffer)
- (ediff-kill-buffer-carefully ediff-fine-diff-buffer)
- (ediff-kill-buffer-carefully ediff-tmp-buffer)
- (ediff-kill-buffer-carefully ediff-error-buffer)
- (ediff-kill-buffer-carefully ediff-msg-buffer)
- (ediff-kill-buffer-carefully ediff-debug-buffer)
- (if (boundp 'ediff-patch-diagnostics)
- (ediff-kill-buffer-carefully ediff-patch-diagnostics))
-
- ;; delete control frame or window
- (cond ((and (ediff-window-display-p) (frame-live-p ctl-frame))
- (delete-frame ctl-frame))
- ((window-live-p ctl-wind)
- (delete-window ctl-wind)))
-
- ;; Hide bottom toolbar. --marcpa
- (if (not (ediff-multiframe-setup-p))
- (ediff-kill-bottom-toolbar))
-
- (ediff-kill-buffer-carefully ctl-buf)
-
- (if (frame-live-p main-frame)
- (select-frame main-frame))
-
- ;; display only if not visible
- (condition-case nil
- (or (ediff-get-visible-buffer-window buff-B)
- (switch-to-buffer buff-B))
- (error))
- (condition-case nil
- (or (ediff-get-visible-buffer-window buff-A)
- (progn
- (if (and (ediff-get-visible-buffer-window buff-B)
- (ediff-buffer-live-p buff-A))
- (funcall ediff-split-window-function))
- (switch-to-buffer buff-A)))
- (error))
- (if three-way-job
- (condition-case nil
- (or (ediff-get-visible-buffer-window buff-C)
- (progn
- (if (and (or (ediff-get-visible-buffer-window buff-A)
- (ediff-get-visible-buffer-window buff-B))
- (ediff-buffer-live-p buff-C))
- (funcall ediff-split-window-function))
- (switch-to-buffer buff-C)))
- (error)))
- (balance-windows)
- (message "")
- ))
-
-(defun ediff-janitor (ask keep-variants)
- "Kill buffers A, B, and, possibly, C, if these buffers aren't modified.
-In merge jobs, buffer C is not deleted here, but rather according to
-ediff-quit-merge-hook.
-A side effect of cleaning up may be that you should be careful when comparing
-the same buffer in two separate Ediff sessions: quitting one of them might
-delete this buffer in another session as well."
- (ediff-dispose-of-variant-according-to-user
- ediff-buffer-A 'A ask keep-variants)
- (ediff-dispose-of-variant-according-to-user
- ediff-buffer-B 'B ask keep-variants)
- (if ediff-merge-job ; don't del buf C if merging--del ancestor buf instead
- (ediff-dispose-of-variant-according-to-user
- ediff-ancestor-buffer 'Ancestor ask keep-variants)
- (ediff-dispose-of-variant-according-to-user
- ediff-buffer-C 'C ask keep-variants)
- ))
-
-;; Kill the variant buffer, according to user directives (ask, kill
-;; unconditionaly, keep)
-;; BUFF is the buffer, BUFF-TYPE is either 'A, or 'B, 'C, 'Ancestor
-(defun ediff-dispose-of-variant-according-to-user (buff bufftype ask keep-variants)
- ;; if this is indirect buffer, kill it and substitute with direct buf
- (if (and (ediff-buffer-live-p buff)
- (ediff-with-current-buffer buff ediff-temp-indirect-buffer))
- (let ((wind (ediff-get-visible-buffer-window buff))
- (base (buffer-base-buffer buff))
- (modified-p (buffer-modified-p buff)))
- (if (and (window-live-p wind) (ediff-buffer-live-p base))
- (set-window-buffer wind base))
- ;; Kill indirect buffer even if it is modified, because the base buffer
- ;; is still there. Note that if the base buffer is dead then so will be
- ;; the indirect buffer
- (ediff-with-current-buffer buff
- (set-buffer-modified-p nil))
- (ediff-kill-buffer-carefully buff)
- (ediff-with-current-buffer base
- (set-buffer-modified-p modified-p)))
- ;; otherwise, ask or use the value of keep-variants
- (or (not (ediff-buffer-live-p buff))
- keep-variants
- (buffer-modified-p buff)
- (and ask
- (not (y-or-n-p (format "Kill buffer %S [%s]? "
- bufftype (buffer-name buff)))))
- (ediff-kill-buffer-carefully buff))
- ))
-
-(defun ediff-maybe-save-and-delete-merge (&optional save-and-continue)
- "Default hook to run on quitting a merge job.
-This can also be used to save merge buffer in the middle of an Ediff session.
-
-If the optional SAVE-AND-CONTINUE argument is non-nil, save merge buffer and
-continue. Otherwise:
-If `ediff-autostore-merges' is nil, this does nothing.
-If it is t, it saves the merge buffer in the file `ediff-merge-store-file'
-or asks the user, if the latter is nil. It then asks the user whether to
-delete the merge buffer.
-If `ediff-autostore-merges' is neither nil nor t, the merge buffer is saved
-only if this merge job is part of a group, i.e., was invoked from within
-`ediff-merge-directories', `ediff-merge-directory-revisions', and such."
- (let ((merge-store-file ediff-merge-store-file)
- (ediff-autostore-merges ; fake ediff-autostore-merges, if necessary
- (if save-and-continue t ediff-autostore-merges)))
- (if ediff-autostore-merges
- (cond ((stringp merge-store-file)
- ;; store, ask to delete
- (ediff-write-merge-buffer-and-maybe-kill
- ediff-buffer-C merge-store-file 'show-file save-and-continue))
- ((eq ediff-autostore-merges t)
- ;; ask for file name
- (setq merge-store-file
- (read-file-name "Save the result of the merge in file: "))
- (ediff-write-merge-buffer-and-maybe-kill
- ediff-buffer-C merge-store-file nil save-and-continue))
- ((and (ediff-buffer-live-p ediff-meta-buffer)
- (ediff-with-current-buffer ediff-meta-buffer
- (ediff-merge-metajob)))
- ;; The parent metajob passed nil as the autostore file.
- nil)))
- ))
-
-;; write merge buffer. If the optional argument save-and-continue is non-nil,
-;; then don't kill the merge buffer
-(defun ediff-write-merge-buffer-and-maybe-kill (buf file
- &optional
- show-file save-and-continue)
- (if (not (eq (find-buffer-visiting file) buf))
- (let ((warn-message
- (format "Another buffer is visiting file %s. Too dangerous to save the merge buffer"
- file)))
- (beep)
- (message "%s" warn-message)
- (with-output-to-temp-buffer ediff-msg-buffer
- (princ "\n\n")
- (princ warn-message)
- (princ "\n\n")
- )
- (sit-for 2))
- (ediff-with-current-buffer buf
- (if (or (not (file-exists-p file))
- (y-or-n-p (format "File %s exists, overwrite? " file)))
- (progn
- ;;(write-region nil nil file)
- (ediff-with-current-buffer buf
- (set-visited-file-name file)
- (save-buffer))
- (if show-file
- (progn
- (message "Merge buffer saved in: %s" file)
- (set-buffer-modified-p nil)
- (sit-for 3)))
- (if (and
- (not save-and-continue)
- (y-or-n-p "Merge buffer saved. Now kill the buffer? "))
- (ediff-kill-buffer-carefully buf)))))
- ))
-
-;; The default way of suspending Ediff.
-;; Buries Ediff buffers, kills all windows.
-(defun ediff-default-suspend-function ()
- (let* ((buf-A ediff-buffer-A)
- (buf-B ediff-buffer-B)
- (buf-C ediff-buffer-C)
- (buf-A-wind (ediff-get-visible-buffer-window buf-A))
- (buf-B-wind (ediff-get-visible-buffer-window buf-B))
- (buf-C-wind (ediff-get-visible-buffer-window buf-C))
- (buf-patch (if (boundp 'ediff-patchbufer) ediff-patchbufer nil))
- (buf-patch-diag (if (boundp 'ediff-patch-diagnostics)
- ediff-patch-diagnostics nil))
- (buf-err ediff-error-buffer)
- (buf-diff ediff-diff-buffer)
- (buf-custom-diff ediff-custom-diff-buffer)
- (buf-fine-diff ediff-fine-diff-buffer))
-
- ;; hide the control panel
- (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame))
- (iconify-frame ediff-control-frame)
- (bury-buffer))
- (if buf-err (bury-buffer buf-err))
- (if buf-diff (bury-buffer buf-diff))
- (if buf-custom-diff (bury-buffer buf-custom-diff))
- (if buf-fine-diff (bury-buffer buf-fine-diff))
- (if buf-patch (bury-buffer buf-patch))
- (if buf-patch-diag (bury-buffer buf-patch-diag))
- (if (window-live-p buf-A-wind)
- (progn
- (select-window buf-A-wind)
- (delete-other-windows)
- (bury-buffer))
- (if (ediff-buffer-live-p buf-A)
- (progn
- (set-buffer buf-A)
- (bury-buffer))))
- (if (window-live-p buf-B-wind)
- (progn
- (select-window buf-B-wind)
- (delete-other-windows)
- (bury-buffer))
- (if (ediff-buffer-live-p buf-B)
- (progn
- (set-buffer buf-B)
- (bury-buffer))))
- (if (window-live-p buf-C-wind)
- (progn
- (select-window buf-C-wind)
- (delete-other-windows)
- (bury-buffer))
- (if (ediff-buffer-live-p buf-C)
- (progn
- (set-buffer buf-C)
- (bury-buffer))))
- ))
-
-
-(defun ediff-suspend ()
- "Suspend Ediff.
-To resume, switch to the appropriate `Ediff Control Panel'
-buffer and then type \\[ediff-recenter]. Ediff will automatically set
-up an appropriate window config."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (run-hooks 'ediff-suspend-hook)
- (message
- "To resume, type M-x eregistry and select the desired Ediff session"))
-
-;; ediff-barf-if-not-control-buffer ensures only called from ediff.
-(declare-function ediff-version "ediff" ())
-
-(defun ediff-status-info ()
- "Show the names of the buffers or files being operated on by Ediff.
-Hit \\[ediff-recenter] to reset the windows afterward."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (save-excursion
- (ediff-skip-unsuitable-frames))
- (with-output-to-temp-buffer ediff-msg-buffer
- (ediff-with-current-buffer standard-output
- (fundamental-mode))
- (raise-frame (selected-frame))
- (princ (ediff-version))
- (princ "\n\n")
- (ediff-with-current-buffer ediff-buffer-A
- (if buffer-file-name
- (princ
- (format "File A = %S\n" buffer-file-name))
- (princ
- (format "Buffer A = %S\n" (buffer-name)))))
- (ediff-with-current-buffer ediff-buffer-B
- (if buffer-file-name
- (princ
- (format "File B = %S\n" buffer-file-name))
- (princ
- (format "Buffer B = %S\n" (buffer-name)))))
- (if ediff-3way-job
- (ediff-with-current-buffer ediff-buffer-C
- (if buffer-file-name
- (princ
- (format "File C = %S\n" buffer-file-name))
- (princ
- (format "Buffer C = %S\n" (buffer-name))))))
- (princ (format "Customized diff output %s\n"
- (if (ediff-buffer-live-p ediff-custom-diff-buffer)
- (concat "\tin buffer "
- (buffer-name ediff-custom-diff-buffer))
- " is not available")))
- (princ (format "Plain diff output %s\n"
- (if (ediff-buffer-live-p ediff-diff-buffer)
- (concat "\tin buffer "
- (buffer-name ediff-diff-buffer))
- " is not available")))
-
- (let* ((A-line (ediff-with-current-buffer ediff-buffer-A
- (1+ (count-lines (point-min) (point)))))
- (B-line (ediff-with-current-buffer ediff-buffer-B
- (1+ (count-lines (point-min) (point)))))
- C-line)
- (princ (format "\Buffer A's point is on line %d\n" A-line))
- (princ (format "Buffer B's point is on line %d\n" B-line))
- (if ediff-3way-job
- (progn
- (setq C-line (ediff-with-current-buffer ediff-buffer-C
- (1+ (count-lines (point-min) (point)))))
- (princ (format "Buffer C's point is on line %d\n" C-line)))))
-
- (princ (format "\nCurrent difference number = %S\n"
- (cond ((< ediff-current-difference 0) 'start)
- ((>= ediff-current-difference
- ediff-number-of-differences) 'end)
- (t (1+ ediff-current-difference)))))
-
- (princ
- (format "\n%s regions that differ in white space & line breaks only"
- (if ediff-ignore-similar-regions
- "Ignoring" "Showing")))
- (if (and ediff-merge-job ediff-show-clashes-only)
- (princ
- "\nFocusing on regions where both buffers differ from the ancestor"))
- (if (and ediff-skip-merge-regions-that-differ-from-default ediff-merge-job)
- (princ
- "\nSkipping merge regions that differ from default setting"))
-
- (cond ((eq ediff-skip-diff-region-function 'ediff-show-all-diffs)
- (princ "\nSelective browsing by regexp is off\n"))
- ((eq ediff-skip-diff-region-function
- ediff-hide-regexp-matches-function)
- (princ
- "\nIgnoring regions that match")
- (princ
- (format
- "\n\t regexp `%s' in buffer A %S\n\t regexp `%s' in buffer B\n"
- ediff-regexp-hide-A ediff-hide-regexp-connective
- ediff-regexp-hide-B)))
- ((eq ediff-skip-diff-region-function
- ediff-focus-on-regexp-matches-function)
- (princ
- "\nFocusing on regions that match")
- (princ
- (format
- "\n\t regexp `%s' in buffer A %S\n\t regexp `%s' in buffer B\n"
- ediff-regexp-focus-A ediff-focus-regexp-connective
- ediff-regexp-focus-B)))
- (t (princ "\nSelective browsing via a user-defined method.\n")))
-
- (princ
- (format "\nBugs/suggestions: type `%s' while in Ediff Control Panel."
- (substitute-command-keys "\\[ediff-submit-report]")))
- ) ; with output
- (if (frame-live-p ediff-control-frame)
- (ediff-reset-mouse ediff-control-frame))
- (if (window-live-p ediff-control-window)
- (select-window ediff-control-window)))
-
-
-
-\f
-;;; Support routines
-
-;; Select a difference by placing the ASCII flags around the appropriate
-;; group of lines in the A, B buffers
-;; This may have to be modified for buffer C, when it will be supported.
-(defun ediff-select-difference (n)
- (if (and (ediff-buffer-live-p ediff-buffer-A)
- (ediff-buffer-live-p ediff-buffer-B)
- (ediff-valid-difference-p n))
- (progn
- (cond
- ((and (ediff-has-face-support-p) ediff-use-faces)
- (ediff-highlight-diff n))
- ((eq ediff-highlighting-style 'ascii)
- (ediff-place-flags-in-buffer
- 'A ediff-buffer-A ediff-control-buffer n)
- (ediff-place-flags-in-buffer
- 'B ediff-buffer-B ediff-control-buffer n)
- (if ediff-3way-job
- (ediff-place-flags-in-buffer
- 'C ediff-buffer-C ediff-control-buffer n))
- (if (ediff-buffer-live-p ediff-ancestor-buffer)
- (ediff-place-flags-in-buffer
- 'Ancestor ediff-ancestor-buffer
- ediff-control-buffer n))
- ))
-
- (ediff-install-fine-diff-if-necessary n)
- ;; set current difference here so the hook will be able to refer to it
- (setq ediff-current-difference n)
- (run-hooks 'ediff-select-hook))))
-
-
-;; Unselect a difference by removing the ASCII flags in the buffers.
-;; This may have to be modified for buffer C, when it will be supported.
-(defun ediff-unselect-difference (n)
- (if (ediff-valid-difference-p n)
- (progn
- (cond ((and (ediff-has-face-support-p) ediff-use-faces)
- (ediff-unhighlight-diff))
- ((eq ediff-highlighting-style 'ascii)
- (ediff-remove-flags-from-buffer
- ediff-buffer-A
- (ediff-get-diff-overlay n 'A))
- (ediff-remove-flags-from-buffer
- ediff-buffer-B
- (ediff-get-diff-overlay n 'B))
- (if ediff-3way-job
- (ediff-remove-flags-from-buffer
- ediff-buffer-C
- (ediff-get-diff-overlay n 'C)))
- (if (ediff-buffer-live-p ediff-ancestor-buffer)
- (ediff-remove-flags-from-buffer
- ediff-ancestor-buffer
- (ediff-get-diff-overlay n 'Ancestor)))
- ))
-
- ;; unhighlight fine diffs
- (ediff-set-fine-diff-properties ediff-current-difference 'default)
- (run-hooks 'ediff-unselect-hook))))
-
-
-;; Unselects prev diff and selects a new one, if FLAG has value other than
-;; 'select-only or 'unselect-only. If FLAG is 'select-only, the
-;; next difference is selected, but the current selection is not
-;; unselected. If FLAG is 'unselect-only then the current selection is
-;; unselected, but the next one is not selected. If NO-RECENTER is non-nil,
-;; don't recenter buffers after selecting/unselecting.
-(defun ediff-unselect-and-select-difference (n &optional flag no-recenter)
- (let ((ediff-current-difference n))
- (or no-recenter
- (ediff-recenter 'no-rehighlight)))
-
- (let ((control-buf ediff-control-buffer))
- (unwind-protect
- (progn
- (or (eq flag 'select-only)
- (ediff-unselect-difference ediff-current-difference))
-
- (or (eq flag 'unselect-only)
- (ediff-select-difference n))
- ;; need to set current diff here even though it is also set in
- ;; ediff-select-difference because ediff-select-difference might not
- ;; be called if unselect-only is specified
- (setq ediff-current-difference n)
- ) ; end protected section
-
- (ediff-with-current-buffer control-buf (ediff-refresh-mode-lines)))
- ))
-
-
-
-(defun ediff-highlight-diff-in-one-buffer (n buf-type)
- (if (ediff-buffer-live-p (ediff-get-buffer buf-type))
- (let* ((buff (ediff-get-buffer buf-type))
- (last (ediff-with-current-buffer buff (point-max)))
- (begin (ediff-get-diff-posn buf-type 'beg n))
- (end (ediff-get-diff-posn buf-type 'end n))
- (xtra (if (equal begin end) 1 0))
- (end-hilit (min last (+ end xtra)))
- (current-diff-overlay
- (symbol-value
- (ediff-get-symbol-from-alist
- buf-type ediff-current-diff-overlay-alist))))
-
- (if (featurep 'xemacs)
- (ediff-move-overlay current-diff-overlay begin end-hilit)
- (ediff-move-overlay current-diff-overlay begin end-hilit buff))
- (ediff-overlay-put current-diff-overlay 'priority
- (ediff-highest-priority begin end-hilit buff))
- (ediff-overlay-put current-diff-overlay 'ediff-diff-num n)
-
- ;; unhighlight the background overlay for diff n so it won't
- ;; interfere with the current diff overlay
- (ediff-set-overlay-face (ediff-get-diff-overlay n buf-type) nil)
- )))
-
-
-(defun ediff-unhighlight-diff-in-one-buffer (buf-type)
- (if (ediff-buffer-live-p (ediff-get-buffer buf-type))
- (let ((current-diff-overlay
- (symbol-value
- (ediff-get-symbol-from-alist
- buf-type ediff-current-diff-overlay-alist)))
- (overlay
- (ediff-get-diff-overlay ediff-current-difference buf-type))
- )
-
- (ediff-move-overlay current-diff-overlay 1 1)
-
- ;; rehighlight the overlay in the background of the
- ;; current difference region
- (ediff-set-overlay-face
- overlay
- (if (and (ediff-has-face-support-p)
- ediff-use-faces ediff-highlight-all-diffs)
- (ediff-background-face buf-type ediff-current-difference)))
- )))
-
-(defun ediff-unhighlight-diffs-totally-in-one-buffer (buf-type)
- (ediff-unselect-and-select-difference -1)
- (if (and (ediff-has-face-support-p) ediff-use-faces)
- (let* ((inhibit-quit t)
- (current-diff-overlay-var
- (ediff-get-symbol-from-alist
- buf-type ediff-current-diff-overlay-alist))
- (current-diff-overlay (symbol-value current-diff-overlay-var)))
- (ediff-paint-background-regions 'unhighlight)
- (if (ediff-overlayp current-diff-overlay)
- (ediff-delete-overlay current-diff-overlay))
- (set current-diff-overlay-var nil)
- )))
-
-
-(defun ediff-highlight-diff (n)
- "Put face on diff N. Invoked for X displays only."
- (ediff-highlight-diff-in-one-buffer n 'A)
- (ediff-highlight-diff-in-one-buffer n 'B)
- (ediff-highlight-diff-in-one-buffer n 'C)
- (ediff-highlight-diff-in-one-buffer n 'Ancestor)
- )
-
-
-(defun ediff-unhighlight-diff ()
- "Remove overlays from buffers A, B, and C."
- (ediff-unhighlight-diff-in-one-buffer 'A)
- (ediff-unhighlight-diff-in-one-buffer 'B)
- (ediff-unhighlight-diff-in-one-buffer 'C)
- (ediff-unhighlight-diff-in-one-buffer 'Ancestor)
- )
-
-;; delete highlighting overlays, restore faces to their original form
-(defun ediff-unhighlight-diffs-totally ()
- (ediff-unhighlight-diffs-totally-in-one-buffer 'A)
- (ediff-unhighlight-diffs-totally-in-one-buffer 'B)
- (ediff-unhighlight-diffs-totally-in-one-buffer 'C)
- (ediff-unhighlight-diffs-totally-in-one-buffer 'Ancestor)
- )
-
-
-;; for compatibility
-(defmacro ediff-minibuffer-with-setup-hook (fun &rest body)
- `(if (fboundp 'minibuffer-with-setup-hook)
- (minibuffer-with-setup-hook ,fun ,@body)
- ,@body))
-
-;; This is adapted from a similar function in `emerge.el'.
-;; PROMPT should not have a trailing ': ', so that it can be modified
-;; according to context.
-;; If DEFAULT-FILE is set, it should be used as the default value.
-;; If DEFAULT-DIR is non-nil, use it as the default directory.
-;; Otherwise, use the value of Emacs' variable `default-directory.'
-(defun ediff-read-file-name (prompt default-dir default-file &optional no-dirs)
- ;; hack default-dir if it is not set
- (setq default-dir
- (file-name-as-directory
- (ediff-abbreviate-file-name
- (expand-file-name (or default-dir
- (and default-file
- (file-name-directory default-file))
- default-directory)))))
-
- ;; strip the directory from default-file
- (if default-file
- (setq default-file (file-name-nondirectory default-file)))
- (if (string= default-file "")
- (setq default-file nil))
-
- (let ((defaults (and (fboundp 'dired-dwim-target-defaults)
- (dired-dwim-target-defaults
- (and default-file (list default-file))
- default-dir)))
- f)
- (setq f (ediff-minibuffer-with-setup-hook
- (lambda () (when defaults
- (setq minibuffer-default defaults)))
- (read-file-name
- (format "%s%s "
- prompt
- (cond (default-file
- (concat " (default " default-file "):"))
- (t (concat " (default " default-dir "):"))))
- default-dir
- (or default-file default-dir)
- t ; must match, no-confirm
- (if default-file (file-name-directory default-file)))))
- (setq f (expand-file-name f default-dir))
- ;; If user entered a directory name, expand the default file in that
- ;; directory. This allows the user to enter a directory name for the
- ;; B-file and diff against the default-file in that directory instead
- ;; of a DIRED listing!
- (if (and (file-directory-p f) default-file)
- (setq f (expand-file-name
- (file-name-nondirectory default-file) f)))
- (if (and no-dirs (file-directory-p f))
- (error "File %s is a directory" f))
- f))
-
-;; If PREFIX is given, then it is used as a prefix for the temp file
-;; name. Otherwise, `ediff' is used. If FILE is given, use this
-;; file and don't create a new one.
-;; In MS-DOS, make sure the prefix isn't too long, or else
-;; `make-temp-name' isn't guaranteed to return a unique filename.
-;; Also, save buffer from START to END in the file.
-;; START defaults to (point-min), END to (point-max)
-(defun ediff-make-temp-file (buff &optional prefix given-file start end)
- (let* ((p (ediff-convert-standard-filename (or prefix "ediff")))
- (short-p p)
- (coding-system-for-write ediff-coding-system-for-write)
- f short-f)
- (if (and (fboundp 'msdos-long-file-names)
- (not (msdos-long-file-names))
- (> (length p) 2))
- (setq short-p (substring p 0 2)))
-
- (setq f (concat ediff-temp-file-prefix p)
- short-f (concat ediff-temp-file-prefix short-p)
- f (cond (given-file)
- ((find-file-name-handler f 'insert-file-contents)
- ;; to thwart file handlers in write-region, e.g., if file
- ;; name ends with .Z or .gz
- ;; This is needed so that patches produced by ediff will
- ;; have more meaningful names
- (ediff-make-empty-tmp-file short-f))
- (prefix
- ;; Prefix is most often the same as the file name for the
- ;; variant. Here we are trying to use the original file
- ;; name but in the temp directory.
- (ediff-make-empty-tmp-file f 'keep-name))
- (t
- ;; If don't care about name, add some random stuff
- ;; to proposed file name.
- (ediff-make-empty-tmp-file short-f))))
-
- ;; create the file
- (ediff-with-current-buffer buff
- (write-region (if start start (point-min))
- (if end end (point-max))
- f
- nil ; don't append---erase
- 'no-message)
- (set-file-modes f ediff-temp-file-mode)
- (expand-file-name f))))
-
-;; Create a temporary file.
-;; The returned file name (created by appending some random characters at the
-;; end of PROPOSED-NAME is guaranteed to point to a newly created empty file.
-;; This is a replacement for make-temp-name, which eliminates a security hole.
-;; If KEEP-PROPOSED-NAME isn't nil, try to keep PROPOSED-NAME, unless such file
-;; already exists.
-;; It is a modified version of make-temp-file in emacs 20.5
-(defun ediff-make-empty-tmp-file (proposed-name &optional keep-proposed-name)
- (let ((file proposed-name))
- (while (condition-case ()
- (progn
- (if (or (file-exists-p file) (not keep-proposed-name))
- (setq file (make-temp-name proposed-name)))
- ;; the with-temp-buffer thing is a workaround for an XEmacs
- ;; bug: write-region complains that we are trying to visit a
- ;; file in an indirect buffer, failing to notice that the
- ;; VISIT flag is unset and that we are actually writing from a
- ;; string and not from any buffer.
- (with-temp-buffer
- (write-region "" nil file nil 'silent nil 'excl))
- nil)
- (file-already-exists t))
- ;; the file was somehow created by someone else between
- ;; `make-temp-name' and `write-region', let's try again.
- nil)
- file))
-
-
-;; Quote metacharacters (using \) when executing diff in Unix, but not in
-;; EMX OS/2
-;;(defun ediff-protect-metachars (str)
-;; (or (memq system-type '(emx))
-;; (let ((limit 0))
-;; (while (string-match ediff-metachars str limit)
-;; (setq str (concat (substring str 0 (match-beginning 0))
-;; "\\"
-;; (substring str (match-beginning 0))))
-;; (setq limit (1+ (match-end 0))))))
-;; str)
-
-;; Make sure the current buffer (for a file) has the same contents as the
-;; file on disk, and attempt to remedy the situation if not.
-;; Signal an error if we can't make them the same, or the user doesn't want
-;; to do what is necessary to make them the same.
-;; Also, Ediff always offers to revert obsolete buffers, whether they
-;; are modified or not.
-(defun ediff-verify-file-buffer (&optional file-magic)
- ;; First check if the file has been modified since the buffer visited it.
- (if (verify-visited-file-modtime (current-buffer))
- (if (buffer-modified-p)
- ;; If buffer is not obsolete and is modified, offer to save
- (if (yes-or-no-p
- (format "Buffer %s has been modified. Save it in file %s? "
- (buffer-name)
- buffer-file-name))
- (condition-case nil
- (save-buffer)
- (error
- (beep)
- (message "Couldn't save %s" buffer-file-name)))
- (error "Buffer is out of sync for file %s" buffer-file-name))
- ;; If buffer is not obsolete and is not modified, do nothing
- nil)
- ;; If buffer is obsolete, offer to revert
- (if (yes-or-no-p
- (format "File %s was modified since visited by buffer %s. REVERT file %s? "
- buffer-file-name
- (buffer-name)
- buffer-file-name))
- (progn
- (if file-magic
- (erase-buffer))
- (revert-buffer t t))
- (error "Buffer out of sync for file %s" buffer-file-name))))
-
-;; if there is another buffer visiting the file of the merge buffer, offer to
-;; save and delete the buffer; else bark
-(defun ediff-verify-file-merge-buffer (file)
- (let ((buff (if (stringp file) (find-buffer-visiting file)))
- warn-message)
- (or (null buff)
- (progn
- (setq warn-message
- (format "Buffer %s is visiting %s. Save and kill the buffer? "
- (buffer-name buff) file))
- (with-output-to-temp-buffer ediff-msg-buffer
- (princ "\n\n")
- (princ warn-message)
- (princ "\n\n"))
- (if (y-or-n-p
- (message "%s" warn-message))
- (with-current-buffer buff
- (save-buffer)
- (kill-buffer (current-buffer)))
- (error "Too dangerous to merge versions of a file visited by another buffer"))))
- ))
-
-
-
-(defun ediff-filename-magic-p (file)
- (or (ediff-file-compressed-p file)
- (ediff-file-remote-p file)))
-
-
-(defun ediff-save-buffer (arg)
- "Safe way of saving buffers A, B, C, and the diff output.
-`wa' saves buffer A, `wb' saves buffer B, `wc' saves buffer C,
-and `wd' saves the diff output.
-
-With prefix argument, `wd' saves plain diff output.
-Without an argument, it saves customized diff argument, if available
-\(and plain output, if customized output was not generated\)."
- (interactive "P")
- (ediff-barf-if-not-control-buffer)
- (ediff-compute-custom-diffs-maybe)
- (ediff-with-current-buffer
- (cond ((memq (ediff-last-command-char) '(?a ?b ?c))
- (ediff-get-buffer
- (ediff-char-to-buftype (ediff-last-command-char))))
- ((eq (ediff-last-command-char) ?d)
- (message "Saving diff output ...")
- (sit-for 1) ; let the user see the message
- (cond ((and arg (ediff-buffer-live-p ediff-diff-buffer))
- ediff-diff-buffer)
- ((ediff-buffer-live-p ediff-custom-diff-buffer)
- ediff-custom-diff-buffer)
- ((ediff-buffer-live-p ediff-diff-buffer)
- ediff-diff-buffer)
- (t (error "Output from `diff' not found"))))
- )
- (let ((window-min-height 2))
- (save-buffer))))
-
-
-;; idea suggested by Hannu Koivisto <azure@iki.fi>
-(defun ediff-clone-buffer-for-region-comparison (buff region-name)
- (let ((cloned-buff (ediff-make-cloned-buffer buff region-name))
- (pop-up-windows t)
- wind
- other-wind
- msg-buf)
- (ediff-with-current-buffer cloned-buff
- (setq ediff-temp-indirect-buffer t))
- (pop-to-buffer cloned-buff)
- (setq wind (ediff-get-visible-buffer-window cloned-buff))
- (select-window wind)
- (delete-other-windows)
- (ediff-activate-mark)
- (split-window-vertically)
- (ediff-select-lowest-window)
- (setq other-wind (selected-window))
- (with-temp-buffer
- (erase-buffer)
- (insert
- (format "\n ******* Mark a region in buffer %s (or confirm the existing one) *******\n"
- (buffer-name cloned-buff)))
- (insert
- (ediff-with-current-buffer buff
- (format "\n\t When done, type %s Use %s to abort\n "
- (ediff-format-bindings-of 'exit-recursive-edit)
- (ediff-format-bindings-of 'abort-recursive-edit))))
- (goto-char (point-min))
- (setq msg-buf (current-buffer))
- (set-window-buffer other-wind msg-buf)
- (shrink-window-if-larger-than-buffer)
- (if (window-live-p wind)
- (select-window wind))
- (condition-case nil
- (recursive-edit)
- (quit
- (ediff-kill-buffer-carefully cloned-buff)))
- )
- cloned-buff))
-
-
-(defun ediff-clone-buffer-for-window-comparison (buff wind region-name)
- (let ((cloned-buff (ediff-make-cloned-buffer buff region-name)))
- (ediff-with-current-buffer cloned-buff
- (setq ediff-temp-indirect-buffer t))
- (set-window-buffer wind cloned-buff)
- cloned-buff))
-
-(defun ediff-clone-buffer-for-current-diff-comparison (buff buf-type reg-name)
- (let ((cloned-buff (ediff-make-cloned-buffer buff reg-name))
- (reg-start (ediff-get-diff-posn buf-type 'beg))
- (reg-end (ediff-get-diff-posn buf-type 'end)))
- (ediff-with-current-buffer cloned-buff
- ;; set region to be the current diff region
- (goto-char reg-start)
- (set-mark reg-end)
- (setq ediff-temp-indirect-buffer t))
- cloned-buff))
-
-
-
-(defun ediff-make-cloned-buffer (buff region-name)
- (ediff-make-indirect-buffer
- buff (generate-new-buffer-name
- (concat (if (stringp buff) buff (buffer-name buff)) region-name))))
-
-
-(defun ediff-make-indirect-buffer (base-buf indirect-buf-name)
- (if (featurep 'xemacs)
- (make-indirect-buffer base-buf indirect-buf-name)
- (make-indirect-buffer base-buf indirect-buf-name 'clone)))
-
-
-;; This function operates only from an ediff control buffer
-(defun ediff-compute-custom-diffs-maybe ()
- (let ((buf-A-file-name (buffer-file-name ediff-buffer-A))
- (buf-B-file-name (buffer-file-name ediff-buffer-B))
- file-A file-B)
- (unless (and buf-A-file-name
- (file-exists-p buf-A-file-name)
- (not (ediff-file-remote-p buf-A-file-name)))
- (setq file-A (ediff-make-temp-file ediff-buffer-A)))
- (unless (and buf-B-file-name
- (file-exists-p buf-B-file-name)
- (not (ediff-file-remote-p buf-B-file-name)))
- (setq file-B (ediff-make-temp-file ediff-buffer-B)))
- (or (ediff-buffer-live-p ediff-custom-diff-buffer)
- (setq ediff-custom-diff-buffer
- (get-buffer-create
- (ediff-unique-buffer-name "*ediff-custom-diff" "*"))))
- (ediff-with-current-buffer ediff-custom-diff-buffer
- (setq buffer-read-only nil)
- (erase-buffer))
- (ediff-exec-process
- ediff-custom-diff-program ediff-custom-diff-buffer 'synchronize
- ediff-custom-diff-options
- (or file-A buf-A-file-name)
- (or file-B buf-B-file-name))
- ;; put the diff file in diff-mode, if it is available
- (if (fboundp 'diff-mode)
- (with-current-buffer ediff-custom-diff-buffer
- (diff-mode)))
- (and file-A (file-exists-p file-A) (delete-file file-A))
- (and file-B (file-exists-p file-B) (delete-file file-B))
- ))
-
-(defun ediff-show-diff-output (arg)
- (interactive "P")
- (ediff-barf-if-not-control-buffer)
- (ediff-compute-custom-diffs-maybe)
- (save-excursion
- (ediff-skip-unsuitable-frames ' ok-unsplittable))
- (let ((buf (cond ((and arg (ediff-buffer-live-p ediff-diff-buffer))
- ediff-diff-buffer)
- ((ediff-buffer-live-p ediff-custom-diff-buffer)
- ediff-custom-diff-buffer)
- ((ediff-buffer-live-p ediff-diff-buffer)
- ediff-diff-buffer)
- (t
- (beep)
- (message "Output from `diff' not found")
- nil))))
- (if buf
- (progn
- (ediff-with-current-buffer buf
- (goto-char (point-min)))
- (switch-to-buffer buf)
- (raise-frame (selected-frame)))))
- (if (frame-live-p ediff-control-frame)
- (ediff-reset-mouse ediff-control-frame))
- (if (window-live-p ediff-control-window)
- (select-window ediff-control-window)))
-
-
-(defun ediff-inferior-compare-regions ()
- "Compare regions in an active Ediff session.
-Like ediff-regions-linewise but is called from under an active Ediff session on
-the files that belong to that session.
-
-After quitting the session invoked via this function, type C-l to the parent
-Ediff Control Panel to restore highlighting."
- (interactive)
- (let ((answer "")
- (possibilities (list ?A ?B ?C))
- (zmacs-regions t)
- use-current-diff-p
- begA begB endA endB bufA bufB)
-
- (if (ediff-valid-difference-p ediff-current-difference)
- (progn
- (ediff-set-fine-diff-properties ediff-current-difference 'default)
- (ediff-unhighlight-diff)))
- (ediff-paint-background-regions 'unhighlight)
-
- (cond ((ediff-merge-job)
- (setq bufB ediff-buffer-C)
- ;; ask which buffer to compare to the merge buffer
- (while (cond ((eq answer ?A)
- (setq bufA ediff-buffer-A
- possibilities '(?B))
- nil)
- ((eq answer ?B)
- (setq bufA ediff-buffer-B
- possibilities '(?A))
- nil)
- ((equal answer ""))
- (t (beep 1)
- (message "Valid values are A or B")
- (sit-for 2)
- t))
- (let ((cursor-in-echo-area t))
- (message
- "Which buffer to compare to the merge buffer (A or B)? ")
- (setq answer (capitalize (read-char-exclusive))))))
-
- ((ediff-3way-comparison-job)
- ;; ask which two buffers to compare
- (while (cond ((memq answer possibilities)
- (setq possibilities (delq answer possibilities))
- (setq bufA
- (eval
- (ediff-get-symbol-from-alist
- answer ediff-buffer-alist)))
- nil)
- ((equal answer ""))
- (t (beep 1)
- (message
- "Valid values are %s"
- (mapconcat 'char-to-string possibilities " or "))
- (sit-for 2)
- t))
- (let ((cursor-in-echo-area t))
- (message "Enter the 1st buffer you want to compare (%s): "
- (mapconcat 'char-to-string possibilities " or "))
- (setq answer (capitalize (read-char-exclusive)))))
- (setq answer "") ; silence error msg
- (while (cond ((memq answer possibilities)
- (setq possibilities (delq answer possibilities))
- (setq bufB
- (eval
- (ediff-get-symbol-from-alist
- answer ediff-buffer-alist)))
- nil)
- ((equal answer ""))
- (t (beep 1)
- (message
- "Valid values are %s"
- (mapconcat 'char-to-string possibilities " or "))
- (sit-for 2)
- t))
- (let ((cursor-in-echo-area t))
- (message "Enter the 2nd buffer you want to compare (%s): "
- (mapconcat 'char-to-string possibilities "/"))
- (setq answer (capitalize (read-char-exclusive))))))
- (t ; 2way comparison
- (setq bufA ediff-buffer-A
- bufB ediff-buffer-B
- possibilities nil)))
-
- (if (and (ediff-valid-difference-p ediff-current-difference)
- (y-or-n-p "Compare currently highlighted difference regions? "))
- (setq use-current-diff-p t))
-
- (setq bufA (if use-current-diff-p
- (ediff-clone-buffer-for-current-diff-comparison
- bufA 'A "-Region.A-")
- (ediff-clone-buffer-for-region-comparison bufA "-Region.A-")))
- (ediff-with-current-buffer bufA
- (setq begA (region-beginning)
- endA (region-end))
- (goto-char begA)
- (beginning-of-line)
- (setq begA (point))
- (goto-char endA)
- (end-of-line)
- (or (eobp) (forward-char)) ; include the newline char
- (setq endA (point)))
-
- (setq bufB (if use-current-diff-p
- (ediff-clone-buffer-for-current-diff-comparison
- bufB 'B "-Region.B-")
- (ediff-clone-buffer-for-region-comparison bufB "-Region.B-")))
- (ediff-with-current-buffer bufB
- (setq begB (region-beginning)
- endB (region-end))
- (goto-char begB)
- (beginning-of-line)
- (setq begB (point))
- (goto-char endB)
- (end-of-line)
- (or (eobp) (forward-char)) ; include the newline char
- (setq endB (point)))
-
-
- (ediff-regions-internal
- bufA begA endA bufB begB endB
- nil ; setup-hook
- (if use-current-diff-p ; job name
- 'ediff-regions-wordwise
- 'ediff-regions-linewise)
- (if use-current-diff-p ; word mode, if diffing current diff
- t nil)
- ;; setup param to pass to ediff-setup
- (list (cons 'ediff-split-window-function ediff-split-window-function)))
- ))
-
-
-
-(defun ediff-remove-flags-from-buffer (buffer overlay)
- (ediff-with-current-buffer buffer
- (let ((inhibit-read-only t))
- (if (featurep 'xemacs)
- (ediff-overlay-put overlay 'begin-glyph nil)
- (ediff-overlay-put overlay 'before-string nil))
-
- (if (featurep 'xemacs)
- (ediff-overlay-put overlay 'end-glyph nil)
- (ediff-overlay-put overlay 'after-string nil))
- )))
-
-
-
-(defun ediff-place-flags-in-buffer (buf-type buffer ctl-buffer diff)
- (ediff-with-current-buffer buffer
- (ediff-place-flags-in-buffer1 buf-type ctl-buffer diff)))
-
-
-(defun ediff-place-flags-in-buffer1 (buf-type ctl-buffer diff-no)
- (let* ((curr-overl (ediff-with-current-buffer ctl-buffer
- (ediff-get-diff-overlay diff-no buf-type)))
- (before (ediff-get-diff-posn buf-type 'beg diff-no ctl-buffer))
- after beg-of-line flag)
-
- ;; insert flag before the difference
- (goto-char before)
- (setq beg-of-line (bolp))
-
- (setq flag (ediff-with-current-buffer ctl-buffer
- (if (eq ediff-highlighting-style 'ascii)
- (if beg-of-line
- ediff-before-flag-bol ediff-before-flag-mol))))
-
- ;; insert the flag itself
- (if (featurep 'xemacs)
- (ediff-overlay-put curr-overl 'begin-glyph flag)
- (ediff-overlay-put curr-overl 'before-string flag))
-
- ;; insert the flag after the difference
- ;; `after' must be set here, after the before-flag was inserted
- (setq after (ediff-get-diff-posn buf-type 'end diff-no ctl-buffer))
- (goto-char after)
- (setq beg-of-line (bolp))
-
- (setq flag (ediff-with-current-buffer ctl-buffer
- (if (eq ediff-highlighting-style 'ascii)
- (if beg-of-line
- ediff-after-flag-eol ediff-after-flag-mol))))
-
- ;; insert the flag itself
- (if (featurep 'xemacs)
- (ediff-overlay-put curr-overl 'end-glyph flag)
- (ediff-overlay-put curr-overl 'after-string flag))
- ))
-
-
-;;; Some diff region tests
-
-;; t if diff region is empty.
-;; In case of buffer C, t also if it is not a 3way
-;; comparison job (merging jobs return t as well).
-(defun ediff-empty-diff-region-p (n buf-type)
- (if (eq buf-type 'C)
- (or (not ediff-3way-comparison-job)
- (= (ediff-get-diff-posn 'C 'beg n)
- (ediff-get-diff-posn 'C 'end n)))
- (= (ediff-get-diff-posn buf-type 'beg n)
- (ediff-get-diff-posn buf-type 'end n))))
-
-;; Test if diff region is white space only.
-;; If 2-way job and buf-type = C, then returns t.
-(defun ediff-whitespace-diff-region-p (n buf-type)
- (or (and (eq buf-type 'C) (not ediff-3way-job))
- (ediff-empty-diff-region-p n buf-type)
- (let ((beg (ediff-get-diff-posn buf-type 'beg n))
- (end (ediff-get-diff-posn buf-type 'end n)))
- (ediff-with-current-buffer (ediff-get-buffer buf-type)
- (save-excursion
- (goto-char beg)
- (skip-chars-forward ediff-whitespace)
- (>= (point) end))))))
-
-
-(defun ediff-get-region-contents (n buf-type ctrl-buf &optional start end)
- (ediff-with-current-buffer
- (ediff-with-current-buffer ctrl-buf (ediff-get-buffer buf-type))
- (buffer-substring
- (or start (ediff-get-diff-posn buf-type 'beg n ctrl-buf))
- (or end (ediff-get-diff-posn buf-type 'end n ctrl-buf)))))
-
-;; Returns positions of difference sectors in the BUF-TYPE buffer.
-;; BUF-TYPE should be a symbol -- `A', `B', or `C'.
-;; POS is either `beg' or `end'--it specifies whether you want the position at
-;; the beginning of a difference or at the end.
-;;
-;; The optional argument N says which difference (default:
-;; `ediff-current-difference'). N is the internal difference number (1- what
-;; the user sees). The optional argument CONTROL-BUF says
-;; which control buffer is in effect in case it is not the current
-;; buffer.
-(defun ediff-get-diff-posn (buf-type pos &optional n control-buf)
- (let (diff-overlay)
- (or control-buf
- (setq control-buf (current-buffer)))
-
- (ediff-with-current-buffer control-buf
- (or n (setq n ediff-current-difference))
- (if (or (< n 0) (>= n ediff-number-of-differences))
- (if (> ediff-number-of-differences 0)
- (error ediff-BAD-DIFF-NUMBER
- this-command (1+ n) ediff-number-of-differences)
- (error ediff-NO-DIFFERENCES)))
- (setq diff-overlay (ediff-get-diff-overlay n buf-type)))
- (if (not (ediff-buffer-live-p (ediff-overlay-buffer diff-overlay)))
- (error ediff-KILLED-VITAL-BUFFER))
- (if (eq pos 'beg)
- (ediff-overlay-start diff-overlay)
- (ediff-overlay-end diff-overlay))
- ))
-
-
-;; Restore highlighting to what it should be according to ediff-use-faces,
-;; ediff-highlighting-style, and ediff-highlight-all-diffs variables.
-(defun ediff-restore-highlighting (&optional ctl-buf)
- (ediff-with-current-buffer (or ctl-buf (current-buffer))
- (if (and (ediff-has-face-support-p)
- ediff-use-faces
- ediff-highlight-all-diffs)
- (ediff-paint-background-regions))
- (ediff-select-difference ediff-current-difference)))
-
-
-
-;; null out difference overlays so they won't slow down future
-;; editing operations
-;; VEC is either a difference vector or a fine-diff vector
-(defun ediff-clear-diff-vector (vec-var &optional fine-diffs-also)
- (if (vectorp (symbol-value vec-var))
- (mapc (lambda (elt)
- (ediff-delete-overlay
- (ediff-get-diff-overlay-from-diff-record elt))
- (if fine-diffs-also
- (ediff-clear-fine-diff-vector elt))
- )
- (symbol-value vec-var)))
- ;; allow them to be garbage collected
- (set vec-var nil))
-
-
-\f
-;;; Misc
-
-;; In Emacs, this just makes overlay. In the future, when Emacs will start
-;; supporting sticky overlays, this function will make a sticky overlay.
-;; BEG and END are expressions telling where overlay starts.
-;; If they are numbers or buffers, then all is well. Otherwise, they must
-;; be expressions to be evaluated in buffer BUF in order to get the overlay
-;; bounds.
-;; If BUFF is not a live buffer, then return nil; otherwise, return the
-;; newly created overlay.
-(defun ediff-make-bullet-proof-overlay (beg end buff)
- (if (ediff-buffer-live-p buff)
- (let (overl)
- (ediff-with-current-buffer buff
- (or (number-or-marker-p beg)
- (setq beg (eval beg)))
- (or (number-or-marker-p end)
- (setq end (eval end)))
- (setq overl
- (if (featurep 'xemacs)
- (make-extent beg end buff)
- ;; advance front and rear of the overlay
- (make-overlay beg end buff nil 'rear-advance)))
-
- ;; never detach
- (ediff-overlay-put
- overl (if (featurep 'emacs) 'evaporate 'detachable) nil)
- ;; make overlay open-ended
- ;; In emacs, it is made open ended at creation time
- (when (featurep 'xemacs)
- (ediff-overlay-put overl 'start-open nil)
- (ediff-overlay-put overl 'end-open nil))
- (ediff-overlay-put overl 'ediff-diff-num 0)
- overl))))
-
-
-(defun ediff-make-current-diff-overlay (type)
- (if (ediff-has-face-support-p)
- (let ((overlay (ediff-get-symbol-from-alist
- type ediff-current-diff-overlay-alist))
- (buffer (ediff-get-buffer type))
- (face (ediff-get-symbol-from-alist
- type ediff-current-diff-face-alist)))
- (set overlay
- (ediff-make-bullet-proof-overlay (point-max) (point-max) buffer))
- (ediff-set-overlay-face (symbol-value overlay) face)
- (ediff-overlay-put (symbol-value overlay) 'ediff ediff-control-buffer))
- ))
-
-
-;; Like other-buffer, but prefers visible buffers and ignores temporary or
-;; other insignificant buffers (those beginning with "^[ *]").
-;; Gets one arg--buffer name or a list of buffer names (it won't return
-;; these buffers).
-;; EXCL-BUFF-LIST is an exclusion list.
-(defun ediff-other-buffer (excl-buff-lst)
- (or (listp excl-buff-lst) (setq excl-buff-lst (list excl-buff-lst)))
- (let* ((all-buffers (nconc (ediff-get-selected-buffers) (buffer-list)))
- ;; we compute this the second time because we need to do memq on it
- ;; later, and nconc above will break it. Either this or use slow
- ;; append instead of nconc
- (selected-buffers (ediff-get-selected-buffers))
- (prefered-buffer (car all-buffers))
- visible-dired-buffers
- (excl-buff-name-list
- (mapcar
- (lambda (b) (cond ((stringp b) b)
- ((bufferp b) (buffer-name b))))
- excl-buff-lst))
- ;; if at least one buffer on the exclusion list is dired, then force
- ;; all others to be dired. This is because this means that the user
- ;; has already chosen a dired buffer before
- (use-dired-major-mode
- (cond ((null (ediff-buffer-live-p (car excl-buff-lst))) 'unknown)
- ((eq (ediff-with-current-buffer (car excl-buff-lst) major-mode)
- 'dired-mode)
- 'yes)
- (t 'no)))
- ;; significant-buffers must be visible and not belong
- ;; to the exclusion list `buff-list'
- ;; We also exclude temporary buffers, but keep mail and gnus buffers
- ;; Furthermore, we exclude dired buffers, unless they are the only
- ;; ones visible (and there are at least two of them).
- ;; Also, any visible window not on the exclusion list that is first in
- ;; the buffer list is chosen regardless. (This is because the user
- ;; clicked on it or did something to distinguish it).
- (significant-buffers
- (mapcar
- (lambda (x)
- (cond ((member (buffer-name x) excl-buff-name-list) nil)
- ((memq x selected-buffers) x)
- ((not (ediff-get-visible-buffer-window x)) nil)
- ((eq x prefered-buffer) x)
- ;; if prev selected buffer is dired, look only at
- ;; dired.
- ((eq use-dired-major-mode 'yes)
- (if (eq (ediff-with-current-buffer x major-mode)
- 'dired-mode)
- x nil))
- ((eq (ediff-with-current-buffer x major-mode)
- 'dired-mode)
- (if (null use-dired-major-mode)
- ;; don't know if we must enforce dired.
- ;; Remember this buffer in case
- ;; dired buffs are the only ones visible.
- (setq visible-dired-buffers
- (cons x visible-dired-buffers)))
- ;; skip, if dired is not forced
- nil)
- ((memq (ediff-with-current-buffer x major-mode)
- '(rmail-mode
- vm-mode
- gnus-article-mode
- mh-show-mode))
- x)
- ((string-match "^[ *]" (buffer-name x)) nil)
- ((string= "*scratch*" (buffer-name x)) nil)
- (t x)))
- all-buffers))
- (clean-significant-buffers (delq nil significant-buffers))
- less-significant-buffers)
-
- (if (and (null clean-significant-buffers)
- (> (length visible-dired-buffers) 0))
- (setq clean-significant-buffers visible-dired-buffers))
-
- (cond (clean-significant-buffers (car clean-significant-buffers))
- ;; try also buffers that are not displayed in windows
- ((setq less-significant-buffers
- (delq nil
- (mapcar
- (lambda (x)
- (cond ((member (buffer-name x) excl-buff-name-list)
- nil)
- ((eq use-dired-major-mode 'yes)
- (if (eq (ediff-with-current-buffer
- x major-mode)
- 'dired-mode)
- x nil))
- ((eq (ediff-with-current-buffer x major-mode)
- 'dired-mode)
- nil)
- ((string-match "^[ *]" (buffer-name x)) nil)
- ((string= "*scratch*" (buffer-name x)) nil)
- (t x)))
- all-buffers)))
- (car less-significant-buffers))
- (t "*scratch*"))
- ))
-
-
-;; If current buffer is a Buffer-menu buffer, then take the selected buffers
-;; and append the buffer at the cursor to the end.
-;; This list would be the preferred list.
-(defun ediff-get-selected-buffers ()
- (if (eq major-mode 'Buffer-menu-mode)
- (let ((lis (condition-case nil
- (list (Buffer-menu-buffer t))
- (error))
- ))
- (save-excursion
- (goto-char (point-max))
- (while (search-backward "\n>" nil t)
- (forward-char 1)
- (setq lis (cons (Buffer-menu-buffer t) lis)))
- lis))
- ))
-
-;; Construct a unique buffer name.
-;; The first one tried is prefixsuffix, then prefix<2>suffix,
-;; prefix<3>suffix, etc.
-(defun ediff-unique-buffer-name (prefix suffix)
- (if (null (get-buffer (concat prefix suffix)))
- (concat prefix suffix)
- (let ((n 2))
- (while (get-buffer (format "%s<%d>%s" prefix n suffix))
- (setq n (1+ n)))
- (format "%s<%d>%s" prefix n suffix))))
-
-
-(defun ediff-submit-report ()
- "Submit bug report on Ediff."
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (let ((reporter-prompt-for-summary-p t)
- (ctl-buf ediff-control-buffer)
- (ediff-device-type (ediff-device-type))
- varlist salutation buffer-name)
- (setq varlist '(ediff-diff-program ediff-diff-options
- ediff-diff3-program ediff-diff3-options
- ediff-patch-program ediff-patch-options
- ediff-shell
- ediff-use-faces
- ediff-auto-refine ediff-highlighting-style
- ediff-buffer-A ediff-buffer-B ediff-control-buffer
- ediff-forward-word-function
- ediff-control-frame
- ediff-control-frame-parameters
- ediff-control-frame-position-function
- ediff-prefer-iconified-control-frame
- ediff-window-setup-function
- ediff-split-window-function
- ediff-job-name
- ediff-word-mode
- buffer-name
- ediff-device-type
- ))
- (setq salutation "
-Congratulations! You may have unearthed a bug in Ediff!
-
-Please make a concise and accurate summary of what happened
-and mail it to the address above.
------------------------------------------------------------
-")
-
- (ediff-skip-unsuitable-frames)
- (ediff-reset-mouse)
-
- (switch-to-buffer ediff-msg-buffer)
- (erase-buffer)
- (delete-other-windows)
- (insert "
-Please read this first:
-----------------------
-
-Some ``bugs'' may actually be no bugs at all. For instance, if you are
-reporting that certain difference regions are not matched as you think they
-should, this is most likely due to the way Unix diff program decides what
-constitutes a difference region. Ediff is an Emacs interface to diff, and
-it has nothing to do with those decisions---it only takes the output from
-diff and presents it in a way that is better suited for human browsing and
-manipulation.
-
-If Emacs happens to dump core, this is NOT an Ediff problem---it is
-an Emacs bug. Report this to Emacs maintainers.
-
-Another popular topic for reports is compilation messages. Because Ediff
-interfaces to several other packages and runs under Emacs and XEmacs,
-byte-compilation may produce output like this:
-
- While compiling toplevel forms in file ediff.el:
- ** reference to free variable pm-color-alist
- ........................
- While compiling the end of the data:
- ** The following functions are not known to be defined:
- ediff-valid-color-p, ediff-set-face,
- ........................
-
-These are NOT errors, but inevitable warnings, which ought to be ignored.
-
-Please do not report those and similar things. However, comments and
-suggestions are always welcome.
-
-Mail anyway? (y or n) ")
-
- (if (y-or-n-p "Mail anyway? ")
- (progn
- (if (ediff-buffer-live-p ctl-buf)
- (set-buffer ctl-buf))
- (setq buffer-name (buffer-name))
- (require 'reporter)
- (reporter-submit-bug-report "kifer@cs.stonybrook.edu"
- (ediff-version)
- varlist
- nil
- 'delete-other-windows
- salutation))
- (bury-buffer)
- (beep 1)(message "Bug report aborted")
- (if (ediff-buffer-live-p ctl-buf)
- (ediff-with-current-buffer ctl-buf
- (ediff-recenter 'no-rehighlight))))
- ))
-
-
-;; Find an appropriate syntax table for everyone to use
-;; If buffer B is not fundamental or text mode, use its syntax table
-;; Otherwise, use buffer B's.
-;; The syntax mode is used in ediff-forward-word-function
-;; The important thing is that every buffer should use the same syntax table
-;; during the refinement operation
-(defun ediff-choose-syntax-table ()
- (setq ediff-syntax-table
- (ediff-with-current-buffer ediff-buffer-A
- (if (not (memq major-mode
- '(fundamental-mode text-mode indented-text-mode)))
- (syntax-table))))
- (if (not ediff-syntax-table)
- (setq ediff-syntax-table
- (ediff-with-current-buffer ediff-buffer-B
- (syntax-table))))
- )
-
-
-(defun ediff-deactivate-mark ()
- (if (featurep 'xemacs)
- (zmacs-deactivate-region)
- (deactivate-mark)))
-
-(defun ediff-activate-mark ()
- (if (featurep 'xemacs)
- (zmacs-activate-region)
- (make-local-variable 'transient-mark-mode)
- (setq mark-active t transient-mark-mode t)))
-
-(defun ediff-nuke-selective-display ()
- (if (featurep 'xemacs)
- (nuke-selective-display)
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (let ((mod-p (buffer-modified-p))
- buffer-read-only end)
- (and (eq t selective-display)
- (while (search-forward "\^M" nil t)
- (end-of-line)
- (setq end (point))
- (beginning-of-line)
- (while (search-forward "\^M" end t)
- (delete-char -1)
- (insert "\^J"))))
- (set-buffer-modified-p mod-p)
- (setq selective-display nil))))))
-
-
-;; The next two are modified versions from emerge.el.
-;; VARS must be a list of symbols
-;; ediff-save-variables returns an association list: ((var . val) ...)
-(defsubst ediff-save-variables (vars)
- (mapcar (lambda (v) (cons v (symbol-value v)))
- vars))
-;; VARS is a list of variable symbols.
-(defun ediff-restore-variables (vars assoc-list)
- (while vars
- (set (car vars) (cdr (assoc (car vars) assoc-list)))
- (setq vars (cdr vars))))
-
-(defun ediff-change-saved-variable (var value buf-type)
- (let* ((assoc-list
- (symbol-value (ediff-get-symbol-from-alist
- buf-type
- ediff-buffer-values-orig-alist)))
- (assoc-elt (assoc var assoc-list)))
- (if assoc-elt
- (setcdr assoc-elt value))))
-
-
-;; must execute in control buf
-(defun ediff-save-protected-variables ()
- (setq ediff-buffer-values-orig-A
- (ediff-with-current-buffer ediff-buffer-A
- (ediff-save-variables ediff-protected-variables)))
- (setq ediff-buffer-values-orig-B
- (ediff-with-current-buffer ediff-buffer-B
- (ediff-save-variables ediff-protected-variables)))
- (if ediff-3way-comparison-job
- (setq ediff-buffer-values-orig-C
- (ediff-with-current-buffer ediff-buffer-C
- (ediff-save-variables ediff-protected-variables))))
- (if (ediff-buffer-live-p ediff-ancestor-buffer)
- (setq ediff-buffer-values-orig-Ancestor
- (ediff-with-current-buffer ediff-ancestor-buffer
- (ediff-save-variables ediff-protected-variables)))))
-
-;; must execute in control buf
-(defun ediff-restore-protected-variables ()
- (let ((values-A ediff-buffer-values-orig-A)
- (values-B ediff-buffer-values-orig-B)
- (values-C ediff-buffer-values-orig-C)
- (values-Ancestor ediff-buffer-values-orig-Ancestor))
- (ediff-with-current-buffer ediff-buffer-A
- (ediff-restore-variables ediff-protected-variables values-A))
- (ediff-with-current-buffer ediff-buffer-B
- (ediff-restore-variables ediff-protected-variables values-B))
- (if ediff-3way-comparison-job
- (ediff-with-current-buffer ediff-buffer-C
- (ediff-restore-variables ediff-protected-variables values-C)))
- (if (ediff-buffer-live-p ediff-ancestor-buffer)
- (ediff-with-current-buffer ediff-ancestor-buffer
- (ediff-restore-variables ediff-protected-variables values-Ancestor)))
- ))
-
-;; save BUFFER in FILE. used in hooks.
-(defun ediff-save-buffer-in-file (buffer file)
- (ediff-with-current-buffer buffer
- (write-file file)))
-
-
-;;; Debug
-
-(ediff-defvar-local ediff-command-begin-time '(0 0 0) "")
-
-;; calculate time used by command
-(defun ediff-calc-command-time ()
- (let ((end (current-time))
- micro sec)
- (setq micro
- (if (>= (nth 2 end) (nth 2 ediff-command-begin-time))
- (- (nth 2 end) (nth 2 ediff-command-begin-time))
- (+ (nth 2 end) (- 1000000 (nth 2 ediff-command-begin-time)))))
- (setq sec (- (nth 1 end) (nth 1 ediff-command-begin-time)))
- (or (equal ediff-command-begin-time '(0 0 0))
- (message "Elapsed time: %d second(s) + %d microsecond(s)" sec micro))))
-
-(defsubst ediff-save-time ()
- (setq ediff-command-begin-time (current-time)))
-
-(defun ediff-profile ()
- "Toggle profiling Ediff commands."
- (interactive)
- (ediff-barf-if-not-control-buffer)
-
- (if (featurep 'xemacs)
- (make-local-hook 'post-command-hook))
-
- (let ((pre-hook 'pre-command-hook)
- (post-hook 'post-command-hook))
- (if (not (equal ediff-command-begin-time '(0 0 0)))
- (progn (remove-hook pre-hook 'ediff-save-time)
- (remove-hook post-hook 'ediff-calc-command-time)
- (setq ediff-command-begin-time '(0 0 0))
- (message "Ediff profiling disabled"))
- (add-hook pre-hook 'ediff-save-time t 'local)
- (add-hook post-hook 'ediff-calc-command-time nil 'local)
- (message "Ediff profiling enabled"))))
-
-(defun ediff-print-diff-vector (diff-vector-var)
- (princ (format "\n*** %S ***\n" diff-vector-var))
- (mapcar (lambda (overl-vec)
- (princ
- (format
- "Diff %d: \tOverlay: %S
-\t\tFine diffs: %s
-\t\tNo-fine-diff-flag: %S
-\t\tState-of-diff:\t %S
-\t\tState-of-merge:\t %S
-"
- (1+ (ediff-overlay-get (aref overl-vec 0) 'ediff-diff-num))
- (aref overl-vec 0)
- ;; fine-diff-vector
- (if (= (length (aref overl-vec 1)) 0)
- "none\n"
- (mapconcat 'prin1-to-string
- (aref overl-vec 1) "\n\t\t\t "))
- (aref overl-vec 2) ; no fine diff flag
- (aref overl-vec 3) ; state-of-diff
- (aref overl-vec 4) ; state-of-merge
- )))
- (eval diff-vector-var)))
-
-
-
-(defun ediff-debug-info ()
- (interactive)
- (ediff-barf-if-not-control-buffer)
- (with-output-to-temp-buffer ediff-debug-buffer
- (ediff-with-current-buffer standard-output
- (fundamental-mode))
- (princ (format "\nCtl buffer: %S\n" ediff-control-buffer))
- (ediff-print-diff-vector (intern "ediff-difference-vector-A"))
- (ediff-print-diff-vector (intern "ediff-difference-vector-B"))
- (ediff-print-diff-vector (intern "ediff-difference-vector-C"))
- (ediff-print-diff-vector (intern "ediff-difference-vector-Ancestor"))
- ))
-
-
-;;; General utilities
-
-;; this uses comparison-func to decide who is a member
-(defun ediff-member (elt lis comparison-func)
- (while (and lis (not (funcall comparison-func (car lis) elt)))
- (setq lis (cdr lis)))
- lis)
-
-;; Make a readable representation of the invocation sequence for FUNC-DEF.
-;; It would either be a key or M-x something.
-(defun ediff-format-bindings-of (func-def)
- (let ((desc (car (where-is-internal func-def
- overriding-local-map
- nil nil))))
- (if desc
- (key-description desc)
- (format "M-x %s" func-def))))
-
-;; this uses comparison-func to decide who is a member, and this determines how
-;; intersection looks like
-(defun ediff-intersection (lis1 lis2 comparison-func)
- (let ((result (list 'a)))
- (while lis1
- (if (ediff-member (car lis1) lis2 comparison-func)
- (nconc result (list (car lis1))))
- (setq lis1 (cdr lis1)))
- (cdr result)))
-
-
-;; eliminates duplicates using comparison-func
-(defun ediff-union (lis1 lis2 comparison-func)
- (let ((result (list 'a)))
- (while lis1
- (or (ediff-member (car lis1) (cdr result) comparison-func)
- (nconc result (list (car lis1))))
- (setq lis1 (cdr lis1)))
- (while lis2
- (or (ediff-member (car lis2) (cdr result) comparison-func)
- (nconc result (list (car lis2))))
- (setq lis2 (cdr lis2)))
- (cdr result)))
-
-;; eliminates duplicates using comparison-func
-(defun ediff-set-difference (lis1 lis2 comparison-func)
- (let ((result (list 'a)))
- (while lis1
- (or (ediff-member (car lis1) (cdr result) comparison-func)
- (ediff-member (car lis1) lis2 comparison-func)
- (nconc result (list (car lis1))))
- (setq lis1 (cdr lis1)))
- (cdr result)))
-
-(defun ediff-add-to-history (history-var newelt)
- (if (fboundp 'add-to-history)
- (add-to-history history-var newelt)
- (set history-var (cons newelt (symbol-value history-var)))))
-
-(defalias 'ediff-copy-list 'copy-sequence)
-
-
-;; don't report error if version control package wasn't found
-;;(ediff-load-version-control 'silent)
-
-(run-hooks 'ediff-load-hook)
-
-
-;; Local Variables:
-;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
-;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
-;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
-;; End:
-
-;; arch-tag: f51099b6-ef4b-470f-88a1-3a0e0b03a879
-;;; ediff-util.el ends here
+++ /dev/null
-;;; ediff-vers.el --- version control interface to Ediff
-
-;; Copyright (C) 1995, 1996, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-;; Compiler pacifier
-(defvar rcs-default-co-switches)
-
-(and noninteractive
- (eval-when-compile
- (condition-case nil
- ;; for compatibility with current stable version of xemacs
- (progn
- ;;(require 'pcvs nil 'noerror)
- ;;(require 'rcs nil 'noerror)
- (require 'pcvs)
- (require 'rcs))
- (error nil))
- (require 'vc)
- (require 'ediff-init)
- ))
-;; end pacifier
-
-(defcustom ediff-keep-tmp-versions nil
- "If t, do not delete temporary previous versions for the files on which
-comparison or merge operations are being performed."
- :type 'boolean
- :group 'ediff-vers
- )
-
-(defalias 'ediff-vc-revision-other-window
- (if (fboundp 'vc-revision-other-window)
- 'vc-revision-other-window
- 'vc-version-other-window))
-
-(defalias 'ediff-vc-working-revision
- (if (fboundp 'vc-working-revision)
- 'vc-working-revision
- 'vc-workfile-version))
-
-;; VC.el support
-
-(eval-when-compile
- (require 'vc-hooks)) ;; for vc-call macro
-
-
-(defun ediff-vc-latest-version (file)
- "Return the version level of the latest version of FILE in repository."
- (if (fboundp 'vc-latest-version)
- (vc-latest-version file)
- (or (vc-file-getprop file 'vc-latest-revision)
- (cond ((vc-backend file)
- (vc-call state file)
- (vc-file-getprop file 'vc-latest-revision))
- (t (error "File %s is not under version control" file))))
- ))
-
-
-(defun ediff-vc-internal (rev1 rev2 &optional startup-hooks)
- ;; Run Ediff on versions of the current buffer.
- ;; If REV1 is "", use the latest version of the current buffer's file.
- ;; If REV2 is "" then compare current buffer with REV1.
- ;; If the current buffer is named `F', the version is named `F.~REV~'.
- ;; If `F.~REV~' already exists, it is used instead of being re-created.
- (let (file1 file2 rev1buf rev2buf)
- (if (string= rev1 "")
- (setq rev1 (ediff-vc-latest-version (buffer-file-name))))
- (save-window-excursion
- (save-excursion
- (ediff-vc-revision-other-window rev1)
- (setq rev1buf (current-buffer)
- file1 (buffer-file-name)))
- (save-excursion
- (or (string= rev2 "") ; use current buffer
- (ediff-vc-revision-other-window rev2))
- (setq rev2buf (current-buffer)
- file2 (buffer-file-name)))
- (setq startup-hooks
- (cons `(lambda ()
- (ediff-delete-version-file ,file1)
- (or ,(string= rev2 "") (ediff-delete-version-file ,file2)))
- startup-hooks)))
- (ediff-buffers
- rev1buf rev2buf
- startup-hooks
- 'ediff-revision)))
-
-;; RCS.el support
-(defun rcs-ediff-view-revision (&optional rev)
-;; View previous RCS revision of current file.
-;; With prefix argument, prompts for a revision name.
- (interactive (list (if current-prefix-arg
- (read-string "Revision: "))))
- (let* ((filename (buffer-file-name (current-buffer)))
- (switches (append '("-p")
- (if rev (list (concat "-r" rev)) nil)))
- (buff (concat (file-name-nondirectory filename) ".~" rev "~")))
- (message "Working ...")
- (setq filename (expand-file-name filename))
- (with-output-to-temp-buffer buff
- (ediff-with-current-buffer standard-output
- (fundamental-mode))
- (let ((output-buffer (ediff-rcs-get-output-buffer filename buff)))
- (delete-windows-on output-buffer)
- (with-current-buffer output-buffer
- (apply 'call-process "co" nil t nil
- ;; -q: quiet (no diagnostics)
- (append switches rcs-default-co-switches
- (list "-q" filename)))))
- (message "")
- buff)))
-
-(defun ediff-rcs-get-output-buffer (file name)
- ;; Get a buffer for RCS output for FILE, make it writable and clean it up.
- ;; Optional NAME is name to use instead of `*RCS-output*'.
- ;; This is a modified version from rcs.el v1.1. I use it here to make
- ;; Ediff immune to changes in rcs.el
- (let ((buf (get-buffer-create name)))
- (with-current-buffer buf
- (setq buffer-read-only nil
- default-directory (file-name-directory (expand-file-name file)))
- (erase-buffer))
- buf))
-
-(defun ediff-rcs-internal (rev1 rev2 &optional startup-hooks)
-;; Run Ediff on versions of the current buffer.
-;; If REV2 is "" then use current buffer.
- (let (rev2buf rev1buf)
- (save-window-excursion
- (setq rev2buf (if (string= rev2 "")
- (current-buffer)
- (rcs-ediff-view-revision rev2))
- rev1buf (rcs-ediff-view-revision rev1)))
-
- ;; rcs.el doesn't create temp version files, so we don't have to delete
- ;; anything in startup hooks to ediff-buffers
- (ediff-buffers rev1buf rev2buf startup-hooks 'ediff-revision)
- ))
-
-;;; Merge with Version Control
-
-(defun ediff-vc-merge-internal (rev1 rev2 ancestor-rev
- &optional startup-hooks merge-buffer-file)
-;; If ANCESTOR-REV non-nil, merge with ancestor
- (let (buf1 buf2 ancestor-buf)
- (save-window-excursion
- (save-excursion
- (ediff-vc-revision-other-window rev1)
- (setq buf1 (current-buffer)))
- (save-excursion
- (or (string= rev2 "")
- (ediff-vc-revision-other-window rev2))
- (setq buf2 (current-buffer)))
- (if ancestor-rev
- (save-excursion
- (if (string= ancestor-rev "")
- (setq ancestor-rev (ediff-vc-working-revision buffer-file-name)))
- (ediff-vc-revision-other-window ancestor-rev)
- (setq ancestor-buf (current-buffer))))
- (setq startup-hooks
- (cons
- `(lambda ()
- (ediff-delete-version-file ,(buffer-file-name buf1))
- (or ,(string= rev2 "")
- (ediff-delete-version-file ,(buffer-file-name buf2)))
- (or ,(string= ancestor-rev "")
- ,(not ancestor-rev)
- (ediff-delete-version-file ,(buffer-file-name ancestor-buf)))
- )
- startup-hooks)))
- (if ancestor-rev
- (ediff-merge-buffers-with-ancestor
- buf1 buf2 ancestor-buf
- startup-hooks 'ediff-merge-revisions-with-ancestor merge-buffer-file)
- (ediff-merge-buffers
- buf1 buf2 startup-hooks 'ediff-merge-revisions merge-buffer-file))
- ))
-
-(defun ediff-rcs-merge-internal (rev1 rev2 ancestor-rev
- &optional
- startup-hooks merge-buffer-file)
- ;; If ANCESTOR-REV non-nil, merge with ancestor
- (let (buf1 buf2 ancestor-buf)
- (save-window-excursion
- (setq buf1 (rcs-ediff-view-revision rev1)
- buf2 (if (string= rev2 "")
- (current-buffer)
- (rcs-ediff-view-revision rev2))
- ancestor-buf (if ancestor-rev
- (if (string= ancestor-rev "")
- (current-buffer)
- (rcs-ediff-view-revision ancestor-rev)))))
- ;; rcs.el doesn't create temp version files, so we don't have to delete
- ;; anything in startup hooks to ediff-buffers
- (if ancestor-rev
- (ediff-merge-buffers-with-ancestor
- buf1 buf2 ancestor-buf
- startup-hooks 'ediff-merge-revisions-with-ancestor merge-buffer-file)
- (ediff-merge-buffers
- buf1 buf2 startup-hooks 'ediff-merge-revisions merge-buffer-file))))
-
-
-;; delete version file on exit unless ediff-keep-tmp-versions is true
-(defun ediff-delete-version-file (file)
- (or ediff-keep-tmp-versions (delete-file file)))
-
-
-(provide 'ediff-vers)
-
-
-;; Local Variables:
-;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
-;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
-;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
-;; End:
-
-;; arch-tag: bbb34f0c-2a90-426a-a77a-c75f479ebbbf
-;;; ediff-vers.el ends here
+++ /dev/null
-;;; ediff-wind.el --- window manipulation utilities
-
-;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-
-;; Compiler pacifier
-(defvar icon-title-format)
-(defvar top-toolbar-height)
-(defvar bottom-toolbar-height)
-(defvar left-toolbar-height)
-(defvar right-toolbar-height)
-(defvar left-toolbar-width)
-(defvar right-toolbar-width)
-(defvar default-menubar)
-(defvar top-gutter)
-(defvar frame-icon-title-format)
-(defvar ediff-diff-status)
-
-;; declare-function does not exist in XEmacs
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
-
-(eval-when-compile
- (require 'ediff-util)
- (require 'ediff-help))
-;; end pacifier
-
-(require 'ediff-init)
-
-;; be careful with ediff-tbar
-(if (featurep 'xemacs)
- (require 'ediff-tbar)
- (defun ediff-compute-toolbar-width () 0))
-
-(defgroup ediff-window nil
- "Ediff window manipulation."
- :prefix "ediff-"
- :group 'ediff
- :group 'frames)
-
-
-;; Determine which window setup function to use based on current window system.
-(defun ediff-choose-window-setup-function-automatically ()
- (if (ediff-window-display-p)
- 'ediff-setup-windows-multiframe
- 'ediff-setup-windows-plain))
-
-(defcustom ediff-window-setup-function (ediff-choose-window-setup-function-automatically)
- "Function called to set up windows.
-Ediff provides a choice of two functions: `ediff-setup-windows-plain', for
-doing everything in one frame and `ediff-setup-windows-multiframe', which sets
-the control panel in a separate frame. By default, the appropriate function is
-chosen automatically depending on the current window system.
-However, `ediff-toggle-multiframe' can be used to toggle between the multiframe
-display and the single frame display.
-If the multiframe function detects that one of the buffers A/B is seen in some
-other frame, it will try to keep that buffer in that frame.
-
-If you don't like any of the two provided functions, write your own one.
-The basic guidelines:
- 1. It should leave the control buffer current and the control window
- selected.
- 2. It should set `ediff-window-A', `ediff-window-B', `ediff-window-C',
- and `ediff-control-window' to contain window objects that display
- the corresponding buffers.
- 3. It should accept the following arguments:
- buffer-A, buffer-B, buffer-C, control-buffer
- Buffer C may not be used in jobs that compare only two buffers.
-If you plan to do something fancy, take a close look at how the two
-provided functions are written."
- :type '(choice (const :tag "Multi Frame" ediff-setup-windows-multiframe)
- (const :tag "Single Frame" ediff-setup-windows-plain)
- (function :tag "Other function"))
- :group 'ediff-window)
-
-;; indicates if we are in a multiframe setup
-(ediff-defvar-local ediff-multiframe nil "")
-
-;; Share of the frame occupied by the merge window (buffer C)
-(ediff-defvar-local ediff-merge-window-share 0.45 "")
-
-;; The control window.
-(ediff-defvar-local ediff-control-window nil "")
-;; Official window for buffer A
-(ediff-defvar-local ediff-window-A nil "")
-;; Official window for buffer B
-(ediff-defvar-local ediff-window-B nil "")
-;; Official window for buffer C
-(ediff-defvar-local ediff-window-C nil "")
-;; Ediff's window configuration.
-;; Used to minimize the need to rearrange windows.
-(ediff-defvar-local ediff-window-config-saved "" "")
-
-;; Association between buff-type and ediff-window-*
-(defconst ediff-window-alist
- '((A . ediff-window-A)
- (?A . ediff-window-A)
- (B . ediff-window-B)
- (?B . ediff-window-B)
- (C . ediff-window-C)
- (?C . ediff-window-C)))
-
-
-(defcustom ediff-split-window-function 'split-window-vertically
- "The function used to split the main window between buffer-A and buffer-B.
-You can set it to a horizontal split instead of the default vertical split
-by setting this variable to `split-window-horizontally'.
-You can also have your own function to do fancy splits.
-This variable has no effect when buffer-A/B are shown in different frames.
-In this case, Ediff will use those frames to display these buffers."
- :type '(choice
- (const :tag "Split vertically" split-window-vertically)
- (const :tag "Split horizontally" split-window-horizontally)
- function)
- :group 'ediff-window)
-
-(defcustom ediff-merge-split-window-function 'split-window-horizontally
- "The function used to split the main window between buffer-A and buffer-B.
-You can set it to a vertical split instead of the default horizontal split
-by setting this variable to `split-window-vertically'.
-You can also have your own function to do fancy splits.
-This variable has no effect when buffer-A/B/C are shown in different frames.
-In this case, Ediff will use those frames to display these buffers."
- :type '(choice
- (const :tag "Split vertically" split-window-vertically)
- (const :tag "Split horizontally" split-window-horizontally)
- function)
- :group 'ediff-window)
-
-;; Definitions hidden from the compiler by compat wrappers.
-(declare-function ediff-display-pixel-width "ediff-init")
-(declare-function ediff-display-pixel-height "ediff-init")
-
-(defconst ediff-control-frame-parameters
- (list
- '(name . "Ediff")
- ;;'(unsplittable . t)
- '(minibuffer . nil)
- '(user-position . t) ; Emacs only
- '(vertical-scroll-bars . nil) ; Emacs only
- '(scrollbar-width . 0) ; XEmacs only
- '(scrollbar-height . 0) ; XEmacs only
- '(menu-bar-lines . 0) ; Emacs only
- '(tool-bar-lines . 0) ; Emacs 21+ only
- '(left-fringe . 0)
- '(right-fringe . 0)
- ;; don't lower but auto-raise
- '(auto-lower . nil)
- '(auto-raise . t)
- '(visibility . nil)
- ;; make initial frame small to avoid distraction
- '(width . 1) '(height . 1)
- ;; this blocks queries from window manager as to where to put
- ;; ediff's control frame. we put the frame outside the display,
- ;; so the initial frame won't jump all over the screen
- (cons 'top (if (fboundp 'ediff-display-pixel-height)
- (1+ (ediff-display-pixel-height))
- 3000))
- (cons 'left (if (fboundp 'ediff-display-pixel-width)
- (1+ (ediff-display-pixel-width))
- 3000))
- )
- "Frame parameters for displaying Ediff Control Panel.
-Used internally---not a user option.")
-
-;; position of the mouse; used to decide whether to warp the mouse into ctl
-;; frame
-(ediff-defvar-local ediff-mouse-pixel-position nil "")
-
-;; not used for now
-(defvar ediff-mouse-pixel-threshold 30
- "If the user moves mouse more than this many pixels, Ediff won't warp mouse into control window.")
-
-(defcustom ediff-grab-mouse t
- "If t, Ediff will always grab the mouse and put it in the control frame.
-If 'maybe, Ediff will do it sometimes, but not after operations that require
-relatively long time. If nil, the mouse will be entirely user's
-responsibility."
- :type 'boolean
- :group 'ediff-window)
-
-(defcustom ediff-control-frame-position-function 'ediff-make-frame-position
- "Function to call to determine the desired location for the control panel.
-Expects three parameters: the control buffer, the desired width and height
-of the control frame. It returns an association list
-of the form \(\(top . <position>\) \(left . <position>\)\)"
- :type 'function
- :group 'ediff-window)
-
-(defcustom ediff-control-frame-upward-shift 42
- "The upward shift of control frame from the top of buffer A's frame.
-Measured in pixels.
-This is used by the default control frame positioning function,
-`ediff-make-frame-position'. This variable is provided for easy
-customization of the default control frame positioning."
- :type 'integer
- :group 'ediff-window)
-
-(defcustom ediff-narrow-control-frame-leftward-shift (if (featurep 'xemacs) 7 3)
- "The leftward shift of control frame from the right edge of buf A's frame.
-Measured in characters.
-This is used by the default control frame positioning function,
-`ediff-make-frame-position' to adjust the position of the control frame
-when it shows the short menu. This variable is provided for easy
-customization of the default."
- :type 'integer
- :group 'ediff-window)
-
-(defcustom ediff-wide-control-frame-rightward-shift 7
- "The rightward shift of control frame from the left edge of buf A's frame.
-Measured in characters.
-This is used by the default control frame positioning function,
-`ediff-make-frame-position' to adjust the position of the control frame
-when it shows the full menu. This variable is provided for easy
-customization of the default."
- :type 'integer
- :group 'ediff-window)
-
-
-;; Wide frame display
-
-;; t means Ediff is using wide display
-(ediff-defvar-local ediff-wide-display-p nil "")
-;; keeps frame config for toggling wide display
-(ediff-defvar-local ediff-wide-display-orig-parameters nil
- "Frame parameters to be restored when the user wants to toggle the wide
-display off.")
-(ediff-defvar-local ediff-wide-display-frame nil
- "Frame to be used for wide display.")
-(ediff-defvar-local ediff-make-wide-display-function 'ediff-make-wide-display
- "The value is a function that is called to create a wide display.
-The function is called without arguments. It should resize the frame in
-which buffers A, B, and C are to be displayed, and it should save the old
-frame parameters in `ediff-wide-display-orig-parameters'.
-The variable `ediff-wide-display-frame' should be set to contain
-the frame used for the wide display.")
-
-;; Frame used for the control panel in a windowing system.
-(ediff-defvar-local ediff-control-frame nil "")
-
-(defcustom ediff-prefer-iconified-control-frame nil
- "If t, keep control panel iconified when help message is off.
-This has effect only on a windowing system.
-If t, hitting `?' to toggle control panel off iconifies it.
-
-This is only useful in Emacs and only for certain kinds of window managers,
-such as TWM and its derivatives, since the window manager must permit
-keyboard input to go into icons. XEmacs completely ignores keyboard input
-into icons, regardless of the window manager."
- :type 'boolean
- :group 'ediff-window)
-
-;;; Functions
-
-(defun ediff-get-window-by-clicking (wind prev-wind wind-number)
- (let (event)
- (message
- "Select windows by clicking. Please click on Window %d " wind-number)
- (while (not (ediff-mouse-event-p (setq event (ediff-read-event))))
- (if (sit-for 1) ; if sequence of events, wait till the final word
- (beep 1))
- (message "Please click on Window %d " wind-number))
- (ediff-read-event) ; discard event
- (setq wind (if (featurep 'xemacs)
- (event-window event)
- (posn-window (event-start event))))))
-
-
-;; Select the lowest window on the frame.
-(defun ediff-select-lowest-window ()
- (if (featurep 'xemacs)
- (select-window (frame-lowest-window))
- (let* ((lowest-window (selected-window))
- (bottom-edge (car (cdr (cdr (cdr (window-edges))))))
- (last-window (save-excursion
- (other-window -1) (selected-window)))
- (window-search t))
- (while window-search
- (let* ((this-window (next-window))
- (next-bottom-edge
- (car (cdr (cdr (cdr (window-edges this-window)))))))
- (if (< bottom-edge next-bottom-edge)
- (setq bottom-edge next-bottom-edge
- lowest-window this-window))
- (select-window this-window)
- (when (eq last-window this-window)
- (select-window lowest-window)
- (setq window-search nil)))))))
-
-
-;;; Common window setup routines
-
-;; Set up the window configuration. If POS is given, set the points to
-;; the beginnings of the buffers.
-;; When 3way comparison is added, this will have to choose the appropriate
-;; setup function based on ediff-job-name
-(defun ediff-setup-windows (buffer-A buffer-B buffer-C control-buffer)
- ;; Make sure we are not in the minibuffer window when we try to delete
- ;; all other windows.
- (run-hooks 'ediff-before-setup-windows-hook)
- (if (eq (selected-window) (minibuffer-window))
- (other-window 1))
-
- ;; in case user did a no-no on a tty
- (or (ediff-window-display-p)
- (setq ediff-window-setup-function 'ediff-setup-windows-plain))
-
- (or (ediff-keep-window-config control-buffer)
- (funcall
- (ediff-with-current-buffer control-buffer ediff-window-setup-function)
- buffer-A buffer-B buffer-C control-buffer))
- (run-hooks 'ediff-after-setup-windows-hook))
-
-;; Just set up 3 windows.
-;; Usually used without windowing systems
-;; With windowing, we want to use dedicated frames.
-(defun ediff-setup-windows-plain (buffer-A buffer-B buffer-C control-buffer)
- (ediff-with-current-buffer control-buffer
- (setq ediff-multiframe nil))
- (if ediff-merge-job
- (ediff-setup-windows-plain-merge
- buffer-A buffer-B buffer-C control-buffer)
- (ediff-setup-windows-plain-compare
- buffer-A buffer-B buffer-C control-buffer)))
-
-(defun ediff-setup-windows-plain-merge (buf-A buf-B buf-C control-buffer)
- ;; skip dedicated and unsplittable frames
- (ediff-destroy-control-frame control-buffer)
- (let ((window-min-height 1)
- split-window-function
- merge-window-share merge-window-lines
- wind-A wind-B wind-C)
- (ediff-with-current-buffer control-buffer
- (setq merge-window-share ediff-merge-window-share
- ;; this lets us have local versions of ediff-split-window-function
- split-window-function ediff-split-window-function))
- (delete-other-windows)
- (set-window-dedicated-p (selected-window) nil)
- (split-window-vertically)
- (ediff-select-lowest-window)
- (ediff-setup-control-buffer control-buffer)
-
- ;; go to the upper window and split it betw A, B, and possibly C
- (other-window 1)
- (setq merge-window-lines
- (max 2 (round (* (window-height) merge-window-share))))
- (switch-to-buffer buf-A)
- (setq wind-A (selected-window))
-
- ;; XEmacs used to have a lot of trouble with display
- ;; It did't set things right unless we tell it to sit still
- ;; 19.12 seems ok.
- ;;(if (featurep 'xemacs) (sit-for 0))
-
- (split-window-vertically (max 2 (- (window-height) merge-window-lines)))
- (if (eq (selected-window) wind-A)
- (other-window 1))
- (setq wind-C (selected-window))
- (switch-to-buffer buf-C)
-
- (select-window wind-A)
- (funcall split-window-function)
-
- (if (eq (selected-window) wind-A)
- (other-window 1))
- (switch-to-buffer buf-B)
- (setq wind-B (selected-window))
-
- (ediff-with-current-buffer control-buffer
- (setq ediff-window-A wind-A
- ediff-window-B wind-B
- ediff-window-C wind-C))
-
- (ediff-select-lowest-window)
- (ediff-setup-control-buffer control-buffer)
- ))
-
-
-;; This function handles all comparison jobs, including 3way jobs
-(defun ediff-setup-windows-plain-compare (buf-A buf-B buf-C control-buffer)
- ;; skip dedicated and unsplittable frames
- (ediff-destroy-control-frame control-buffer)
- (let ((window-min-height 1)
- split-window-function wind-width-or-height
- three-way-comparison
- wind-A-start wind-B-start wind-A wind-B wind-C)
- (ediff-with-current-buffer control-buffer
- (setq wind-A-start (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type
- 'A ediff-narrow-bounds))
- wind-B-start (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type
- 'B ediff-narrow-bounds))
- ;; this lets us have local versions of ediff-split-window-function
- split-window-function ediff-split-window-function
- three-way-comparison ediff-3way-comparison-job))
- ;; if in minibuffer go somewhere else
- (if (save-match-data
- (string-match "\*Minibuf-" (buffer-name (window-buffer))))
- (select-window (next-window nil 'ignore-minibuf)))
- (delete-other-windows)
- (set-window-dedicated-p (selected-window) nil)
- (split-window-vertically)
- (ediff-select-lowest-window)
- (ediff-setup-control-buffer control-buffer)
-
- ;; go to the upper window and split it betw A, B, and possibly C
- (other-window 1)
- (switch-to-buffer buf-A)
- (setq wind-A (selected-window))
- (if three-way-comparison
- (setq wind-width-or-height
- (/ (if (eq split-window-function 'split-window-vertically)
- (window-height wind-A)
- (window-width wind-A))
- 3)))
-
- ;; XEmacs used to have a lot of trouble with display
- ;; It did't set things right unless we told it to sit still
- ;; 19.12 seems ok.
- ;;(if (featurep 'xemacs) (sit-for 0))
-
- (funcall split-window-function wind-width-or-height)
-
- (if (eq (selected-window) wind-A)
- (other-window 1))
- (switch-to-buffer buf-B)
- (setq wind-B (selected-window))
-
- (if three-way-comparison
- (progn
- (funcall split-window-function) ; equally
- (if (eq (selected-window) wind-B)
- (other-window 1))
- (switch-to-buffer buf-C)
- (setq wind-C (selected-window))))
-
- (ediff-with-current-buffer control-buffer
- (setq ediff-window-A wind-A
- ediff-window-B wind-B
- ediff-window-C wind-C))
-
- ;; It is unlikely that we will want to implement 3way window comparison.
- ;; So, only buffers A and B are used here.
- (if ediff-windows-job
- (progn
- (set-window-start wind-A wind-A-start)
- (set-window-start wind-B wind-B-start)))
-
- (ediff-select-lowest-window)
- (ediff-setup-control-buffer control-buffer)
- ))
-
-
-;; dispatch an appropriate window setup function
-(defun ediff-setup-windows-multiframe (buf-A buf-B buf-C control-buf)
- (ediff-with-current-buffer control-buf
- (setq ediff-multiframe t))
- (if ediff-merge-job
- (ediff-setup-windows-multiframe-merge buf-A buf-B buf-C control-buf)
- (ediff-setup-windows-multiframe-compare buf-A buf-B buf-C control-buf)))
-
-(defun ediff-setup-windows-multiframe-merge (buf-A buf-B buf-C control-buf)
-;;; Algorithm:
-;;; 1. Never use frames that have dedicated windows in them---it is bad to
-;;; destroy dedicated windows.
-;;; 2. If A and B are in the same frame but C's frame is different--- use one
-;;; frame for A and B and use a separate frame for C.
-;;; 3. If C's frame is non-existent, then: if the first suitable
-;;; non-dedicated frame is different from A&B's, then use it for C.
-;;; Otherwise, put A,B, and C in one frame.
-;;; 4. If buffers A, B, C are is separate frames, use them to display these
-;;; buffers.
-
- ;; Skip dedicated or iconified frames.
- ;; Unsplittable frames are taken care of later.
- (ediff-skip-unsuitable-frames 'ok-unsplittable)
-
- (let* ((window-min-height 1)
- (wind-A (ediff-get-visible-buffer-window buf-A))
- (wind-B (ediff-get-visible-buffer-window buf-B))
- (wind-C (ediff-get-visible-buffer-window buf-C))
- (frame-A (if wind-A (window-frame wind-A)))
- (frame-B (if wind-B (window-frame wind-B)))
- (frame-C (if wind-C (window-frame wind-C)))
- ;; on wide display, do things in one frame
- (force-one-frame
- (ediff-with-current-buffer control-buf ediff-wide-display-p))
- ;; this lets us have local versions of ediff-split-window-function
- (split-window-function
- (ediff-with-current-buffer control-buf ediff-split-window-function))
- (orig-wind (selected-window))
- (orig-frame (selected-frame))
- (use-same-frame (or force-one-frame
- ;; A and C must be in one frame
- (eq frame-A (or frame-C orig-frame))
- ;; B and C must be in one frame
- (eq frame-B (or frame-C orig-frame))
- ;; A or B is not visible
- (not (frame-live-p frame-A))
- (not (frame-live-p frame-B))
- ;; A or B is not suitable for display
- (not (ediff-window-ok-for-display wind-A))
- (not (ediff-window-ok-for-display wind-B))
- ;; A and B in the same frame, and no good frame
- ;; for C
- (and (eq frame-A frame-B)
- (not (frame-live-p frame-C)))
- ))
- ;; use-same-frame-for-AB implies wind A and B are ok for display
- (use-same-frame-for-AB (and (not use-same-frame)
- (eq frame-A frame-B)))
- (merge-window-share (ediff-with-current-buffer control-buf
- ediff-merge-window-share))
- merge-window-lines
- designated-minibuffer-frame
- done-A done-B done-C)
-
- ;; buf-A on its own
- (if (and (window-live-p wind-A)
- (null use-same-frame) ; implies wind-A is suitable
- (null use-same-frame-for-AB))
- (progn ; bug A on its own
- ;; buffer buf-A is seen in live wind-A
- (select-window wind-A)
- (delete-other-windows)
- (setq wind-A (selected-window))
- (setq done-A t)))
-
- ;; buf-B on its own
- (if (and (window-live-p wind-B)
- (null use-same-frame) ; implies wind-B is suitable
- (null use-same-frame-for-AB))
- (progn ; buf B on its own
- ;; buffer buf-B is seen in live wind-B
- (select-window wind-B)
- (delete-other-windows)
- (setq wind-B (selected-window))
- (setq done-B t)))
-
- ;; buf-C on its own
- (if (and (window-live-p wind-C)
- (ediff-window-ok-for-display wind-C)
- (null use-same-frame)) ; buf C on its own
- (progn
- ;; buffer buf-C is seen in live wind-C
- (select-window wind-C)
- (delete-other-windows)
- (setq wind-C (selected-window))
- (setq done-C t)))
-
- (if (and use-same-frame-for-AB ; implies wind A and B are suitable
- (window-live-p wind-A))
- (progn
- ;; wind-A must already be displaying buf-A
- (select-window wind-A)
- (delete-other-windows)
- (setq wind-A (selected-window))
-
- (funcall split-window-function)
- (if (eq (selected-window) wind-A)
- (other-window 1))
- (switch-to-buffer buf-B)
- (setq wind-B (selected-window))
-
- (setq done-A t
- done-B t)))
-
- (if use-same-frame
- (let ((window-min-height 1))
- (if (and (eq frame-A frame-B)
- (eq frame-B frame-C)
- (frame-live-p frame-A))
- (select-frame frame-A)
- ;; avoid dedicated and non-splittable windows
- (ediff-skip-unsuitable-frames))
- (delete-other-windows)
- (setq merge-window-lines
- (max 2 (round (* (window-height) merge-window-share))))
- (switch-to-buffer buf-A)
- (setq wind-A (selected-window))
-
- (split-window-vertically
- (max 2 (- (window-height) merge-window-lines)))
- (if (eq (selected-window) wind-A)
- (other-window 1))
- (setq wind-C (selected-window))
- (switch-to-buffer buf-C)
-
- (select-window wind-A)
-
- (funcall split-window-function)
- (if (eq (selected-window) wind-A)
- (other-window 1))
- (switch-to-buffer buf-B)
- (setq wind-B (selected-window))
-
- (setq done-A t
- done-B t
- done-C t)
- ))
-
- (or done-A ; Buf A to be set in its own frame,
- ;;; or it was set before because use-same-frame = 1
- (progn
- ;; Buf-A was not set up yet as it wasn't visible,
- ;; and use-same-frame = nil, use-same-frame-for-AB = nil
- (select-window orig-wind)
- (delete-other-windows)
- (switch-to-buffer buf-A)
- (setq wind-A (selected-window))
- ))
- (or done-B ; Buf B to be set in its own frame,
- ;;; or it was set before because use-same-frame = 1
- (progn
- ;; Buf-B was not set up yet as it wasn't visible
- ;; and use-same-frame = nil, use-same-frame-for-AB = nil
- (select-window orig-wind)
- (delete-other-windows)
- (switch-to-buffer buf-B)
- (setq wind-B (selected-window))
- ))
-
- (or done-C ; Buf C to be set in its own frame,
- ;;; or it was set before because use-same-frame = 1
- (progn
- ;; Buf-C was not set up yet as it wasn't visible
- ;; and use-same-frame = nil
- (select-window orig-wind)
- (delete-other-windows)
- (switch-to-buffer buf-C)
- (setq wind-C (selected-window))
- ))
-
- (ediff-with-current-buffer control-buf
- (setq ediff-window-A wind-A
- ediff-window-B wind-B
- ediff-window-C wind-C)
- (setq frame-A (window-frame ediff-window-A)
- designated-minibuffer-frame
- (window-frame (minibuffer-window frame-A))))
-
- (ediff-setup-control-frame control-buf designated-minibuffer-frame)
- ))
-
-
-;; Window setup for all comparison jobs, including 3way comparisons
-(defun ediff-setup-windows-multiframe-compare (buf-A buf-B buf-C control-buf)
-;;; Algorithm:
-;;; If a buffer is seen in a frame, use that frame for that buffer.
-;;; If it is not seen, use the current frame.
-;;; If both buffers are not seen, they share the current frame. If one
-;;; of the buffers is not seen, it is placed in the current frame (where
-;;; ediff started). If that frame is displaying the other buffer, it is
-;;; shared between the two buffers.
-;;; However, if we decide to put both buffers in one frame
-;;; and the selected frame isn't splittable, we create a new frame and
-;;; put both buffers there, event if one of this buffers is visible in
-;;; another frame.
-
- ;; Skip dedicated or iconified frames.
- ;; Unsplittable frames are taken care of later.
- (ediff-skip-unsuitable-frames 'ok-unsplittable)
-
- (let* ((window-min-height 1)
- (wind-A (ediff-get-visible-buffer-window buf-A))
- (wind-B (ediff-get-visible-buffer-window buf-B))
- (wind-C (ediff-get-visible-buffer-window buf-C))
- (frame-A (if wind-A (window-frame wind-A)))
- (frame-B (if wind-B (window-frame wind-B)))
- (frame-C (if wind-C (window-frame wind-C)))
- (ctl-frame-exists-p (ediff-with-current-buffer control-buf
- (frame-live-p ediff-control-frame)))
- ;; on wide display, do things in one frame
- (force-one-frame
- (ediff-with-current-buffer control-buf ediff-wide-display-p))
- ;; this lets us have local versions of ediff-split-window-function
- (split-window-function
- (ediff-with-current-buffer control-buf ediff-split-window-function))
- (three-way-comparison
- (ediff-with-current-buffer control-buf ediff-3way-comparison-job))
- (orig-wind (selected-window))
- (use-same-frame (or force-one-frame
- (eq frame-A frame-B)
- (not (ediff-window-ok-for-display wind-A))
- (not (ediff-window-ok-for-display wind-B))
- (if three-way-comparison
- (or (eq frame-A frame-C)
- (eq frame-B frame-C)
- (not (ediff-window-ok-for-display wind-C))
- (not (frame-live-p frame-A))
- (not (frame-live-p frame-B))
- (not (frame-live-p frame-C))))
- (and (not (frame-live-p frame-B))
- (or ctl-frame-exists-p
- (eq frame-A (selected-frame))))
- (and (not (frame-live-p frame-A))
- (or ctl-frame-exists-p
- (eq frame-B (selected-frame))))))
- wind-A-start wind-B-start
- designated-minibuffer-frame
- done-A done-B done-C)
-
- (ediff-with-current-buffer control-buf
- (setq wind-A-start (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type
- 'A ediff-narrow-bounds))
- wind-B-start (ediff-overlay-start
- (ediff-get-value-according-to-buffer-type
- 'B ediff-narrow-bounds))))
-
- (if (and (window-live-p wind-A) (null use-same-frame)) ; buf-A on its own
- (progn
- ;; buffer buf-A is seen in live wind-A
- (select-window wind-A) ; must be displaying buf-A
- (delete-other-windows)
- (setq wind-A (selected-window))
- (setq done-A t)))
-
- (if (and (window-live-p wind-B) (null use-same-frame)) ; buf B on its own
- (progn
- ;; buffer buf-B is seen in live wind-B
- (select-window wind-B) ; must be displaying buf-B
- (delete-other-windows)
- (setq wind-B (selected-window))
- (setq done-B t)))
-
- (if (and (window-live-p wind-C) (null use-same-frame)) ; buf C on its own
- (progn
- ;; buffer buf-C is seen in live wind-C
- (select-window wind-C) ; must be displaying buf-C
- (delete-other-windows)
- (setq wind-C (selected-window))
- (setq done-C t)))
-
- (if use-same-frame
- (let (wind-width-or-height) ; this affects 3way setups only
- (if (and (eq frame-A frame-B) (frame-live-p frame-A))
- (select-frame frame-A)
- ;; avoid dedicated and non-splittable windows
- (ediff-skip-unsuitable-frames))
- (delete-other-windows)
- (switch-to-buffer buf-A)
- (setq wind-A (selected-window))
-
- (if three-way-comparison
- (setq wind-width-or-height
- (/
- (if (eq split-window-function 'split-window-vertically)
- (window-height wind-A)
- (window-width wind-A))
- 3)))
-
- (funcall split-window-function wind-width-or-height)
- (if (eq (selected-window) wind-A)
- (other-window 1))
- (switch-to-buffer buf-B)
- (setq wind-B (selected-window))
-
- (if three-way-comparison
- (progn
- (funcall split-window-function) ; equally
- (if (memq (selected-window) (list wind-A wind-B))
- (other-window 1))
- (switch-to-buffer buf-C)
- (setq wind-C (selected-window))))
- (setq done-A t
- done-B t
- done-C t)
- ))
-
- (or done-A ; Buf A to be set in its own frame
- ;;; or it was set before because use-same-frame = 1
- (progn
- ;; Buf-A was not set up yet as it wasn't visible,
- ;; and use-same-frame = nil
- (select-window orig-wind)
- (delete-other-windows)
- (switch-to-buffer buf-A)
- (setq wind-A (selected-window))
- ))
- (or done-B ; Buf B to be set in its own frame
- ;;; or it was set before because use-same-frame = 1
- (progn
- ;; Buf-B was not set up yet as it wasn't visible,
- ;; and use-same-frame = nil
- (select-window orig-wind)
- (delete-other-windows)
- (switch-to-buffer buf-B)
- (setq wind-B (selected-window))
- ))
-
- (if three-way-comparison
- (or done-C ; Buf C to be set in its own frame
- ;;; or it was set before because use-same-frame = 1
- (progn
- ;; Buf-C was not set up yet as it wasn't visible,
- ;; and use-same-frame = nil
- (select-window orig-wind)
- (delete-other-windows)
- (switch-to-buffer buf-C)
- (setq wind-C (selected-window))
- )))
-
- (ediff-with-current-buffer control-buf
- (setq ediff-window-A wind-A
- ediff-window-B wind-B
- ediff-window-C wind-C)
-
- (setq frame-A (window-frame ediff-window-A)
- designated-minibuffer-frame
- (window-frame (minibuffer-window frame-A))))
-
- ;; It is unlikely that we'll implement a version of ediff-windows that
- ;; would compare 3 windows at once. So, we don't use buffer C here.
- (if ediff-windows-job
- (progn
- (set-window-start wind-A wind-A-start)
- (set-window-start wind-B wind-B-start)))
-
- (ediff-setup-control-frame control-buf designated-minibuffer-frame)
- ))
-
-;; skip unsplittable frames and frames that have dedicated windows.
-;; create a new splittable frame if none is found
-(defun ediff-skip-unsuitable-frames (&optional ok-unsplittable)
- (if (ediff-window-display-p)
- (let ((wind-frame (window-frame (selected-window)))
- seen-windows)
- (while (and (not (memq (selected-window) seen-windows))
- (or
- (ediff-frame-has-dedicated-windows wind-frame)
- (ediff-frame-iconified-p wind-frame)
- ;; skip small windows
- (< (frame-height wind-frame)
- (* 3 window-min-height))
- (if ok-unsplittable
- nil
- (ediff-frame-unsplittable-p wind-frame))))
- ;; remember history
- (setq seen-windows (cons (selected-window) seen-windows))
- ;; try new window
- (other-window 1 t)
- (setq wind-frame (window-frame (selected-window)))
- )
- (if (memq (selected-window) seen-windows)
- ;; fed up, no appropriate frames
- (setq wind-frame (make-frame '((unsplittable)))))
-
- (select-frame wind-frame)
- )))
-
-(defun ediff-frame-has-dedicated-windows (frame)
- (let (ans)
- (walk-windows
- (lambda (wind) (if (window-dedicated-p wind)
- (setq ans t)))
- 'ignore-minibuffer
- frame)
- ans))
-
-;; window is ok, if it is only one window on the frame, not counting the
-;; minibuffer, or none of the frame's windows is dedicated.
-;; The idea is that it is bad to destroy dedicated windows while creating an
-;; ediff window setup
-(defun ediff-window-ok-for-display (wind)
- (and
- (window-live-p wind)
- (or
- ;; only one window
- (eq wind (next-window wind 'ignore-minibuffer (window-frame wind)))
- ;; none is dedicated (in multiframe setup)
- (not (ediff-frame-has-dedicated-windows (window-frame wind)))
- )))
-
-;; Prepare or refresh control frame
-(defun ediff-setup-control-frame (ctl-buffer designated-minibuffer-frame)
- (let ((window-min-height 1)
- ctl-frame-iconified-p dont-iconify-ctl-frame deiconify-ctl-frame
- ctl-frame old-ctl-frame lines
- ;; user-grabbed-mouse
- fheight fwidth adjusted-parameters)
-
- (ediff-with-current-buffer ctl-buffer
- (if (and (featurep 'xemacs) (featurep 'menubar))
- (set-buffer-menubar nil))
- ;;(setq user-grabbed-mouse (ediff-user-grabbed-mouse))
- (run-hooks 'ediff-before-setup-control-frame-hook))
-
- (setq old-ctl-frame (ediff-with-current-buffer ctl-buffer ediff-control-frame))
- (ediff-with-current-buffer ctl-buffer
- (setq ctl-frame (if (frame-live-p old-ctl-frame)
- old-ctl-frame
- (make-frame ediff-control-frame-parameters))
- ediff-control-frame ctl-frame)
- ;; protect against undefined face-attribute
- (condition-case nil
- (if (and (featurep 'emacs) (face-attribute 'mode-line :box))
- (set-face-attribute 'mode-line ctl-frame :box nil))
- (error)))
-
- (setq ctl-frame-iconified-p (ediff-frame-iconified-p ctl-frame))
- (select-frame ctl-frame)
- (if (window-dedicated-p (selected-window))
- ()
- (delete-other-windows)
- (switch-to-buffer ctl-buffer))
-
- ;; must be before ediff-setup-control-buffer
- ;; just a precaution--we should be in ctl-buffer already
- (ediff-with-current-buffer ctl-buffer
- (make-local-variable 'frame-title-format)
- (make-local-variable 'frame-icon-title-format) ; XEmacs
- (make-local-variable 'icon-title-format)) ; Emacs
-
- (ediff-setup-control-buffer ctl-buffer)
- (setq dont-iconify-ctl-frame
- (not (string= ediff-help-message ediff-brief-help-message)))
- (setq deiconify-ctl-frame
- (and (eq this-command 'ediff-toggle-help)
- dont-iconify-ctl-frame))
-
- ;; 1 more line for the modeline
- (setq lines (1+ (count-lines (point-min) (point-max)))
- fheight lines
- fwidth (max (+ (ediff-help-message-line-length) 2)
- (ediff-compute-toolbar-width))
- adjusted-parameters
- (list
- ;; possibly change surrogate minibuffer
- (cons 'minibuffer
- (minibuffer-window
- designated-minibuffer-frame))
- (cons 'width fwidth)
- (cons 'height fheight)
- (cons 'user-position t)
- ))
-
- ;; adjust autoraise
- (setq adjusted-parameters
- (cons (if ediff-use-long-help-message
- '(auto-raise . nil)
- '(auto-raise . t))
- adjusted-parameters))
-
- ;; In XEmacs, buffer menubar needs to be killed before frame parameters
- ;; are changed.
- (if (ediff-has-toolbar-support-p)
- (when (featurep 'xemacs)
- (if (ediff-has-gutter-support-p)
- (set-specifier top-gutter (list ctl-frame nil)))
- (sit-for 0)
- (set-specifier top-toolbar-height (list ctl-frame 0))
- ;;(set-specifier bottom-toolbar-height (list ctl-frame 0))
- (set-specifier left-toolbar-width (list ctl-frame 0))
- (set-specifier right-toolbar-width (list ctl-frame 0))))
-
- ;; Under OS/2 (emx) we have to call modify frame parameters twice, in order
- ;; to make sure that at least once we do it for non-iconified frame. If
- ;; appears that in the OS/2 port of Emacs, one can't modify frame
- ;; parameters of iconified frames. As a precaution, we do likewise for
- ;; windows-nt.
- (if (memq system-type '(emx windows-nt windows-95))
- (modify-frame-parameters ctl-frame adjusted-parameters))
-
- ;; make or zap toolbar (if not requested)
- (ediff-make-bottom-toolbar ctl-frame)
-
- (goto-char (point-min))
-
- (modify-frame-parameters ctl-frame adjusted-parameters)
- (make-frame-visible ctl-frame)
-
- ;; This works around a bug in 19.25 and earlier. There, if frame gets
- ;; iconified, the current buffer changes to that of the frame that
- ;; becomes exposed as a result of this iconification.
- ;; So, we make sure the current buffer doesn't change.
- (select-frame ctl-frame)
- (ediff-refresh-control-frame)
-
- (cond ((and ediff-prefer-iconified-control-frame
- (not ctl-frame-iconified-p) (not dont-iconify-ctl-frame))
- (iconify-frame ctl-frame))
- ((or deiconify-ctl-frame (not ctl-frame-iconified-p))
- (raise-frame ctl-frame)))
-
- (set-window-dedicated-p (selected-window) t)
-
- ;; Now move the frame. We must do it separately due to an obscure bug in
- ;; XEmacs
- (modify-frame-parameters
- ctl-frame
- (funcall ediff-control-frame-position-function ctl-buffer fwidth fheight))
-
- ;; synchronize so the cursor will move to control frame
- ;; per RMS suggestion
- (if (ediff-window-display-p)
- (let ((count 7))
- (sit-for .1)
- (while (and (not (frame-visible-p ctl-frame)) (> count 0))
- (setq count (1- count))
- (sit-for .3))))
-
- (or (ediff-frame-iconified-p ctl-frame)
- ;; don't warp the mouse, unless ediff-grab-mouse = t
- (ediff-reset-mouse ctl-frame
- (or (eq this-command 'ediff-quit)
- (not (eq ediff-grab-mouse t)))))
-
- (when (featurep 'xemacs)
- (ediff-with-current-buffer ctl-buffer
- (make-local-hook 'select-frame-hook)
- (add-hook 'select-frame-hook
- 'ediff-xemacs-select-frame-hook nil 'local)))
-
- (ediff-with-current-buffer ctl-buffer
- (run-hooks 'ediff-after-setup-control-frame-hook))))
-
-
-(defun ediff-destroy-control-frame (ctl-buffer)
- (ediff-with-current-buffer ctl-buffer
- (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame))
- (let ((ctl-frame ediff-control-frame))
- (if (and (featurep 'xemacs) (featurep 'menubar))
- (set-buffer-menubar default-menubar))
- (setq ediff-control-frame nil)
- (delete-frame ctl-frame))))
- (if ediff-multiframe
- (ediff-skip-unsuitable-frames))
- ;;(ediff-reset-mouse nil)
- )
-
-
-;; finds a good place to clip control frame
-(defun ediff-make-frame-position (ctl-buffer ctl-frame-width ctl-frame-height)
- (ediff-with-current-buffer ctl-buffer
- (let* ((frame-A (window-frame ediff-window-A))
- (frame-A-parameters (frame-parameters frame-A))
- (frame-A-top (eval (cdr (assoc 'top frame-A-parameters))))
- (frame-A-left (eval (cdr (assoc 'left frame-A-parameters))))
- (frame-A-width (frame-width frame-A))
- (ctl-frame ediff-control-frame)
- horizontal-adjustment upward-adjustment
- ctl-frame-top ctl-frame-left)
-
- ;; Multiple control frames are clipped based on the value of
- ;; ediff-control-buffer-number. This is done in order not to obscure
- ;; other active control panels.
- (setq horizontal-adjustment (* 2 ediff-control-buffer-number)
- upward-adjustment (* -14 ediff-control-buffer-number))
-
- (setq ctl-frame-top
- (- frame-A-top upward-adjustment ediff-control-frame-upward-shift)
- ctl-frame-left
- (+ frame-A-left
- (if ediff-use-long-help-message
- (* (ediff-frame-char-width ctl-frame)
- (+ ediff-wide-control-frame-rightward-shift
- horizontal-adjustment))
- (- (* frame-A-width (ediff-frame-char-width frame-A))
- (* (ediff-frame-char-width ctl-frame)
- (+ ctl-frame-width
- ediff-narrow-control-frame-leftward-shift
- horizontal-adjustment))))))
- (setq ctl-frame-top
- (min ctl-frame-top
- (- (ediff-display-pixel-height)
- (* 2 ctl-frame-height
- (ediff-frame-char-height ctl-frame))))
- ctl-frame-left
- (min ctl-frame-left
- (- (ediff-display-pixel-width)
- (* ctl-frame-width (ediff-frame-char-width ctl-frame)))))
- ;; keep ctl frame within the visible bounds
- (setq ctl-frame-top (max ctl-frame-top 1)
- ctl-frame-left (max ctl-frame-left 1))
-
- (list (cons 'top ctl-frame-top)
- (cons 'left ctl-frame-left))
- )))
-
-(defun ediff-xemacs-select-frame-hook ()
- (if (and (equal (selected-frame) ediff-control-frame)
- (not ediff-use-long-help-message))
- (raise-frame ediff-control-frame)))
-
-(defun ediff-make-wide-display ()
- "Construct an alist of parameters for the wide display.
-Saves the old frame parameters in `ediff-wide-display-orig-parameters'.
-The frame to be resized is kept in `ediff-wide-display-frame'.
-This function modifies only the left margin and the width of the display.
-It assumes that it is called from within the control buffer."
- (if (not (fboundp 'ediff-display-pixel-width))
- (error "Can't determine display width"))
- (let* ((frame-A (window-frame ediff-window-A))
- (frame-A-params (frame-parameters frame-A))
- (cw (ediff-frame-char-width frame-A))
- (wd (- (/ (ediff-display-pixel-width) cw) 5)))
- (setq ediff-wide-display-orig-parameters
- (list (cons 'left (max 0 (eval (cdr (assoc 'left frame-A-params)))))
- (cons 'width (cdr (assoc 'width frame-A-params))))
- ediff-wide-display-frame frame-A)
- (modify-frame-parameters
- frame-A `((left . ,cw) (width . ,wd) (user-position . t)))))
-
-
-;; Revise the mode line to display which difference we have selected
-;; Also resets modelines of buffers A/B, since they may be clobbered by
-;; anothe invocations of Ediff.
-(defun ediff-refresh-mode-lines ()
- (let (buf-A-state-diff buf-B-state-diff buf-C-state-diff buf-C-state-merge)
-
- (if (ediff-valid-difference-p)
- (setq
- buf-C-state-diff (ediff-get-state-of-diff ediff-current-difference 'C)
- buf-C-state-merge (ediff-get-state-of-merge ediff-current-difference)
- buf-A-state-diff (ediff-get-state-of-diff ediff-current-difference 'A)
- buf-B-state-diff (ediff-get-state-of-diff ediff-current-difference 'B)
- buf-A-state-diff (if buf-A-state-diff
- (format "[%s] " buf-A-state-diff)
- "")
- buf-B-state-diff (if buf-B-state-diff
- (format "[%s] " buf-B-state-diff)
- "")
- buf-C-state-diff (if (and (ediff-buffer-live-p ediff-buffer-C)
- (or buf-C-state-diff buf-C-state-merge))
- (format "[%s%s%s] "
- (or buf-C-state-diff "")
- (if buf-C-state-merge
- (concat " " buf-C-state-merge)
- "")
- (if (ediff-get-state-of-ancestor
- ediff-current-difference)
- " AncestorEmpty"
- "")
- )
- ""))
- (setq buf-A-state-diff ""
- buf-B-state-diff ""
- buf-C-state-diff ""))
-
- ;; control buffer format
- (setq mode-line-format
- (if (ediff-narrow-control-frame-p)
- (list " " mode-line-buffer-identification)
- (list "-- " mode-line-buffer-identification " Quick Help")))
- ;; control buffer id
- (setq mode-line-buffer-identification
- (if (ediff-narrow-control-frame-p)
- (ediff-make-narrow-control-buffer-id 'skip-name)
- (ediff-make-wide-control-buffer-id)))
- ;; Force mode-line redisplay
- (force-mode-line-update)
-
- (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame))
- (ediff-refresh-control-frame))
-
- (ediff-with-current-buffer ediff-buffer-A
- (setq ediff-diff-status buf-A-state-diff)
- (ediff-strip-mode-line-format)
- (setq mode-line-format
- (list " A: " 'ediff-diff-status mode-line-format))
- (force-mode-line-update))
- (ediff-with-current-buffer ediff-buffer-B
- (setq ediff-diff-status buf-B-state-diff)
- (ediff-strip-mode-line-format)
- (setq mode-line-format
- (list " B: " 'ediff-diff-status mode-line-format))
- (force-mode-line-update))
- (if ediff-3way-job
- (ediff-with-current-buffer ediff-buffer-C
- (setq ediff-diff-status buf-C-state-diff)
- (ediff-strip-mode-line-format)
- (setq mode-line-format
- (list " C: " 'ediff-diff-status mode-line-format))
- (force-mode-line-update)))
- (if (ediff-buffer-live-p ediff-ancestor-buffer)
- (ediff-with-current-buffer ediff-ancestor-buffer
- (ediff-strip-mode-line-format)
- ;; we keep the second dummy string in the mode line format of the
- ;; ancestor, since for other buffers Ediff prepends 2 strings and
- ;; ediff-strip-mode-line-format expects that.
- (setq mode-line-format
- (list " Ancestor: "
- (cond ((not (stringp buf-C-state-merge))
- "")
- ((string-match "prefer-A" buf-C-state-merge)
- "[=diff(B)] ")
- ((string-match "prefer-B" buf-C-state-merge)
- "[=diff(A)] ")
- (t ""))
- mode-line-format))))
- ))
-
-
-(defun ediff-refresh-control-frame ()
- (if (featurep 'emacs)
- ;; set frame/icon titles for Emacs
- (modify-frame-parameters
- ediff-control-frame
- (list (cons 'title (ediff-make-base-title))
- (cons 'icon-name (ediff-make-narrow-control-buffer-id))
- ))
- ;; set frame/icon titles for XEmacs
- (setq frame-title-format (ediff-make-base-title)
- frame-icon-title-format (ediff-make-narrow-control-buffer-id))
- ;; force an update of the frame title
- (modify-frame-parameters ediff-control-frame '(()))))
-
-
-(defun ediff-make-narrow-control-buffer-id (&optional skip-name)
- (concat
- (if skip-name
- " "
- (ediff-make-base-title))
- (cond ((< ediff-current-difference 0)
- (format " _/%d" ediff-number-of-differences))
- ((>= ediff-current-difference ediff-number-of-differences)
- (format " $/%d" ediff-number-of-differences))
- (t
- (format " %d/%d"
- (1+ ediff-current-difference)
- ediff-number-of-differences)))))
-
-(defun ediff-make-base-title ()
- (concat
- (cdr (assoc 'name ediff-control-frame-parameters))
- ediff-control-buffer-suffix))
-
-(defun ediff-make-wide-control-buffer-id ()
- (cond ((< ediff-current-difference 0)
- (list (format "%%b At start of %d diffs"
- ediff-number-of-differences)))
- ((>= ediff-current-difference ediff-number-of-differences)
- (list (format "%%b At end of %d diffs"
- ediff-number-of-differences)))
- (t
- (list (format "%%b diff %d of %d"
- (1+ ediff-current-difference)
- ediff-number-of-differences)))))
-
-
-
-;; If buff is not live, return nil
-(defun ediff-get-visible-buffer-window (buff)
- (if (ediff-buffer-live-p buff)
- (if (featurep 'xemacs)
- (get-buffer-window buff t)
- (get-buffer-window buff 'visible))))
-
-
-;;; Functions to decide when to redraw windows
-
-(defun ediff-keep-window-config (control-buf)
- (and (eq control-buf (current-buffer))
- (/= (buffer-size) 0)
- (ediff-with-current-buffer control-buf
- (let ((ctl-wind ediff-control-window)
- (A-wind ediff-window-A)
- (B-wind ediff-window-B)
- (C-wind ediff-window-C))
-
- (and
- (ediff-window-visible-p A-wind)
- (ediff-window-visible-p B-wind)
- ;; if buffer C is defined then take it into account
- (or (not ediff-3way-job)
- (ediff-window-visible-p C-wind))
- (eq (window-buffer A-wind) ediff-buffer-A)
- (eq (window-buffer B-wind) ediff-buffer-B)
- (or (not ediff-3way-job)
- (eq (window-buffer C-wind) ediff-buffer-C))
- (string= ediff-window-config-saved
- (format "%S%S%S%S%S%S%S"
- ctl-wind A-wind B-wind C-wind
- ediff-split-window-function
- (ediff-multiframe-setup-p)
- ediff-wide-display-p)))))))
-
-
-(provide 'ediff-wind)
-
-
-;; Local Variables:
-;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
-;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
-;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
-;; End:
-
-;; arch-tag: 73d9a5d7-eed7-4d9c-8b4b-21d5d78eb597
-;;; ediff-wind.el ends here
+++ /dev/null
-;;; ediff.el --- a comprehensive visual interface to diff & patch
-
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
-;; Created: February 2, 1994
-;; Keywords: comparing, merging, patching, tools, unix
-
-;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
-;; file on 20/3/2008, and the maintainer agreed that when a bug is
-;; filed in the Emacs bug reporting system against this file, a copy
-;; of the bug report be sent to the maintainer's email address.
-
-(defconst ediff-version "2.81.4" "The current version of Ediff")
-(defconst ediff-date "December 7, 2009" "Date of last update")
-
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Never read that diff output again!
-;; Apply patch interactively!
-;; Merge with ease!
-
-;; This package provides a convenient way of simultaneous browsing through
-;; the differences between a pair (or a triple) of files or buffers. The
-;; files being compared, file-A, file-B, and file-C (if applicable) are
-;; shown in separate windows (side by side, one above the another, or in
-;; separate frames), and the differences are highlighted as you step
-;; through them. You can also copy difference regions from one buffer to
-;; another (and recover old differences if you change your mind).
-
-;; Ediff also supports merging operations on files and buffers, including
-;; merging using ancestor versions. Both comparison and merging operations can
-;; be performed on directories, i.e., by pairwise comparison of files in those
-;; directories.
-
-;; In addition, Ediff can apply a patch to a file and then let you step
-;; though both files, the patched and the original one, simultaneously,
-;; difference-by-difference. You can even apply a patch right out of a
-;; mail buffer, i.e., patches received by mail don't even have to be saved.
-;; Since Ediff lets you copy differences between buffers, you can, in
-;; effect, apply patches selectively (i.e., you can copy a difference
-;; region from file_orig to file, thereby undoing any particular patch that
-;; you don't like).
-
-;; Ediff is aware of version control, which lets the user compare
-;; files with their older versions. Ediff can also work with remote and
-;; compressed files. Details are given below.
-
-;; Finally, Ediff supports directory-level comparison, merging and patching.
-;; See the on-line manual for details.
-
-;; This package builds upon the ideas borrowed from emerge.el and several
-;; Ediff's functions are adaptations from emerge.el. Much of the functionality
-;; Ediff provides is also influenced by emerge.el.
-
-;; The present version of Ediff supersedes Emerge. It provides a superior user
-;; interface and has numerous major features not found in Emerge. In
-;; particular, it can do patching, and 2-way and 3-way file comparison,
-;; merging, and directory operations.
-
-
-
-;;; Bugs:
-
-;; 1. The undo command doesn't restore deleted regions well. That is, if
-;; you delete all characters in a difference region and then invoke
-;; `undo', the reinstated text will most likely be inserted outside of
-;; what Ediff thinks is the current difference region. (This problem
-;; doesn't seem to exist with XEmacs.)
-;;
-;; If at any point you feel that difference regions are no longer correct,
-;; you can hit '!' to recompute the differences.
-
-;; 2. On a monochrome display, the repertoire of faces with which to
-;; highlight fine differences is limited. By default, Ediff is using
-;; underlining. However, if the region is already underlined by some other
-;; overlays, there is no simple way to temporarily remove that residual
-;; underlining. This problem occurs when a buffer is highlighted with
-;; hilit19.el or font-lock.el packages. If this residual highlighting gets
-;; in the way, you can do the following. Both font-lock.el and hilit19.el
-;; provide commands for unhighlighting buffers. You can either place these
-;; commands in `ediff-prepare-buffer-hook' (which will unhighlight every
-;; buffer used by Ediff) or you can execute them interactively, at any time
-;; and on any buffer.
-
-
-;;; Acknowledgements:
-
-;; Ediff was inspired by Dale R. Worley's <drw@math.mit.edu> emerge.el.
-;; Ediff would not have been possible without the help and encouragement of
-;; its many users. See Ediff on-line Info for the full list of those who
-;; helped. Improved defaults in Ediff file-name reading commands.
-
-;;; Code:
-
-(provide 'ediff)
-
-;; Compiler pacifier
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
-
-
-(eval-when-compile
- (require 'dired)
- (require 'ediff-util)
- (require 'ediff-ptch))
-;; end pacifier
-
-(require 'ediff-init)
-(require 'ediff-mult) ; required because of the registry stuff
-
-(defgroup ediff nil
- "A comprehensive visual interface to diff & patch."
- :tag "Ediff"
- :group 'tools)
-
-
-(defcustom ediff-use-last-dir nil
- "If t, Ediff will use previous directory as default when reading file name."
- :type 'boolean
- :group 'ediff)
-
-;; Last directory used by an Ediff command for file-A.
-(defvar ediff-last-dir-A nil)
-;; Last directory used by an Ediff command for file-B.
-(defvar ediff-last-dir-B nil)
-;; Last directory used by an Ediff command for file-C.
-(defvar ediff-last-dir-C nil)
-;; Last directory used by an Ediff command for the ancestor file.
-(defvar ediff-last-dir-ancestor nil)
-;; Last directory used by an Ediff command as the output directory for merge.
-(defvar ediff-last-merge-autostore-dir nil)
-
-
-;; Used as a startup hook to set `_orig' patch file read-only.
-(defun ediff-set-read-only-in-buf-A ()
- (ediff-with-current-buffer ediff-buffer-A
- (toggle-read-only 1)))
-
-;; Return a plausible default for ediff's first file:
-;; In dired, return the file number FILENO (or 0) in the list
-;; (all-selected-files, filename under the cursor), where directories are
-;; ignored. Otherwise, return DEFAULT file name, if non-nil. Else,
-;; if the buffer is visiting a file, return that file name.
-(defun ediff-get-default-file-name (&optional default fileno)
- (cond ((eq major-mode 'dired-mode)
- (let ((current (dired-get-filename nil 'no-error))
- (marked (condition-case nil
- (dired-get-marked-files 'no-dir)
- (error nil)))
- aux-list choices result)
- (or (integerp fileno) (setq fileno 0))
- (if (stringp default)
- (setq aux-list (cons default aux-list)))
- (if (and (stringp current) (not (file-directory-p current)))
- (setq aux-list (cons current aux-list)))
- (setq choices (nconc marked aux-list))
- (setq result (elt choices fileno))
- (or result
- default)))
- ((stringp default) default)
- ((buffer-file-name (current-buffer))
- (file-name-nondirectory (buffer-file-name (current-buffer))))
- ))
-
-;;; Compare files/buffers
-
-;;;###autoload
-(defun ediff-files (file-A file-B &optional startup-hooks)
- "Run Ediff on a pair of files, FILE-A and FILE-B."
- (interactive
- (let ((dir-A (if ediff-use-last-dir
- ediff-last-dir-A
- default-directory))
- dir-B f)
- (list (setq f (ediff-read-file-name
- "File A to compare"
- dir-A
- (ediff-get-default-file-name)
- 'no-dirs))
- (ediff-read-file-name "File B to compare"
- (setq dir-B
- (if ediff-use-last-dir
- ediff-last-dir-B
- (file-name-directory f)))
- (progn
- (ediff-add-to-history
- 'file-name-history
- (ediff-abbreviate-file-name
- (expand-file-name
- (file-name-nondirectory f)
- dir-B)))
- (ediff-get-default-file-name f 1)))
- )))
- (ediff-files-internal file-A
- (if (file-directory-p file-B)
- (expand-file-name
- (file-name-nondirectory file-A) file-B)
- file-B)
- nil ; file-C
- startup-hooks
- 'ediff-files))
-
-;;;###autoload
-(defun ediff-files3 (file-A file-B file-C &optional startup-hooks)
- "Run Ediff on three files, FILE-A, FILE-B, and FILE-C."
- (interactive
- (let ((dir-A (if ediff-use-last-dir
- ediff-last-dir-A
- default-directory))
- dir-B dir-C f ff)
- (list (setq f (ediff-read-file-name
- "File A to compare"
- dir-A
- (ediff-get-default-file-name)
- 'no-dirs))
- (setq ff (ediff-read-file-name "File B to compare"
- (setq dir-B
- (if ediff-use-last-dir
- ediff-last-dir-B
- (file-name-directory f)))
- (progn
- (ediff-add-to-history
- 'file-name-history
- (ediff-abbreviate-file-name
- (expand-file-name
- (file-name-nondirectory f)
- dir-B)))
- (ediff-get-default-file-name f 1))))
- (ediff-read-file-name "File C to compare"
- (setq dir-C (if ediff-use-last-dir
- ediff-last-dir-C
- (file-name-directory ff)))
- (progn
- (ediff-add-to-history
- 'file-name-history
- (ediff-abbreviate-file-name
- (expand-file-name
- (file-name-nondirectory ff)
- dir-C)))
- (ediff-get-default-file-name ff 2)))
- )))
- (ediff-files-internal file-A
- (if (file-directory-p file-B)
- (expand-file-name
- (file-name-nondirectory file-A) file-B)
- file-B)
- (if (file-directory-p file-C)
- (expand-file-name
- (file-name-nondirectory file-A) file-C)
- file-C)
- startup-hooks
- 'ediff-files3))
-
-;;;###autoload
-(defalias 'ediff3 'ediff-files3)
-
-
-(defun ediff-find-file (file-var buffer-name &optional last-dir hooks-var)
- "Visit FILE and arrange its buffer to Ediff's liking.
-FILE-VAR is actually a variable symbol whose value must contain a true
-file name.
-BUFFER-NAME is a variable symbol, which will get the buffer object into
-which FILE is read.
-LAST-DIR is the directory variable symbol where FILE's
-directory name should be returned. HOOKS-VAR is a variable symbol that will
-be assigned the hook to be executed after `ediff-startup' is finished.
-`ediff-find-file' arranges that the temp files it might create will be
-deleted."
- (let* ((file (symbol-value file-var))
- (file-magic (ediff-filename-magic-p file))
- (temp-file-name-prefix (file-name-nondirectory file)))
- (cond ((not (file-readable-p file))
- (error "File `%s' does not exist or is not readable" file))
- ((file-directory-p file)
- (error "File `%s' is a directory" file)))
-
- ;; some of the commands, below, require full file name
- (setq file (expand-file-name file))
-
- ;; Record the directory of the file
- (if last-dir
- (set last-dir (expand-file-name (file-name-directory file))))
-
- ;; Setup the buffer
- (set buffer-name (find-file-noselect file))
-
- (ediff-with-current-buffer (symbol-value buffer-name)
- (widen) ; Make sure the entire file is seen
- (cond (file-magic ; file has a handler, such as jka-compr-handler or
- ;;; ange-ftp-hook-function--arrange for temp file
- (ediff-verify-file-buffer 'magic)
- (setq file
- (ediff-make-temp-file
- (current-buffer) temp-file-name-prefix))
- (set hooks-var (cons `(lambda () (delete-file ,file))
- (symbol-value hooks-var))))
- ;; file processed via auto-mode-alist, a la uncompress.el
- ((not (equal (file-truename file)
- (file-truename (buffer-file-name))))
- (setq file
- (ediff-make-temp-file
- (current-buffer) temp-file-name-prefix))
- (set hooks-var (cons `(lambda () (delete-file ,file))
- (symbol-value hooks-var))))
- (t ;; plain file---just check that the file matches the buffer
- (ediff-verify-file-buffer))))
- (set file-var file)))
-
-;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer
-(defun ediff-files-internal (file-A file-B file-C startup-hooks job-name
- &optional merge-buffer-file)
- (let (buf-A buf-B buf-C)
- (if (string= file-A file-B)
- (error "Files A and B are the same"))
- (if (stringp file-C)
- (or (and (string= file-A file-C) (error "Files A and C are the same"))
- (and (string= file-B file-C) (error "Files B and C are the same"))))
- (message "Reading file %s ... " file-A)
- ;;(sit-for 0)
- (ediff-find-file 'file-A 'buf-A 'ediff-last-dir-A 'startup-hooks)
- (message "Reading file %s ... " file-B)
- ;;(sit-for 0)
- (ediff-find-file 'file-B 'buf-B 'ediff-last-dir-B 'startup-hooks)
- (if (stringp file-C)
- (progn
- (message "Reading file %s ... " file-C)
- ;;(sit-for 0)
- (ediff-find-file
- 'file-C 'buf-C
- (if (eq job-name 'ediff-merge-files-with-ancestor)
- 'ediff-last-dir-ancestor 'ediff-last-dir-C)
- 'startup-hooks)))
- (ediff-setup buf-A file-A
- buf-B file-B
- buf-C file-C
- startup-hooks
- (list (cons 'ediff-job-name job-name))
- merge-buffer-file)))
-
-(declare-function diff-latest-backup-file "diff" (fn))
-
-;;;###autoload
-(defalias 'ediff 'ediff-files)
-
-;;;###autoload
-(defun ediff-current-file ()
- "Start ediff between current buffer and its file on disk.
-This command can be used instead of `revert-buffer'. If there is
-nothing to revert then this command fails."
- (interactive)
- (unless (or revert-buffer-function
- revert-buffer-insert-file-contents-function
- (and buffer-file-number
- (or (buffer-modified-p)
- (not (verify-visited-file-modtime
- (current-buffer))))))
- (error "Nothing to revert"))
- (let* ((auto-save-p (and (recent-auto-save-p)
- buffer-auto-save-file-name
- (file-readable-p buffer-auto-save-file-name)
- (y-or-n-p
- "Buffer has been auto-saved recently. Compare with auto-save file? ")))
- (file-name (if auto-save-p
- buffer-auto-save-file-name
- buffer-file-name))
- (revert-buf-name (concat "FILE=" file-name))
- (revert-buf (get-buffer revert-buf-name))
- (current-major major-mode))
- (unless file-name
- (error "Buffer does not seem to be associated with any file"))
- (when revert-buf
- (kill-buffer revert-buf)
- (setq revert-buf nil))
- (setq revert-buf (get-buffer-create revert-buf-name))
- (with-current-buffer revert-buf
- (insert-file-contents file-name)
- ;; Assume same modes:
- (funcall current-major))
- (ediff-buffers revert-buf (current-buffer))))
-
-
-;;;###autoload
-(defun ediff-backup (file)
- "Run Ediff on FILE and its backup file.
-Uses the latest backup, if there are several numerical backups.
-If this file is a backup, `ediff' it with its original."
- (interactive (list (read-file-name "Ediff (file with backup): ")))
- ;; The code is taken from `diff-backup'.
- (require 'diff)
- (let (bak ori)
- (if (backup-file-name-p file)
- (setq bak file
- ori (file-name-sans-versions file))
- (setq bak (or (diff-latest-backup-file file)
- (error "No backup found for %s" file))
- ori file))
- (ediff-files bak ori)))
-
-;;;###autoload
-(defun ediff-buffers (buffer-A buffer-B &optional startup-hooks job-name)
- "Run Ediff on a pair of buffers, BUFFER-A and BUFFER-B."
- (interactive
- (let (bf)
- (list (setq bf (read-buffer "Buffer A to compare: "
- (ediff-other-buffer "") t))
- (read-buffer "Buffer B to compare: "
- (progn
- ;; realign buffers so that two visible bufs will be
- ;; at the top
- (save-window-excursion (other-window 1))
- (ediff-other-buffer bf))
- t))))
- (or job-name (setq job-name 'ediff-buffers))
- (ediff-buffers-internal buffer-A buffer-B nil startup-hooks job-name))
-
-;;;###autoload
-(defalias 'ebuffers 'ediff-buffers)
-
-
-;;;###autoload
-(defun ediff-buffers3 (buffer-A buffer-B buffer-C
- &optional startup-hooks job-name)
- "Run Ediff on three buffers, BUFFER-A, BUFFER-B, and BUFFER-C."
- (interactive
- (let (bf bff)
- (list (setq bf (read-buffer "Buffer A to compare: "
- (ediff-other-buffer "") t))
- (setq bff (read-buffer "Buffer B to compare: "
- (progn
- ;; realign buffers so that two visible
- ;; bufs will be at the top
- (save-window-excursion (other-window 1))
- (ediff-other-buffer bf))
- t))
- (read-buffer "Buffer C to compare: "
- (progn
- ;; realign buffers so that three visible
- ;; bufs will be at the top
- (save-window-excursion (other-window 1))
- (ediff-other-buffer (list bf bff)))
- t)
- )))
- (or job-name (setq job-name 'ediff-buffers3))
- (ediff-buffers-internal buffer-A buffer-B buffer-C startup-hooks job-name))
-
-;;;###autoload
-(defalias 'ebuffers3 'ediff-buffers3)
-
-
-
-;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer
-(defun ediff-buffers-internal (buf-A buf-B buf-C startup-hooks job-name
- &optional merge-buffer-file)
- (let* ((buf-A-file-name (buffer-file-name (get-buffer buf-A)))
- (buf-B-file-name (buffer-file-name (get-buffer buf-B)))
- (buf-C-is-alive (ediff-buffer-live-p buf-C))
- (buf-C-file-name (if buf-C-is-alive
- (buffer-file-name (get-buffer buf-B))))
- file-A file-B file-C)
- (unwind-protect
- (progn
- (if (not (ediff-buffer-live-p buf-A))
- (error "Buffer %S doesn't exist" buf-A))
- (if (not (ediff-buffer-live-p buf-B))
- (error "Buffer %S doesn't exist" buf-B))
- (let ((ediff-job-name job-name))
- (if (and ediff-3way-comparison-job
- (not buf-C-is-alive))
- (error "Buffer %S doesn't exist" buf-C)))
- (if (stringp buf-A-file-name)
- (setq buf-A-file-name (file-name-nondirectory buf-A-file-name)))
- (if (stringp buf-B-file-name)
- (setq buf-B-file-name (file-name-nondirectory buf-B-file-name)))
- (if (stringp buf-C-file-name)
- (setq buf-C-file-name (file-name-nondirectory buf-C-file-name)))
-
- (setq file-A (ediff-make-temp-file buf-A buf-A-file-name)
- file-B (ediff-make-temp-file buf-B buf-B-file-name))
- (if buf-C-is-alive
- (setq file-C (ediff-make-temp-file buf-C buf-C-file-name)))
-
- (ediff-setup (get-buffer buf-A) file-A
- (get-buffer buf-B) file-B
- (if buf-C-is-alive (get-buffer buf-C))
- file-C
- (cons `(lambda ()
- (delete-file ,file-A)
- (delete-file ,file-B)
- (if (stringp ,file-C) (delete-file ,file-C)))
- startup-hooks)
- (list (cons 'ediff-job-name job-name))
- merge-buffer-file))
- (if (and (stringp file-A) (file-exists-p file-A))
- (delete-file file-A))
- (if (and (stringp file-B) (file-exists-p file-B))
- (delete-file file-B))
- (if (and (stringp file-C) (file-exists-p file-C))
- (delete-file file-C)))))
-
-
-;;; Directory and file group operations
-
-;; Get appropriate default name for directory:
-;; If ediff-use-last-dir, use ediff-last-dir-A.
-;; In dired mode, use the directory that is under the point (if any);
-;; otherwise, use default-directory
-(defun ediff-get-default-directory-name ()
- (cond (ediff-use-last-dir ediff-last-dir-A)
- ((eq major-mode 'dired-mode)
- (let ((f (dired-get-filename nil 'noerror)))
- (if (and (stringp f) (file-directory-p f))
- f
- default-directory)))
- (t default-directory)))
-
-
-;;;###autoload
-(defun ediff-directories (dir1 dir2 regexp)
- "Run Ediff on a pair of directories, DIR1 and DIR2, comparing files that have
-the same name in both. The third argument, REGEXP, is nil or a regular
-expression; only file names that match the regexp are considered."
- (interactive
- (let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
- f)
- (list (setq f (read-directory-name
- "Directory A to compare:" dir-A nil 'must-match))
- (read-directory-name "Directory B to compare:"
- (if ediff-use-last-dir
- ediff-last-dir-B
- (ediff-strip-last-dir f))
- nil 'must-match)
- (read-string
- (if (stringp default-regexp)
- (format "Filter through regular expression (default %s): "
- default-regexp)
- "Filter through regular expression: ")
- nil
- 'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
- )))
- (ediff-directories-internal
- dir1 dir2 nil regexp 'ediff-files 'ediff-directories
- ))
-
-;;;###autoload
-(defalias 'edirs 'ediff-directories)
-
-
-;;;###autoload
-(defun ediff-directory-revisions (dir1 regexp)
- "Run Ediff on a directory, DIR1, comparing its files with their revisions.
-The second argument, REGEXP, is a regular expression that filters the file
-names. Only the files that are under revision control are taken into account."
- (interactive
- (let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
- )
- (list (read-directory-name
- "Directory to compare with revision:" dir-A nil 'must-match)
- (read-string
- (if (stringp default-regexp)
- (format "Filter through regular expression (default %s): "
- default-regexp)
- "Filter through regular expression: ")
- nil
- 'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
- )))
- (ediff-directory-revisions-internal
- dir1 regexp 'ediff-revision 'ediff-directory-revisions
- ))
-
-;;;###autoload
-(defalias 'edir-revisions 'ediff-directory-revisions)
-
-
-;;;###autoload
-(defun ediff-directories3 (dir1 dir2 dir3 regexp)
- "Run Ediff on three directories, DIR1, DIR2, and DIR3, comparing files that
-have the same name in all three. The last argument, REGEXP, is nil or a
-regular expression; only file names that match the regexp are considered."
-
- (interactive
- (let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
- f)
- (list (setq f (read-directory-name "Directory A to compare:" dir-A nil))
- (setq f (read-directory-name "Directory B to compare:"
- (if ediff-use-last-dir
- ediff-last-dir-B
- (ediff-strip-last-dir f))
- nil 'must-match))
- (read-directory-name "Directory C to compare:"
- (if ediff-use-last-dir
- ediff-last-dir-C
- (ediff-strip-last-dir f))
- nil 'must-match)
- (read-string
- (if (stringp default-regexp)
- (format "Filter through regular expression (default %s): "
- default-regexp)
- "Filter through regular expression: ")
- nil
- 'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
- )))
- (ediff-directories-internal
- dir1 dir2 dir3 regexp 'ediff-files3 'ediff-directories3
- ))
-
-;;;###autoload
-(defalias 'edirs3 'ediff-directories3)
-
-;;;###autoload
-(defun ediff-merge-directories (dir1 dir2 regexp &optional merge-autostore-dir)
- "Run Ediff on a pair of directories, DIR1 and DIR2, merging files that have
-the same name in both. The third argument, REGEXP, is nil or a regular
-expression; only file names that match the regexp are considered."
- (interactive
- (let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
- f)
- (list (setq f (read-directory-name "Directory A to merge:"
- dir-A nil 'must-match))
- (read-directory-name "Directory B to merge:"
- (if ediff-use-last-dir
- ediff-last-dir-B
- (ediff-strip-last-dir f))
- nil 'must-match)
- (read-string
- (if (stringp default-regexp)
- (format "Filter through regular expression (default %s): "
- default-regexp)
- "Filter through regular expression: ")
- nil
- 'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
- )))
- (ediff-directories-internal
- dir1 dir2 nil regexp 'ediff-merge-files 'ediff-merge-directories
- nil merge-autostore-dir
- ))
-
-;;;###autoload
-(defalias 'edirs-merge 'ediff-merge-directories)
-
-;;;###autoload
-(defun ediff-merge-directories-with-ancestor (dir1 dir2 ancestor-dir regexp
- &optional
- merge-autostore-dir)
- "Merge files in directories DIR1 and DIR2 using files in ANCESTOR-DIR as ancestors.
-Ediff merges files that have identical names in DIR1, DIR2. If a pair of files
-in DIR1 and DIR2 doesn't have an ancestor in ANCESTOR-DIR, Ediff will merge
-without ancestor. The fourth argument, REGEXP, is nil or a regular expression;
-only file names that match the regexp are considered."
- (interactive
- (let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
- f)
- (list (setq f (read-directory-name "Directory A to merge:" dir-A nil))
- (setq f (read-directory-name "Directory B to merge:"
- (if ediff-use-last-dir
- ediff-last-dir-B
- (ediff-strip-last-dir f))
- nil 'must-match))
- (read-directory-name "Ancestor directory:"
- (if ediff-use-last-dir
- ediff-last-dir-C
- (ediff-strip-last-dir f))
- nil 'must-match)
- (read-string
- (if (stringp default-regexp)
- (format "Filter through regular expression (default %s): "
- default-regexp)
- "Filter through regular expression: ")
- nil
- 'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
- )))
- (ediff-directories-internal
- dir1 dir2 ancestor-dir regexp
- 'ediff-merge-files-with-ancestor 'ediff-merge-directories-with-ancestor
- nil merge-autostore-dir
- ))
-
-;;;###autoload
-(defun ediff-merge-directory-revisions (dir1 regexp
- &optional merge-autostore-dir)
- "Run Ediff on a directory, DIR1, merging its files with their revisions.
-The second argument, REGEXP, is a regular expression that filters the file
-names. Only the files that are under revision control are taken into account."
- (interactive
- (let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
- )
- (list (read-directory-name
- "Directory to merge with revisions:" dir-A nil 'must-match)
- (read-string
- (if (stringp default-regexp)
- (format "Filter through regular expression (default %s): "
- default-regexp)
- "Filter through regular expression: ")
- nil
- 'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
- )))
- (ediff-directory-revisions-internal
- dir1 regexp 'ediff-merge-revisions 'ediff-merge-directory-revisions
- nil merge-autostore-dir
- ))
-
-;;;###autoload
-(defalias 'edir-merge-revisions 'ediff-merge-directory-revisions)
-
-;;;###autoload
-(defun ediff-merge-directory-revisions-with-ancestor (dir1 regexp
- &optional
- merge-autostore-dir)
- "Run Ediff on a directory, DIR1, merging its files with their revisions and ancestors.
-The second argument, REGEXP, is a regular expression that filters the file
-names. Only the files that are under revision control are taken into account."
- (interactive
- (let ((dir-A (ediff-get-default-directory-name))
- (default-regexp (eval ediff-default-filtering-regexp))
- )
- (list (read-directory-name
- "Directory to merge with revisions and ancestors:"
- dir-A nil 'must-match)
- (read-string
- (if (stringp default-regexp)
- (format "Filter through regular expression (default %s): "
- default-regexp)
- "Filter through regular expression: ")
- nil
- 'ediff-filtering-regexp-history
- (eval ediff-default-filtering-regexp))
- )))
- (ediff-directory-revisions-internal
- dir1 regexp 'ediff-merge-revisions-with-ancestor
- 'ediff-merge-directory-revisions-with-ancestor
- nil merge-autostore-dir
- ))
-
-;;;###autoload
-(defalias
- 'edir-merge-revisions-with-ancestor
- 'ediff-merge-directory-revisions-with-ancestor)
-
-;;;###autoload
-(defalias 'edirs-merge-with-ancestor 'ediff-merge-directories-with-ancestor)
-
-;; Run ediff-action (ediff-files, ediff-merge, ediff-merge-with-ancestors)
-;; on a pair of directories (three directories, in case of ancestor).
-;; The third argument, REGEXP, is nil or a regular expression;
-;; only file names that match the regexp are considered.
-;; JOBNAME is the symbol indicating the meta-job to be performed.
-;; MERGE-AUTOSTORE-DIR is the directory in which to store merged files.
-(defun ediff-directories-internal (dir1 dir2 dir3 regexp action jobname
- &optional startup-hooks
- merge-autostore-dir)
- (if (stringp dir3)
- (setq dir3 (if (file-directory-p dir3) dir3 (file-name-directory dir3))))
-
- (cond ((string= dir1 dir2)
- (error "Directories A and B are the same: %s" dir1))
- ((and (eq jobname 'ediff-directories3)
- (string= dir1 dir3))
- (error "Directories A and C are the same: %s" dir1))
- ((and (eq jobname 'ediff-directories3)
- (string= dir2 dir3))
- (error "Directories B and C are the same: %s" dir1)))
-
- (if merge-autostore-dir
- (or (stringp merge-autostore-dir)
- (error "%s: Directory for storing merged files must be a string"
- jobname)))
- (let (;; dir-diff-struct is of the form (common-list diff-list)
- ;; It is a structure where ediff-intersect-directories returns
- ;; commonalities and differences among directories
- dir-diff-struct
- meta-buf)
- (if (and ediff-autostore-merges
- (ediff-merge-metajob jobname)
- (not merge-autostore-dir))
- (setq merge-autostore-dir
- (read-directory-name "Save merged files in directory: "
- (if ediff-use-last-dir
- ediff-last-merge-autostore-dir
- (ediff-strip-last-dir dir1))
- nil
- 'must-match)))
- ;; verify we are not merging into an orig directory
- (if merge-autostore-dir
- (cond ((and (stringp dir1) (string= merge-autostore-dir dir1))
- (or (y-or-n-p
- "Directory for saving merged files = Directory A. Sure? ")
- (error "Directory merge aborted")))
- ((and (stringp dir2) (string= merge-autostore-dir dir2))
- (or (y-or-n-p
- "Directory for saving merged files = Directory B. Sure? ")
- (error "Directory merge aborted")))
- ((and (stringp dir3) (string= merge-autostore-dir dir3))
- (or (y-or-n-p
- "Directory for saving merged files = Ancestor Directory. Sure? ")
- (error "Directory merge aborted")))))
-
- (setq dir-diff-struct (ediff-intersect-directories
- jobname
- regexp dir1 dir2 dir3 merge-autostore-dir))
- (setq startup-hooks
- ;; this sets various vars in the meta buffer inside
- ;; ediff-prepare-meta-buffer
- (cons `(lambda ()
- ;; tell what to do if the user clicks on a session record
- (setq ediff-session-action-function (quote ,action))
- ;; set ediff-dir-difference-list
- (setq ediff-dir-difference-list
- (cdr (quote ,dir-diff-struct))))
- startup-hooks))
- (setq meta-buf (ediff-prepare-meta-buffer
- 'ediff-filegroup-action
- (car dir-diff-struct)
- "*Ediff Session Group Panel"
- 'ediff-redraw-directory-group-buffer
- jobname
- startup-hooks))
- (ediff-show-meta-buffer meta-buf)
- ))
-
-;; MERGE-AUTOSTORE-DIR can be given to tell ediff where to store the merged
-;; files
-(defun ediff-directory-revisions-internal (dir1 regexp action jobname
- &optional startup-hooks
- merge-autostore-dir)
- (setq dir1 (if (file-directory-p dir1) dir1 (file-name-directory dir1)))
-
- (if merge-autostore-dir
- (or (stringp merge-autostore-dir)
- (error "%S: Directory for storing merged files must be a string"
- jobname)))
- (let (file-list meta-buf)
- (if (and ediff-autostore-merges
- (ediff-merge-metajob jobname)
- (not merge-autostore-dir))
- (setq merge-autostore-dir
- (read-directory-name "Save merged files in directory: "
- (if ediff-use-last-dir
- ediff-last-merge-autostore-dir
- (ediff-strip-last-dir dir1))
- nil
- 'must-match)))
- ;; verify merge-autostore-dir != dir1
- (if (and merge-autostore-dir
- (stringp dir1)
- (string= merge-autostore-dir dir1))
- (or (y-or-n-p
- "Directory for saving merged file = directory A. Sure? ")
- (error "Merge of directory revisions aborted")))
-
- (setq file-list
- (ediff-get-directory-files-under-revision
- jobname regexp dir1 merge-autostore-dir))
- (setq startup-hooks
- ;; this sets various vars in the meta buffer inside
- ;; ediff-prepare-meta-buffer
- (cons `(lambda ()
- ;; tell what to do if the user clicks on a session record
- (setq ediff-session-action-function (quote ,action)))
- startup-hooks))
- (setq meta-buf (ediff-prepare-meta-buffer
- 'ediff-filegroup-action
- file-list
- "*Ediff Session Group Panel"
- 'ediff-redraw-directory-group-buffer
- jobname
- startup-hooks))
- (ediff-show-meta-buffer meta-buf)
- ))
-
-
-;;; Compare regions and windows
-
-;;;###autoload
-(defun ediff-windows-wordwise (dumb-mode &optional wind-A wind-B startup-hooks)
- "Compare WIND-A and WIND-B, which are selected by clicking, wordwise.
-With prefix argument, DUMB-MODE, or on a non-windowing display, works as
-follows:
-If WIND-A is nil, use selected window.
-If WIND-B is nil, use window next to WIND-A."
- (interactive "P")
- (ediff-windows dumb-mode wind-A wind-B
- startup-hooks 'ediff-windows-wordwise 'word-mode))
-
-;;;###autoload
-(defun ediff-windows-linewise (dumb-mode &optional wind-A wind-B startup-hooks)
- "Compare WIND-A and WIND-B, which are selected by clicking, linewise.
-With prefix argument, DUMB-MODE, or on a non-windowing display, works as
-follows:
-If WIND-A is nil, use selected window.
-If WIND-B is nil, use window next to WIND-A."
- (interactive "P")
- (ediff-windows dumb-mode wind-A wind-B
- startup-hooks 'ediff-windows-linewise nil))
-
-;; Compare WIND-A and WIND-B, which are selected by clicking.
-;; With prefix argument, DUMB-MODE, or on a non-windowing display,
-;; works as follows:
-;; If WIND-A is nil, use selected window.
-;; If WIND-B is nil, use window next to WIND-A.
-(defun ediff-windows (dumb-mode wind-A wind-B startup-hooks job-name word-mode)
- (if (or dumb-mode (not (ediff-window-display-p)))
- (setq wind-A (ediff-get-next-window wind-A nil)
- wind-B (ediff-get-next-window wind-B wind-A))
- (setq wind-A (ediff-get-window-by-clicking wind-A nil 1)
- wind-B (ediff-get-window-by-clicking wind-B wind-A 2)))
-
- (let ((buffer-A (window-buffer wind-A))
- (buffer-B (window-buffer wind-B))
- beg-A end-A beg-B end-B)
-
- (save-excursion
- (save-window-excursion
- (sit-for 0) ; sync before using window-start/end -- a precaution
- (select-window wind-A)
- (setq beg-A (window-start)
- end-A (window-end))
- (select-window wind-B)
- (setq beg-B (window-start)
- end-B (window-end))))
- (setq buffer-A
- (ediff-clone-buffer-for-window-comparison
- buffer-A wind-A "-Window.A-")
- buffer-B
- (ediff-clone-buffer-for-window-comparison
- buffer-B wind-B "-Window.B-"))
- (ediff-regions-internal
- buffer-A beg-A end-A buffer-B beg-B end-B
- startup-hooks job-name word-mode nil)))
-
-
-;;;###autoload
-(defun ediff-regions-wordwise (buffer-A buffer-B &optional startup-hooks)
- "Run Ediff on a pair of regions in specified buffers.
-Regions \(i.e., point and mark\) can be set in advance or marked interactively.
-This function is effective only for relatively small regions, up to 200
-lines. For large regions, use `ediff-regions-linewise'."
- (interactive
- (let (bf)
- (list (setq bf (read-buffer "Region's A buffer: "
- (ediff-other-buffer "") t))
- (read-buffer "Region's B buffer: "
- (progn
- ;; realign buffers so that two visible bufs will be
- ;; at the top
- (save-window-excursion (other-window 1))
- (ediff-other-buffer bf))
- t))))
- (if (not (ediff-buffer-live-p buffer-A))
- (error "Buffer %S doesn't exist" buffer-A))
- (if (not (ediff-buffer-live-p buffer-B))
- (error "Buffer %S doesn't exist" buffer-B))
-
-
- (let ((buffer-A
- (ediff-clone-buffer-for-region-comparison buffer-A "-Region.A-"))
- (buffer-B
- (ediff-clone-buffer-for-region-comparison buffer-B "-Region.B-"))
- reg-A-beg reg-A-end reg-B-beg reg-B-end)
- (with-current-buffer buffer-A
- (setq reg-A-beg (region-beginning)
- reg-A-end (region-end))
- (set-buffer buffer-B)
- (setq reg-B-beg (region-beginning)
- reg-B-end (region-end)))
-
- (ediff-regions-internal
- (get-buffer buffer-A) reg-A-beg reg-A-end
- (get-buffer buffer-B) reg-B-beg reg-B-end
- startup-hooks 'ediff-regions-wordwise 'word-mode nil)))
-
-;;;###autoload
-(defun ediff-regions-linewise (buffer-A buffer-B &optional startup-hooks)
- "Run Ediff on a pair of regions in specified buffers.
-Regions \(i.e., point and mark\) can be set in advance or marked interactively.
-Each region is enlarged to contain full lines.
-This function is effective for large regions, over 100-200
-lines. For small regions, use `ediff-regions-wordwise'."
- (interactive
- (let (bf)
- (list (setq bf (read-buffer "Region A's buffer: "
- (ediff-other-buffer "") t))
- (read-buffer "Region B's buffer: "
- (progn
- ;; realign buffers so that two visible bufs will be
- ;; at the top
- (save-window-excursion (other-window 1))
- (ediff-other-buffer bf))
- t))))
- (if (not (ediff-buffer-live-p buffer-A))
- (error "Buffer %S doesn't exist" buffer-A))
- (if (not (ediff-buffer-live-p buffer-B))
- (error "Buffer %S doesn't exist" buffer-B))
-
- (let ((buffer-A
- (ediff-clone-buffer-for-region-comparison buffer-A "-Region.A-"))
- (buffer-B
- (ediff-clone-buffer-for-region-comparison buffer-B "-Region.B-"))
- reg-A-beg reg-A-end reg-B-beg reg-B-end)
- (with-current-buffer buffer-A
- (setq reg-A-beg (region-beginning)
- reg-A-end (region-end))
- ;; enlarge the region to hold full lines
- (goto-char reg-A-beg)
- (beginning-of-line)
- (setq reg-A-beg (point))
- (goto-char reg-A-end)
- (end-of-line)
- (or (eobp) (forward-char)) ; include the newline char
- (setq reg-A-end (point))
-
- (set-buffer buffer-B)
- (setq reg-B-beg (region-beginning)
- reg-B-end (region-end))
- ;; enlarge the region to hold full lines
- (goto-char reg-B-beg)
- (beginning-of-line)
- (setq reg-B-beg (point))
- (goto-char reg-B-end)
- (end-of-line)
- (or (eobp) (forward-char)) ; include the newline char
- (setq reg-B-end (point))
- ) ; save excursion
-
- (ediff-regions-internal
- (get-buffer buffer-A) reg-A-beg reg-A-end
- (get-buffer buffer-B) reg-B-beg reg-B-end
- startup-hooks 'ediff-regions-linewise nil nil))) ; no word mode
-
-;; compare region beg-A to end-A of buffer-A
-;; to regions beg-B -- end-B in buffer-B.
-(defun ediff-regions-internal (buffer-A beg-A end-A buffer-B beg-B end-B
- startup-hooks job-name word-mode
- setup-parameters)
- (let ((tmp-buffer (get-buffer-create ediff-tmp-buffer))
- overl-A overl-B
- file-A file-B)
- (unwind-protect
- (progn
- ;; in case beg/end-A/B aren't markers--make them into markers
- (ediff-with-current-buffer buffer-A
- (setq beg-A (move-marker (make-marker) beg-A)
- end-A (move-marker (make-marker) end-A)))
- (ediff-with-current-buffer buffer-B
- (setq beg-B (move-marker (make-marker) beg-B)
- end-B (move-marker (make-marker) end-B)))
-
- ;; make file-A
- (if word-mode
- (ediff-wordify beg-A end-A buffer-A tmp-buffer)
- (ediff-copy-to-buffer beg-A end-A buffer-A tmp-buffer))
- (setq file-A (ediff-make-temp-file tmp-buffer "regA"))
-
- ;; make file-B
- (if word-mode
- (ediff-wordify beg-B end-B buffer-B tmp-buffer)
- (ediff-copy-to-buffer beg-B end-B buffer-B tmp-buffer))
- (setq file-B (ediff-make-temp-file tmp-buffer "regB"))
-
- (setq overl-A (ediff-make-bullet-proof-overlay beg-A end-A buffer-A))
- (setq overl-B (ediff-make-bullet-proof-overlay beg-B end-B buffer-B))
- (ediff-setup buffer-A file-A
- buffer-B file-B
- nil nil ; buffer & file C
- (cons `(lambda ()
- (delete-file ,file-A)
- (delete-file ,file-B))
- startup-hooks)
- (append
- (list (cons 'ediff-word-mode word-mode)
- (cons 'ediff-narrow-bounds (list overl-A overl-B))
- (cons 'ediff-job-name job-name))
- setup-parameters)))
- (if (and (stringp file-A) (file-exists-p file-A))
- (delete-file file-A))
- (if (and (stringp file-B) (file-exists-p file-B))
- (delete-file file-B)))
- ))
-
-
-;;; Merge files and buffers
-
-;;;###autoload
-(defalias 'ediff-merge 'ediff-merge-files)
-
-(defsubst ediff-merge-on-startup ()
- (ediff-do-merge 0)
- ;; Can't remember why this is here, but it may cause the automatically merged
- ;; buffer to be lost. So, keep the buffer modified.
- ;;(ediff-with-current-buffer ediff-buffer-C
- ;; (set-buffer-modified-p nil))
- )
-
-;;;###autoload
-(defun ediff-merge-files (file-A file-B
- ;; MERGE-BUFFER-FILE is the file to be
- ;; associated with the merge buffer
- &optional startup-hooks merge-buffer-file)
- "Merge two files without ancestor."
- (interactive
- (let ((dir-A (if ediff-use-last-dir
- ediff-last-dir-A
- default-directory))
- dir-B f)
- (list (setq f (ediff-read-file-name
- "File A to merge"
- dir-A
- (ediff-get-default-file-name)
- 'no-dirs))
- (ediff-read-file-name "File B to merge"
- (setq dir-B
- (if ediff-use-last-dir
- ediff-last-dir-B
- (file-name-directory f)))
- (progn
- (ediff-add-to-history
- 'file-name-history
- (ediff-abbreviate-file-name
- (expand-file-name
- (file-name-nondirectory f)
- dir-B)))
- (ediff-get-default-file-name f 1)))
- )))
- (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
- (ediff-files-internal file-A
- (if (file-directory-p file-B)
- (expand-file-name
- (file-name-nondirectory file-A) file-B)
- file-B)
- nil ; file-C
- startup-hooks
- 'ediff-merge-files
- merge-buffer-file))
-
-;;;###autoload
-(defun ediff-merge-files-with-ancestor (file-A file-B file-ancestor
- &optional
- startup-hooks
- ;; MERGE-BUFFER-FILE is the file
- ;; to be associated with the
- ;; merge buffer
- merge-buffer-file)
- "Merge two files with ancestor."
- (interactive
- (let ((dir-A (if ediff-use-last-dir
- ediff-last-dir-A
- default-directory))
- dir-B dir-ancestor f ff)
- (list (setq f (ediff-read-file-name
- "File A to merge"
- dir-A
- (ediff-get-default-file-name)
- 'no-dirs))
- (setq ff (ediff-read-file-name "File B to merge"
- (setq dir-B
- (if ediff-use-last-dir
- ediff-last-dir-B
- (file-name-directory f)))
- (progn
- (ediff-add-to-history
- 'file-name-history
- (ediff-abbreviate-file-name
- (expand-file-name
- (file-name-nondirectory f)
- dir-B)))
- (ediff-get-default-file-name f 1))))
- (ediff-read-file-name "Ancestor file"
- (setq dir-ancestor
- (if ediff-use-last-dir
- ediff-last-dir-ancestor
- (file-name-directory ff)))
- (progn
- (ediff-add-to-history
- 'file-name-history
- (ediff-abbreviate-file-name
- (expand-file-name
- (file-name-nondirectory ff)
- dir-ancestor)))
- (ediff-get-default-file-name ff 2)))
- )))
- (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
- (ediff-files-internal file-A
- (if (file-directory-p file-B)
- (expand-file-name
- (file-name-nondirectory file-A) file-B)
- file-B)
- file-ancestor
- startup-hooks
- 'ediff-merge-files-with-ancestor
- merge-buffer-file))
-
-;;;###autoload
-(defalias 'ediff-merge-with-ancestor 'ediff-merge-files-with-ancestor)
-
-;;;###autoload
-(defun ediff-merge-buffers (buffer-A buffer-B
- &optional
- ;; MERGE-BUFFER-FILE is the file to be
- ;; associated with the merge buffer
- startup-hooks job-name merge-buffer-file)
- "Merge buffers without ancestor."
- (interactive
- (let (bf)
- (list (setq bf (read-buffer "Buffer A to merge: "
- (ediff-other-buffer "") t))
- (read-buffer "Buffer B to merge: "
- (progn
- ;; realign buffers so that two visible bufs will be
- ;; at the top
- (save-window-excursion (other-window 1))
- (ediff-other-buffer bf))
- t))))
-
- (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
- (or job-name (setq job-name 'ediff-merge-buffers))
- (ediff-buffers-internal
- buffer-A buffer-B nil startup-hooks job-name merge-buffer-file))
-
-;;;###autoload
-(defun ediff-merge-buffers-with-ancestor (buffer-A buffer-B buffer-ancestor
- &optional
- startup-hooks
- job-name
- ;; MERGE-BUFFER-FILE is the
- ;; file to be associated
- ;; with the merge buffer
- merge-buffer-file)
- "Merge buffers with ancestor."
- (interactive
- (let (bf bff)
- (list (setq bf (read-buffer "Buffer A to merge: "
- (ediff-other-buffer "") t))
- (setq bff (read-buffer "Buffer B to merge: "
- (progn
- ;; realign buffers so that two visible
- ;; bufs will be at the top
- (save-window-excursion (other-window 1))
- (ediff-other-buffer bf))
- t))
- (read-buffer "Ancestor buffer: "
- (progn
- ;; realign buffers so that three visible
- ;; bufs will be at the top
- (save-window-excursion (other-window 1))
- (ediff-other-buffer (list bf bff)))
- t)
- )))
-
- (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
- (or job-name (setq job-name 'ediff-merge-buffers-with-ancestor))
- (ediff-buffers-internal
- buffer-A buffer-B buffer-ancestor startup-hooks job-name merge-buffer-file))
-
-
-;;;###autoload
-(defun ediff-merge-revisions (&optional file startup-hooks merge-buffer-file)
- ;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer
- "Run Ediff by merging two revisions of a file.
-The file is the optional FILE argument or the file visited by the current
-buffer."
- (interactive)
- (if (stringp file) (find-file file))
- (let (rev1 rev2)
- (setq rev1
- (read-string
- (format
- "Version 1 to merge (default %s's working version): "
- (if (stringp file)
- (file-name-nondirectory file) "current buffer")))
- rev2
- (read-string
- (format
- "Version 2 to merge (default %s): "
- (if (stringp file)
- (file-name-nondirectory file) "current buffer"))))
- (ediff-load-version-control)
- ;; ancestor-revision=nil
- (funcall
- (intern (format "ediff-%S-merge-internal" ediff-version-control-package))
- rev1 rev2 nil startup-hooks merge-buffer-file)))
-
-
-;;;###autoload
-(defun ediff-merge-revisions-with-ancestor (&optional
- file startup-hooks
- ;; MERGE-BUFFER-FILE is the file to
- ;; be associated with the merge
- ;; buffer
- merge-buffer-file)
- "Run Ediff by merging two revisions of a file with a common ancestor.
-The file is the optional FILE argument or the file visited by the current
-buffer."
- (interactive)
- (if (stringp file) (find-file file))
- (let (rev1 rev2 ancestor-rev)
- (setq rev1
- (read-string
- (format
- "Version 1 to merge (default %s's working version): "
- (if (stringp file)
- (file-name-nondirectory file) "current buffer")))
- rev2
- (read-string
- (format
- "Version 2 to merge (default %s): "
- (if (stringp file)
- (file-name-nondirectory file) "current buffer")))
- ancestor-rev
- (read-string
- (format
- "Ancestor version (default %s's base revision): "
- (if (stringp file)
- (file-name-nondirectory file) "current buffer"))))
- (ediff-load-version-control)
- (funcall
- (intern (format "ediff-%S-merge-internal" ediff-version-control-package))
- rev1 rev2 ancestor-rev startup-hooks merge-buffer-file)))
-
-;;; Apply patch
-
-;;;###autoload
-(defun ediff-patch-file (&optional arg patch-buf)
- "Run Ediff by patching SOURCE-FILENAME.
-If optional PATCH-BUF is given, use the patch in that buffer
-and don't ask the user.
-If prefix argument, then: if even argument, assume that the patch is in a
-buffer. If odd -- assume it is in a file."
- (interactive "P")
- (let (source-dir source-file)
- (require 'ediff-ptch)
- (setq patch-buf
- (ediff-get-patch-buffer
- (if arg (prefix-numeric-value arg)) patch-buf))
- (setq source-dir (cond (ediff-use-last-dir ediff-last-dir-patch)
- ((and (not ediff-patch-default-directory)
- (buffer-file-name patch-buf))
- (file-name-directory
- (expand-file-name
- (buffer-file-name patch-buf))))
- (t default-directory)))
- (setq source-file
- (read-file-name
- "File to patch (directory, if multifile patch): "
- ;; use an explicit initial file
- source-dir nil nil (ediff-get-default-file-name)))
- (ediff-dispatch-file-patching-job patch-buf source-file)))
-
-;;;###autoload
-(defun ediff-patch-buffer (&optional arg patch-buf)
- "Run Ediff by patching the buffer specified at prompt.
-Without the optional prefix ARG, asks if the patch is in some buffer and
-prompts for the buffer or a file, depending on the answer.
-With ARG=1, assumes the patch is in a file and prompts for the file.
-With ARG=2, assumes the patch is in a buffer and prompts for the buffer.
-PATCH-BUF is an optional argument, which specifies the buffer that contains the
-patch. If not given, the user is prompted according to the prefix argument."
- (interactive "P")
- (require 'ediff-ptch)
- (setq patch-buf
- (ediff-get-patch-buffer
- (if arg (prefix-numeric-value arg)) patch-buf))
- (ediff-patch-buffer-internal
- patch-buf
- (read-buffer
- "Which buffer to patch? "
- (ediff-other-buffer patch-buf))))
-
-
-;;;###autoload
-(defalias 'epatch 'ediff-patch-file)
-;;;###autoload
-(defalias 'epatch-buffer 'ediff-patch-buffer)
-
-
-
-\f
-;;; Versions Control functions
-
-;;;###autoload
-(defun ediff-revision (&optional file startup-hooks)
- "Run Ediff by comparing versions of a file.
-The file is an optional FILE argument or the file entered at the prompt.
-Default: the file visited by the current buffer.
-Uses `vc.el' or `rcs.el' depending on `ediff-version-control-package'."
- ;; if buffer is non-nil, use that buffer instead of the current buffer
- (interactive "P")
- (if (not (stringp file))
- (setq file
- (ediff-read-file-name "Compare revisions for file"
- (if ediff-use-last-dir
- ediff-last-dir-A
- default-directory)
- (ediff-get-default-file-name)
- 'no-dirs)))
- (find-file file)
- (if (and (buffer-modified-p)
- (y-or-n-p (format "Buffer %s is modified. Save buffer? "
- (buffer-name))))
- (save-buffer (current-buffer)))
- (let (rev1 rev2)
- (setq rev1
- (read-string
- (format "Revision 1 to compare (default %s's latest revision): "
- (file-name-nondirectory file)))
- rev2
- (read-string
- (format "Revision 2 to compare (default %s's current state): "
- (file-name-nondirectory file))))
- (ediff-load-version-control)
- (funcall
- (intern (format "ediff-%S-internal" ediff-version-control-package))
- rev1 rev2 startup-hooks)
- ))
-
-
-;;;###autoload
-(defalias 'erevision 'ediff-revision)
-
-
-;; Test if version control package is loaded and load if not
-;; Is SILENT is non-nil, don't report error if package is not found.
-(defun ediff-load-version-control (&optional silent)
- (require 'ediff-vers)
- (or (featurep ediff-version-control-package)
- (if (locate-library (symbol-name ediff-version-control-package))
- (progn
- (message "") ; kill the message from `locate-library'
- (require ediff-version-control-package))
- (or silent
- (error "Version control package %S.el not found. Use vc.el instead"
- ediff-version-control-package)))))
-
-
-;;;###autoload
-(defun ediff-version ()
- "Return string describing the version of Ediff.
-When called interactively, displays the version."
- (interactive)
- ;; called-interactively-p - not in XEmacs
- ;; (if (called-interactively-p 'interactive)
- (if (interactive-p)
- (message "%s" (ediff-version))
- (format "Ediff %s of %s" ediff-version ediff-date)))
-
-;; info is run first, and will autoload info.el.
-(declare-function Info-goto-node "info" (nodename &optional fork))
-
-;;;###autoload
-(defun ediff-documentation (&optional node)
- "Display Ediff's manual.
-With optional NODE, goes to that node."
- (interactive)
- (let ((ctl-window ediff-control-window)
- (ctl-buf ediff-control-buffer))
-
- (ediff-skip-unsuitable-frames)
- (condition-case nil
- (progn
- (pop-to-buffer (get-buffer-create "*info*"))
- (info (if (featurep 'xemacs) "ediff.info" "ediff"))
- (if node
- (Info-goto-node node)
- (message "Type `i' to search for a specific topic"))
- (raise-frame (selected-frame)))
- (error (beep 1)
- (with-output-to-temp-buffer ediff-msg-buffer
- (ediff-with-current-buffer standard-output
- (fundamental-mode))
- (princ ediff-BAD-INFO))
- (if (window-live-p ctl-window)
- (progn
- (select-window ctl-window)
- (set-window-buffer ctl-window ctl-buf)))))))
-
-
-(dolist (mess '("^Errors in diff output. Diff output is in "
- "^Hmm... I don't see an Ediff command around here...$"
- "^Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer$"
- ": This command runs in Ediff Control Buffer only!$"
- ": Invalid op in ediff-check-version$"
- "^ediff-shrink-window-C can be used only for merging jobs$"
- "^Lost difference info on these directories$"
- "^This command is inapplicable in the present context$"
- "^This session group has no parent$"
- "^Can't hide active session, $"
- "^Ediff: something wrong--no multiple diffs buffer$"
- "^Can't make context diff for Session $"
- "^The patch buffer wasn't found$"
- "^Aborted$"
- "^This Ediff session is not part of a session group$"
- "^No active Ediff sessions or corrupted session registry$"
- "^No session info in this line$"
- "^`.*' is not an ordinary file$"
- "^Patch appears to have failed$"
- "^Recomputation of differences cancelled$"
- "^No fine differences in this mode$"
- "^Lost connection to ancestor buffer...sorry$"
- "^Not merging with ancestor$"
- "^Don't know how to toggle read-only in buffer "
- "Emacs is not running as a window application$"
- "^This command makes sense only when merging with an ancestor$"
- "^At end of the difference list$"
- "^At beginning of the difference list$"
- "^Nothing saved for diff .* in buffer "
- "^Buffer is out of sync for file "
- "^Buffer out of sync for file "
- "^Output from `diff' not found$"
- "^You forgot to specify a region in buffer "
- "^All right. Make up your mind and come back...$"
- "^Current buffer is not visiting any file$"
- "^Failed to retrieve revision: $"
- "^Can't determine display width.$"
- "^File `.*' does not exist or is not readable$"
- "^File `.*' is a directory$"
- "^Buffer .* doesn't exist$"
- "^Directories . and . are the same: "
- "^Directory merge aborted$"
- "^Merge of directory revisions aborted$"
- "^Buffer .* doesn't exist$"
- "^There is no file to merge$"
- "^Version control package .*.el not found. Use vc.el instead$"))
- (add-to-list 'debug-ignored-errors mess))
-
-
-(require 'ediff-util)
-
-(run-hooks 'ediff-load-hook)
-
-
-;; Local Variables:
-;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
-;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
-;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
-;; End:
-
-;; arch-tag: 97c71396-db02-4f41-8b48-6a51c3348fcc
-;;; ediff.el ends here
+++ /dev/null
-;;; emerge.el --- merge diffs under Emacs control
-
-;;; The author has placed this file in the public domain.
-
-;; This file is part of GNU Emacs.
-
-;; Author: Dale R. Worley <worley@world.std.com>
-;; Keywords: unix, tools
-
-;; This software was created by Dale R. Worley and is
-;; distributed free of charge. It is placed in the public domain and
-;; permission is granted to anyone to use, duplicate, modify and redistribute
-;; it provided that this notice is attached.
-
-;; Dale R. Worley provides absolutely NO WARRANTY OF ANY KIND
-;; with respect to this software. The entire risk as to the quality and
-;; performance of this software is with the user. IN NO EVENT WILL DALE
-;; R. WORLEY BE LIABLE TO ANYONE FOR ANY DAMAGES ARISING OUT THE
-;; USE OF THIS SOFTWARE, INCLUDING, WITHOUT LIMITATION, DAMAGES RESULTING FROM
-;; LOST DATA OR LOST PROFITS, OR FOR ANY SPECIAL, INCIDENTAL OR CONSEQUENTIAL
-;; DAMAGES.
-
-;;; Commentary:
-
-;;; Code:
-
-;; There aren't really global variables, just dynamic bindings
-(defvar A-begin)
-(defvar A-end)
-(defvar B-begin)
-(defvar B-end)
-(defvar diff)
-(defvar diff-vector)
-(defvar merge-begin)
-(defvar merge-end)
-(defvar template)
-(defvar valid-diff)
-
-;;; Macros
-
-(defmacro emerge-eval-in-buffer (buffer &rest forms)
- "Macro to switch to BUFFER, evaluate FORMS, returns to original buffer.
-Differs from `save-excursion' in that it doesn't save the point and mark."
- `(let ((StartBuffer (current-buffer)))
- (unwind-protect
- (progn
- (set-buffer ,buffer)
- ,@forms)
- (set-buffer StartBuffer))))
-
-(defmacro emerge-defvar-local (var value doc)
- "Defines SYMBOL as an advertised variable.
-Performs a defvar, then executes `make-variable-buffer-local' on
-the variable. Also sets the `preserved' property, so that
-`kill-all-local-variables' (called by major-mode setting commands)
-won't destroy Emerge control variables."
- `(progn
- (defvar ,var ,value ,doc)
- (make-variable-buffer-local ',var)
- (put ',var 'preserved t)))
-
-;; Add entries to minor-mode-alist so that emerge modes show correctly
-(defvar emerge-minor-modes-list
- '((emerge-mode " Emerge")
- (emerge-fast-mode " F")
- (emerge-edit-mode " E")
- (emerge-auto-advance " A")
- (emerge-skip-prefers " S")))
-(if (not (assq 'emerge-mode minor-mode-alist))
- (setq minor-mode-alist (append emerge-minor-modes-list
- minor-mode-alist)))
-
-;; We need to define this function so describe-mode can describe Emerge mode.
-(defun emerge-mode ()
- "Emerge mode is used by the Emerge file-merging package.
-It is entered only through one of the functions:
- `emerge-files'
- `emerge-files-with-ancestor'
- `emerge-buffers'
- `emerge-buffers-with-ancestor'
- `emerge-files-command'
- `emerge-files-with-ancestor-command'
- `emerge-files-remote'
- `emerge-files-with-ancestor-remote'
-
-Commands:
-\\{emerge-basic-keymap}
-Commands must be prefixed by \\<emerge-fast-keymap>\\[emerge-basic-keymap] in `edit' mode,
-but can be invoked directly in `fast' mode.")
-
-(define-obsolete-variable-alias 'emerge-version 'emacs-version "23.2")
-
-(defun emerge-version ()
- "Return string describing the version of Emerge.
-When called interactively, displays the version."
- (interactive)
- (if (called-interactively-p 'interactive)
- (message "Emerge version %s" emacs-version)
- emacs-version))
-
-(make-obsolete 'emerge-version 'emacs-version "23.2")
-
-;;; Emerge configuration variables
-
-(defgroup emerge nil
- "Merge diffs under Emacs control."
- :group 'tools)
-
-;; Commands that produce difference files
-;; All that can be configured is the name of the programs to execute
-;; (emerge-diff-program and emerge-diff3-program) and the options
-;; to be provided (emerge-diff-options). The order in which the file names
-;; are given is fixed.
-;; The file names are always expanded (see expand-file-name) before being
-;; passed to diff, thus they need not be invoked under a shell that
-;; understands `~'.
-;; The code which processes the diff/diff3 output depends on all the
-;; finicky details of their output, including the somewhat strange
-;; way they number lines of a file.
-(defcustom emerge-diff-program "diff"
- "Name of the program which compares two files."
- :type 'string
- :group 'emerge)
-(defcustom emerge-diff3-program "diff3"
- "Name of the program which compares three files.
-Its arguments are the ancestor file and the two variant files."
- :type 'string
- :group 'emerge)
-(defcustom emerge-diff-options ""
- "Options to pass to `emerge-diff-program' and `emerge-diff3-program'."
- :type 'string
- :group 'emerge)
-(defcustom emerge-match-diff-line
- (let ((x "\\([0-9]+\\)\\(\\|,\\([0-9]+\\)\\)"))
- (concat "^" x "\\([acd]\\)" x "$"))
- "Pattern to match lines produced by diff that describe differences.
-This is as opposed to lines from the source files."
- :type 'regexp
- :group 'emerge)
-(defcustom emerge-diff-ok-lines-regexp
- "^\\([0-9,]+[acd][0-9,]+$\\|[<>] \\|---\\)"
- "Regexp that matches normal output lines from `emerge-diff-program'.
-Lines that do not match are assumed to be error messages."
- :type 'regexp
- :group 'emerge)
-(defcustom emerge-diff3-ok-lines-regexp
- "^\\([1-3]:\\|====\\| \\)"
- "Regexp that matches normal output lines from `emerge-diff3-program'.
-Lines that do not match are assumed to be error messages."
- :type 'regexp
- :group 'emerge)
-
-(defcustom emerge-rcs-ci-program "ci"
- "Name of the program that checks in RCS revisions."
- :type 'string
- :group 'emerge)
-(defcustom emerge-rcs-co-program "co"
- "Name of the program that checks out RCS revisions."
- :type 'string
- :group 'emerge)
-
-(defcustom emerge-process-local-variables nil
- "Non-nil if Emerge should process local-variables lists in merge buffers.
-\(You can explicitly request processing the local-variables
-by executing `(hack-local-variables)'.)"
- :type 'boolean
- :group 'emerge)
-(defcustom emerge-execute-line-deletions nil
- "If non-nil: `emerge-execute-line' makes no output if an input was deleted.
-It concludes that an input version has been deleted when an ancestor entry
-is present, only one A or B entry is present, and an output entry is present.
-If nil: In such circumstances, the A or B file that is present will be
-copied to the designated output file."
- :type 'boolean
- :group 'emerge)
-
-(defcustom emerge-before-flag "vvvvvvvvvvvvvvvvvvvv\n"
- "Flag placed above the highlighted block of code. Must end with newline.
-Must be set before Emerge is loaded, or emerge-new-flags must be run
-after setting."
- :type 'string
- :group 'emerge)
-(defcustom emerge-after-flag "^^^^^^^^^^^^^^^^^^^^\n"
- "Flag placed below the highlighted block of code. Must end with newline.
-Must be set before Emerge is loaded, or emerge-new-flags must be run
-after setting."
- :type 'string
- :group 'emerge)
-
-;; Hook variables
-
-(defcustom emerge-startup-hook nil
- "Hook to run in the merge buffer after the merge has been set up."
- :type 'hook
- :group 'emerge)
-(defcustom emerge-select-hook nil
- "Hook to run after a difference has been selected.
-The variable `n' holds the (internal) number of the difference."
- :type 'hook
- :group 'emerge)
-(defcustom emerge-unselect-hook nil
- "Hook to run after a difference has been unselected.
-The variable `n' holds the (internal) number of the difference."
- :type 'hook
- :group 'emerge)
-
-;; Variables to control the default directories of the arguments to
-;; Emerge commands.
-
-(defcustom emerge-default-last-directories nil
- "If nil, default dir for filenames in emerge is `default-directory'.
-If non-nil, filenames complete in the directory of the last argument of the
-same type to an `emerge-files...' command."
- :type 'boolean
- :group 'emerge)
-
-(defvar emerge-last-dir-A nil
- "Last directory for the first file of an `emerge-files...' command.")
-(defvar emerge-last-dir-B nil
- "Last directory for the second file of an `emerge-files...' command.")
-(defvar emerge-last-dir-ancestor nil
- "Last directory for the ancestor file of an `emerge-files...' command.")
-(defvar emerge-last-dir-output nil
- "Last directory for the output file of an `emerge-files...' command.")
-(defvar emerge-last-revision-A nil
- "Last RCS revision used for first file of an `emerge-revisions...' command.")
-(defvar emerge-last-revision-B nil
- "Last RCS revision used for second file of an `emerge-revisions...' command.")
-(defvar emerge-last-revision-ancestor nil
- "Last RCS revision used for ancestor file of an `emerge-revisions...' command.")
-
-(defvar emerge-before-flag-length)
-(defvar emerge-before-flag-lines)
-(defvar emerge-before-flag-match)
-(defvar emerge-after-flag-length)
-(defvar emerge-after-flag-lines)
-(defvar emerge-after-flag-match)
-(defvar emerge-diff-buffer)
-(defvar emerge-diff-error-buffer)
-(defvar emerge-prefix-argument)
-(defvar emerge-file-out)
-(defvar emerge-exit-func)
-(defvar emerge-globalized-difference-list)
-(defvar emerge-globalized-number-of-differences)
-
-;; The flags used to mark differences in the buffers.
-
-;; These function definitions need to be up here, because they are used
-;; during loading.
-(defun emerge-new-flags ()
- "Function to be called after `emerge-{before,after}-flag'.
-This is called after these functions are changed to compute values that
-depend on the flags."
- (setq emerge-before-flag-length (length emerge-before-flag))
- (setq emerge-before-flag-lines
- (emerge-count-matches-string emerge-before-flag "\n"))
- (setq emerge-before-flag-match (regexp-quote emerge-before-flag))
- (setq emerge-after-flag-length (length emerge-after-flag))
- (setq emerge-after-flag-lines
- (emerge-count-matches-string emerge-after-flag "\n"))
- (setq emerge-after-flag-match (regexp-quote emerge-after-flag)))
-
-(defun emerge-count-matches-string (string regexp)
- "Return the number of matches in STRING for REGEXP."
- (let ((i 0)
- (count 0))
- (while (string-match regexp string i)
- (setq count (1+ count))
- (setq i (match-end 0)))
- count))
-
-;; Calculate dependent variables
-(emerge-new-flags)
-
-(defcustom emerge-min-visible-lines 3
- "Number of lines that we want to show above and below the flags when we are
-displaying a difference."
- :type 'integer
- :group 'emerge)
-
-(defcustom emerge-temp-file-prefix
- (expand-file-name "emerge" temporary-file-directory)
- "Prefix to put on Emerge temporary file names.
-Do not start with `~/' or `~USERNAME/'."
- :type 'string
- :group 'emerge)
-
-(defcustom emerge-temp-file-mode 384 ; u=rw only
- "Mode for Emerge temporary files."
- :type 'integer
- :group 'emerge)
-
-(defcustom emerge-combine-versions-template
- "#ifdef NEW\n%b#else /* not NEW */\n%a#endif /* not NEW */\n"
- "Template for `emerge-combine-versions' to combine the two versions.
-The template is inserted as a string, with the following interpolations:
- %a the A version of the difference
- %b the B version of the difference
- %% the character `%'
-Don't forget to end the template with a newline.
-Note that this variable can be made local to a particular merge buffer by
-giving a prefix argument to `emerge-set-combine-versions-template'."
- :type 'string
- :group 'emerge)
-
-;; Build keymaps
-
-(defvar emerge-basic-keymap nil
- "Keymap of Emerge commands.
-Directly available in `fast' mode;
-must be prefixed by \\<emerge-fast-keymap>\\[emerge-basic-keymap] in `edit' mode.")
-
-(defvar emerge-fast-keymap nil
- "Local keymap used in Emerge `fast' mode.
-Makes Emerge commands directly available.")
-
-(defvar emerge-options-menu
- (make-sparse-keymap "Options"))
-
-(defvar emerge-merge-menu
- (make-sparse-keymap "Merge"))
-
-(defvar emerge-move-menu
- (make-sparse-keymap "Move"))
-
-(defcustom emerge-command-prefix "\C-c\C-c"
- "Command prefix for Emerge commands in `edit' mode.
-Must be set before Emerge is loaded."
- :type 'string
- :group 'emerge)
-
-;; This function sets up the fixed keymaps. It is executed when the first
-;; Emerge is done to allow the user maximum time to set up the global keymap.
-(defun emerge-setup-fixed-keymaps ()
- ;; Set up the basic keymap
- (setq emerge-basic-keymap (make-keymap))
- (suppress-keymap emerge-basic-keymap) ; this sets 0..9 to digit-argument and
- ; - to negative-argument
- (define-key emerge-basic-keymap "p" 'emerge-previous-difference)
- (define-key emerge-basic-keymap "n" 'emerge-next-difference)
- (define-key emerge-basic-keymap "a" 'emerge-select-A)
- (define-key emerge-basic-keymap "b" 'emerge-select-B)
- (define-key emerge-basic-keymap "j" 'emerge-jump-to-difference)
- (define-key emerge-basic-keymap "." 'emerge-find-difference)
- (define-key emerge-basic-keymap "q" 'emerge-quit)
- (define-key emerge-basic-keymap "\C-]" 'emerge-abort)
- (define-key emerge-basic-keymap "f" 'emerge-fast-mode)
- (define-key emerge-basic-keymap "e" 'emerge-edit-mode)
- (define-key emerge-basic-keymap "s" nil)
- (define-key emerge-basic-keymap "sa" 'emerge-auto-advance)
- (define-key emerge-basic-keymap "ss" 'emerge-skip-prefers)
- (define-key emerge-basic-keymap "l" 'emerge-recenter)
- (define-key emerge-basic-keymap "d" nil)
- (define-key emerge-basic-keymap "da" 'emerge-default-A)
- (define-key emerge-basic-keymap "db" 'emerge-default-B)
- (define-key emerge-basic-keymap "c" nil)
- (define-key emerge-basic-keymap "ca" 'emerge-copy-as-kill-A)
- (define-key emerge-basic-keymap "cb" 'emerge-copy-as-kill-B)
- (define-key emerge-basic-keymap "i" nil)
- (define-key emerge-basic-keymap "ia" 'emerge-insert-A)
- (define-key emerge-basic-keymap "ib" 'emerge-insert-B)
- (define-key emerge-basic-keymap "m" 'emerge-mark-difference)
- (define-key emerge-basic-keymap "v" 'emerge-scroll-up)
- (define-key emerge-basic-keymap "^" 'emerge-scroll-down)
- (define-key emerge-basic-keymap "<" 'emerge-scroll-left)
- (define-key emerge-basic-keymap ">" 'emerge-scroll-right)
- (define-key emerge-basic-keymap "|" 'emerge-scroll-reset)
- (define-key emerge-basic-keymap "x" nil)
- (define-key emerge-basic-keymap "x1" 'emerge-one-line-window)
- (define-key emerge-basic-keymap "xc" 'emerge-combine-versions)
- (define-key emerge-basic-keymap "xC" 'emerge-combine-versions-register)
- (define-key emerge-basic-keymap "xf" 'emerge-file-names)
- (define-key emerge-basic-keymap "xj" 'emerge-join-differences)
- (define-key emerge-basic-keymap "xl" 'emerge-line-numbers)
- (define-key emerge-basic-keymap "xm" 'emerge-set-merge-mode)
- (define-key emerge-basic-keymap "xs" 'emerge-split-difference)
- (define-key emerge-basic-keymap "xt" 'emerge-trim-difference)
- (define-key emerge-basic-keymap "xx" 'emerge-set-combine-versions-template)
- ;; Allow emerge-basic-keymap to be referenced indirectly
- (fset 'emerge-basic-keymap emerge-basic-keymap)
- ;; Set up the fast mode keymap
- (setq emerge-fast-keymap (copy-keymap emerge-basic-keymap))
- ;; Allow prefixed commands to work in fast mode
- (define-key emerge-fast-keymap emerge-command-prefix 'emerge-basic-keymap)
- ;; Allow emerge-fast-keymap to be referenced indirectly
- (fset 'emerge-fast-keymap emerge-fast-keymap)
- ;; Suppress write-file and save-buffer
- (define-key emerge-fast-keymap [remap write-file] 'emerge-query-write-file)
- (define-key emerge-fast-keymap [remap save-buffer] 'emerge-query-save-buffer)
-
- (define-key emerge-basic-keymap [menu-bar] (make-sparse-keymap))
-
- (define-key emerge-fast-keymap [menu-bar emerge-options]
- (cons "Merge-Options" emerge-options-menu))
- (define-key emerge-fast-keymap [menu-bar merge]
- (cons "Merge" emerge-merge-menu))
- (define-key emerge-fast-keymap [menu-bar move]
- (cons "Move" emerge-move-menu))
-
- (define-key emerge-move-menu [emerge-scroll-reset]
- '("Scroll Reset" . emerge-scroll-reset))
- (define-key emerge-move-menu [emerge-scroll-right]
- '("Scroll Right" . emerge-scroll-right))
- (define-key emerge-move-menu [emerge-scroll-left]
- '("Scroll Left" . emerge-scroll-left))
- (define-key emerge-move-menu [emerge-scroll-down]
- '("Scroll Down" . emerge-scroll-down))
- (define-key emerge-move-menu [emerge-scroll-up]
- '("Scroll Up" . emerge-scroll-up))
- (define-key emerge-move-menu [emerge-recenter]
- '("Recenter" . emerge-recenter))
- (define-key emerge-move-menu [emerge-mark-difference]
- '("Mark Difference" . emerge-mark-difference))
- (define-key emerge-move-menu [emerge-jump-to-difference]
- '("Jump To Difference" . emerge-jump-to-difference))
- (define-key emerge-move-menu [emerge-find-difference]
- '("Find Difference" . emerge-find-difference))
- (define-key emerge-move-menu [emerge-previous-difference]
- '("Previous Difference" . emerge-previous-difference))
- (define-key emerge-move-menu [emerge-next-difference]
- '("Next Difference" . emerge-next-difference))
-
-
- (define-key emerge-options-menu [emerge-one-line-window]
- '("One Line Window" . emerge-one-line-window))
- (define-key emerge-options-menu [emerge-set-merge-mode]
- '("Set Merge Mode..." . emerge-set-merge-mode))
- (define-key emerge-options-menu [emerge-set-combine-template]
- '("Set Combine Template..." . emerge-set-combine-template))
- (define-key emerge-options-menu [emerge-default-B]
- '("Default B" . emerge-default-B))
- (define-key emerge-options-menu [emerge-default-A]
- '("Default A" . emerge-default-A))
- (define-key emerge-options-menu [emerge-skip-prefers]
- '(menu-item "Skip Prefers" emerge-skip-prefers
- :button (:toggle . emerge-skip-prefers)))
- (define-key emerge-options-menu [emerge-auto-advance]
- '(menu-item "Auto Advance" emerge-auto-advance
- :button (:toggle . emerge-auto-advance)))
- (define-key emerge-options-menu [emerge-edit-mode]
- '(menu-item "Edit Mode" emerge-edit-mode :enable (not emerge-edit-mode)))
- (define-key emerge-options-menu [emerge-fast-mode]
- '(menu-item "Fast Mode" emerge-fast-mode :enable (not emerge-fast-mode)))
-
- (define-key emerge-merge-menu [emerge-abort] '("Abort" . emerge-abort))
- (define-key emerge-merge-menu [emerge-quit] '("Quit" . emerge-quit))
- (define-key emerge-merge-menu [emerge-split-difference]
- '("Split Difference" . emerge-split-difference))
- (define-key emerge-merge-menu [emerge-join-differences]
- '("Join Differences" . emerge-join-differences))
- (define-key emerge-merge-menu [emerge-trim-difference]
- '("Trim Difference" . emerge-trim-difference))
- (define-key emerge-merge-menu [emerge-combine-versions]
- '("Combine Versions" . emerge-combine-versions))
- (define-key emerge-merge-menu [emerge-copy-as-kill-B]
- '("Copy B as Kill" . emerge-copy-as-kill-B))
- (define-key emerge-merge-menu [emerge-copy-as-kill-A]
- '("Copy A as Kill" . emerge-copy-as-kill-A))
- (define-key emerge-merge-menu [emerge-insert-B]
- '("Insert B" . emerge-insert-B))
- (define-key emerge-merge-menu [emerge-insert-A]
- '("Insert A" . emerge-insert-A))
- (define-key emerge-merge-menu [emerge-select-B]
- '("Select B" . emerge-select-B))
- (define-key emerge-merge-menu [emerge-select-A]
- '("Select A" . emerge-select-A)))
-
-
-;; Variables which control each merge. They are local to the merge buffer.
-
-;; Mode variables
-(emerge-defvar-local emerge-mode nil
- "Indicator for emerge-mode.")
-(emerge-defvar-local emerge-fast-mode nil
- "Indicator for emerge-mode fast submode.")
-(emerge-defvar-local emerge-edit-mode nil
- "Indicator for emerge-mode edit submode.")
-(emerge-defvar-local emerge-A-buffer nil
- "The buffer in which the A variant is stored.")
-(emerge-defvar-local emerge-B-buffer nil
- "The buffer in which the B variant is stored.")
-(emerge-defvar-local emerge-merge-buffer nil
- "The buffer in which the merged file is manipulated.")
-(emerge-defvar-local emerge-ancestor-buffer nil
- "The buffer in which the ancestor variant is stored,
-or nil if there is none.")
-
-(defconst emerge-saved-variables
- '((buffer-modified-p set-buffer-modified-p)
- buffer-read-only
- buffer-auto-save-file-name)
- "Variables and properties of a buffer which are saved, modified and restored
-during a merge.")
-(defconst emerge-merging-values '(nil t nil)
- "Values to be assigned to emerge-saved-variables during a merge.")
-
-(emerge-defvar-local emerge-A-buffer-values nil
- "Remembers emerge-saved-variables for emerge-A-buffer.")
-(emerge-defvar-local emerge-B-buffer-values nil
- "Remembers emerge-saved-variables for emerge-B-buffer.")
-
-(emerge-defvar-local emerge-difference-list nil
- "Vector of differences between the variants, and markers in the buffers to
-show where they are. Each difference is represented by a vector of seven
-elements. The first two are markers to the beginning and end of the difference
-section in the A buffer, the second two are markers for the B buffer, the third
-two are markers for the merge buffer, and the last element is the \"state\" of
-that difference in the merge buffer.
- A section of a buffer is described by two markers, one to the beginning of
-the first line of the section, and one to the beginning of the first line
-after the section. (If the section is empty, both markers point to the same
-point.) If the section is part of the selected difference, then the markers
-are moved into the flags, so the user can edit the section without disturbing
-the markers.
- The \"states\" are:
- A the merge buffer currently contains the A variant
- B the merge buffer currently contains the B variant
- default-A the merge buffer contains the A variant by default,
- but this difference hasn't been selected yet, so
- change-default commands can alter it
- default-B the merge buffer contains the B variant by default,
- but this difference hasn't been selected yet, so
- change-default commands can alter it
- prefer-A in a three-file merge, the A variant is the preferred
- choice
- prefer-B in a three-file merge, the B variant is the preferred
- choice")
-(emerge-defvar-local emerge-current-difference -1
- "The difference that is currently selected.")
-(emerge-defvar-local emerge-number-of-differences nil
- "Number of differences found.")
-(emerge-defvar-local emerge-edit-keymap nil
- "The local keymap for the merge buffer, with the emerge commands defined in
-it. Used to save the local keymap during fast mode, when the local keymap is
-replaced by emerge-fast-keymap.")
-(emerge-defvar-local emerge-old-keymap nil
- "The original local keymap for the merge buffer.")
-(emerge-defvar-local emerge-auto-advance nil
- "*If non-nil, emerge-select-A and emerge-select-B automatically advance to
-the next difference.")
-(emerge-defvar-local emerge-skip-prefers nil
- "*If non-nil, differences for which there is a preference are automatically
-skipped.")
-(emerge-defvar-local emerge-quit-hook nil
- "Hooks to run in the merge buffer after the merge has been finished.
-`emerge-prefix-argument' will hold the prefix argument of the `emerge-quit'
-command.
-This is *not* a user option, since Emerge uses it for its own processing.")
-(emerge-defvar-local emerge-output-description nil
- "Describes output destination of emerge, for `emerge-file-names'.")
-
-;;; Setup functions for two-file mode.
-
-(defun emerge-files-internal (file-A file-B &optional startup-hooks quit-hooks
- output-file)
- (if (not (file-readable-p file-A))
- (error "File `%s' does not exist or is not readable" file-A))
- (if (not (file-readable-p file-B))
- (error "File `%s' does not exist or is not readable" file-B))
- (let ((buffer-A (find-file-noselect file-A))
- (buffer-B (find-file-noselect file-B)))
- ;; Record the directories of the files
- (setq emerge-last-dir-A (file-name-directory file-A))
- (setq emerge-last-dir-B (file-name-directory file-B))
- (if output-file
- (setq emerge-last-dir-output (file-name-directory output-file)))
- ;; Make sure the entire files are seen, and they reflect what is on disk
- (emerge-eval-in-buffer
- buffer-A
- (widen)
- (let ((temp (file-local-copy file-A)))
- (if temp
- (setq file-A temp
- startup-hooks
- (cons `(lambda () (delete-file ,file-A))
- startup-hooks))
- ;; Verify that the file matches the buffer
- (emerge-verify-file-buffer))))
- (emerge-eval-in-buffer
- buffer-B
- (widen)
- (let ((temp (file-local-copy file-B)))
- (if temp
- (setq file-B temp
- startup-hooks
- (cons `(lambda () (delete-file ,file-B))
- startup-hooks))
- ;; Verify that the file matches the buffer
- (emerge-verify-file-buffer))))
- (emerge-setup buffer-A file-A buffer-B file-B startup-hooks quit-hooks
- output-file)))
-
-;; Start up Emerge on two files
-(defun emerge-setup (buffer-A file-A buffer-B file-B startup-hooks quit-hooks
- output-file)
- (setq file-A (expand-file-name file-A))
- (setq file-B (expand-file-name file-B))
- (setq output-file (and output-file (expand-file-name output-file)))
- (let* ((merge-buffer-name (emerge-unique-buffer-name "*merge" "*"))
- ;; create the merge buffer from buffer A, so it inherits buffer A's
- ;; default directory, etc.
- (merge-buffer (emerge-eval-in-buffer
- buffer-A
- (get-buffer-create merge-buffer-name))))
- (emerge-eval-in-buffer
- merge-buffer
- (emerge-copy-modes buffer-A)
- (setq buffer-read-only nil)
- (auto-save-mode 1)
- (setq emerge-mode t)
- (setq emerge-A-buffer buffer-A)
- (setq emerge-B-buffer buffer-B)
- (setq emerge-ancestor-buffer nil)
- (setq emerge-merge-buffer merge-buffer)
- (setq emerge-output-description
- (if output-file
- (concat "Output to file: " output-file)
- (concat "Output to buffer: " (buffer-name merge-buffer))))
- (save-excursion (insert-buffer-substring emerge-A-buffer))
- (emerge-set-keys)
- (setq emerge-difference-list (emerge-make-diff-list file-A file-B))
- (setq emerge-number-of-differences (length emerge-difference-list))
- (setq emerge-current-difference -1)
- (setq emerge-quit-hook quit-hooks)
- (emerge-remember-buffer-characteristics)
- (emerge-handle-local-variables))
- (emerge-setup-windows buffer-A buffer-B merge-buffer t)
- (emerge-eval-in-buffer merge-buffer
- (run-hooks 'startup-hooks 'emerge-startup-hook)
- (setq buffer-read-only t))))
-
-;; Generate the Emerge difference list between two files
-(defun emerge-make-diff-list (file-A file-B)
- (setq emerge-diff-buffer (get-buffer-create "*emerge-diff*"))
- (emerge-eval-in-buffer
- emerge-diff-buffer
- (erase-buffer)
- (shell-command
- (format "%s %s %s %s"
- emerge-diff-program emerge-diff-options
- (emerge-protect-metachars file-A)
- (emerge-protect-metachars file-B))
- t))
- (emerge-prepare-error-list emerge-diff-ok-lines-regexp)
- (emerge-convert-diffs-to-markers
- emerge-A-buffer emerge-B-buffer emerge-merge-buffer
- (emerge-extract-diffs emerge-diff-buffer)))
-
-(defun emerge-extract-diffs (diff-buffer)
- (let (list)
- (emerge-eval-in-buffer
- diff-buffer
- (goto-char (point-min))
- (while (re-search-forward emerge-match-diff-line nil t)
- (let* ((a-begin (string-to-number (buffer-substring (match-beginning 1)
- (match-end 1))))
- (a-end (let ((b (match-beginning 3))
- (e (match-end 3)))
- (if b
- (string-to-number (buffer-substring b e))
- a-begin)))
- (diff-type (buffer-substring (match-beginning 4) (match-end 4)))
- (b-begin (string-to-number (buffer-substring (match-beginning 5)
- (match-end 5))))
- (b-end (let ((b (match-beginning 7))
- (e (match-end 7)))
- (if b
- (string-to-number (buffer-substring b e))
- b-begin))))
- ;; fix the beginning and end numbers, because diff is somewhat
- ;; strange about how it numbers lines
- (if (string-equal diff-type "a")
- (progn
- (setq b-end (1+ b-end))
- (setq a-begin (1+ a-begin))
- (setq a-end a-begin))
- (if (string-equal diff-type "d")
- (progn
- (setq a-end (1+ a-end))
- (setq b-begin (1+ b-begin))
- (setq b-end b-begin))
- ;; (string-equal diff-type "c")
- (progn
- (setq a-end (1+ a-end))
- (setq b-end (1+ b-end)))))
- (setq list (cons (vector a-begin a-end
- b-begin b-end
- 'default-A)
- list)))))
- (nreverse list)))
-
-;; Set up buffer of diff/diff3 error messages.
-(defun emerge-prepare-error-list (ok-regexp)
- (setq emerge-diff-error-buffer (get-buffer-create "*emerge-diff-errors*"))
- (emerge-eval-in-buffer
- emerge-diff-error-buffer
- (erase-buffer)
- (save-excursion (insert-buffer-substring emerge-diff-buffer))
- (delete-matching-lines ok-regexp)))
-
-;;; Top-level and setup functions for three-file mode.
-
-(defun emerge-files-with-ancestor-internal (file-A file-B file-ancestor
- &optional startup-hooks quit-hooks
- output-file)
- (if (not (file-readable-p file-A))
- (error "File `%s' does not exist or is not readable" file-A))
- (if (not (file-readable-p file-B))
- (error "File `%s' does not exist or is not readable" file-B))
- (if (not (file-readable-p file-ancestor))
- (error "File `%s' does not exist or is not readable" file-ancestor))
- (let ((buffer-A (find-file-noselect file-A))
- (buffer-B (find-file-noselect file-B))
- (buffer-ancestor (find-file-noselect file-ancestor)))
- ;; Record the directories of the files
- (setq emerge-last-dir-A (file-name-directory file-A))
- (setq emerge-last-dir-B (file-name-directory file-B))
- (setq emerge-last-dir-ancestor (file-name-directory file-ancestor))
- (if output-file
- (setq emerge-last-dir-output (file-name-directory output-file)))
- ;; Make sure the entire files are seen, and they reflect what is on disk
- (emerge-eval-in-buffer
- buffer-A
- (widen)
- (let ((temp (file-local-copy file-A)))
- (if temp
- (setq file-A temp
- startup-hooks
- (cons `(lambda () (delete-file ,file-A))
- startup-hooks))
- ;; Verify that the file matches the buffer
- (emerge-verify-file-buffer))))
- (emerge-eval-in-buffer
- buffer-B
- (widen)
- (let ((temp (file-local-copy file-B)))
- (if temp
- (setq file-B temp
- startup-hooks
- (cons `(lambda () (delete-file ,file-B))
- startup-hooks))
- ;; Verify that the file matches the buffer
- (emerge-verify-file-buffer))))
- (emerge-eval-in-buffer
- buffer-ancestor
- (widen)
- (let ((temp (file-local-copy file-ancestor)))
- (if temp
- (setq file-ancestor temp
- startup-hooks
- (cons `(lambda () (delete-file ,file-ancestor))
- startup-hooks))
- ;; Verify that the file matches the buffer
- (emerge-verify-file-buffer))))
- (emerge-setup-with-ancestor buffer-A file-A buffer-B file-B
- buffer-ancestor file-ancestor
- startup-hooks quit-hooks output-file)))
-
-;; Start up Emerge on two files with an ancestor
-(defun emerge-setup-with-ancestor (buffer-A file-A buffer-B file-B
- buffer-ancestor file-ancestor
- &optional startup-hooks quit-hooks
- output-file)
- (setq file-A (expand-file-name file-A))
- (setq file-B (expand-file-name file-B))
- (setq file-ancestor (expand-file-name file-ancestor))
- (setq output-file (and output-file (expand-file-name output-file)))
- (let* ((merge-buffer-name (emerge-unique-buffer-name "*merge" "*"))
- ;; create the merge buffer from buffer A, so it inherits buffer A's
- ;; default directory, etc.
- (merge-buffer (emerge-eval-in-buffer
- buffer-A
- (get-buffer-create merge-buffer-name))))
- (emerge-eval-in-buffer
- merge-buffer
- (emerge-copy-modes buffer-A)
- (setq buffer-read-only nil)
- (auto-save-mode 1)
- (setq emerge-mode t)
- (setq emerge-A-buffer buffer-A)
- (setq emerge-B-buffer buffer-B)
- (setq emerge-ancestor-buffer buffer-ancestor)
- (setq emerge-merge-buffer merge-buffer)
- (setq emerge-output-description
- (if output-file
- (concat "Output to file: " output-file)
- (concat "Output to buffer: " (buffer-name merge-buffer))))
- (save-excursion (insert-buffer-substring emerge-A-buffer))
- (emerge-set-keys)
- (setq emerge-difference-list
- (emerge-make-diff3-list file-A file-B file-ancestor))
- (setq emerge-number-of-differences (length emerge-difference-list))
- (setq emerge-current-difference -1)
- (setq emerge-quit-hook quit-hooks)
- (emerge-remember-buffer-characteristics)
- (emerge-select-prefer-Bs)
- (emerge-handle-local-variables))
- (emerge-setup-windows buffer-A buffer-B merge-buffer t)
- (emerge-eval-in-buffer merge-buffer
- (run-hooks 'startup-hooks 'emerge-startup-hook)
- (setq buffer-read-only t))))
-
-;; Generate the Emerge difference list between two files with an ancestor
-(defun emerge-make-diff3-list (file-A file-B file-ancestor)
- (setq emerge-diff-buffer (get-buffer-create "*emerge-diff*"))
- (emerge-eval-in-buffer
- emerge-diff-buffer
- (erase-buffer)
- (shell-command
- (format "%s %s %s %s %s"
- emerge-diff3-program emerge-diff-options
- (emerge-protect-metachars file-A)
- (emerge-protect-metachars file-ancestor)
- (emerge-protect-metachars file-B))
- t))
- (emerge-prepare-error-list emerge-diff3-ok-lines-regexp)
- (emerge-convert-diffs-to-markers
- emerge-A-buffer emerge-B-buffer emerge-merge-buffer
- (emerge-extract-diffs3 emerge-diff-buffer)))
-
-(defun emerge-extract-diffs3 (diff-buffer)
- (let (list)
- (emerge-eval-in-buffer
- diff-buffer
- (while (re-search-forward "^====\\(.?\\)$" nil t)
- ;; leave point after matched line
- (beginning-of-line 2)
- (let ((agreement (buffer-substring (match-beginning 1) (match-end 1))))
- ;; if the A and B files are the same, ignore the difference
- (if (not (string-equal agreement "2"))
- (setq list
- (cons
- (let (group-1 group-3 pos)
- (setq pos (point))
- (setq group-1 (emerge-get-diff3-group "1"))
- (goto-char pos)
- (setq group-3 (emerge-get-diff3-group "3"))
- (vector (car group-1) (car (cdr group-1))
- (car group-3) (car (cdr group-3))
- (cond ((string-equal agreement "1") 'prefer-A)
- ((string-equal agreement "3") 'prefer-B)
- (t 'default-A))))
- list))))))
- (nreverse list)))
-
-(defun emerge-get-diff3-group (file)
- ;; This save-excursion allows emerge-get-diff3-group to be called for the
- ;; various groups of lines (1, 2, 3) in any order, and for the lines to
- ;; appear in any order. The reason this is necessary is that Gnu diff3
- ;; can produce the groups in the order 1, 2, 3 or 1, 3, 2.
- (save-excursion
- (re-search-forward
- (concat "^" file ":\\([0-9]+\\)\\(,\\([0-9]+\\)\\)?\\([ac]\\)$"))
- (beginning-of-line 2)
- ;; treatment depends on whether it is an "a" group or a "c" group
- (if (string-equal (buffer-substring (match-beginning 4) (match-end 4)) "c")
- ;; it is a "c" group
- (if (match-beginning 2)
- ;; it has two numbers
- (list (string-to-number
- (buffer-substring (match-beginning 1) (match-end 1)))
- (1+ (string-to-number
- (buffer-substring (match-beginning 3) (match-end 3)))))
- ;; it has one number
- (let ((x (string-to-number
- (buffer-substring (match-beginning 1) (match-end 1)))))
- (list x (1+ x))))
- ;; it is an "a" group
- (let ((x (1+ (string-to-number
- (buffer-substring (match-beginning 1) (match-end 1))))))
- (list x x)))))
-
-;;; Functions to start Emerge on files
-
-;;;###autoload
-(defun emerge-files (arg file-A file-B file-out &optional startup-hooks
- quit-hooks)
- "Run Emerge on two files."
- (interactive
- (let (f)
- (list current-prefix-arg
- (setq f (emerge-read-file-name "File A to merge" emerge-last-dir-A
- nil nil t))
- (emerge-read-file-name "File B to merge" emerge-last-dir-B nil f t)
- (and current-prefix-arg
- (emerge-read-file-name "Output file" emerge-last-dir-output
- f f nil)))))
- (if file-out
- (add-hook 'quit-hooks `(lambda () (emerge-files-exit ,file-out))))
- (emerge-files-internal
- file-A file-B startup-hooks
- quit-hooks
- file-out))
-
-;;;###autoload
-(defun emerge-files-with-ancestor (arg file-A file-B file-ancestor file-out
- &optional startup-hooks quit-hooks)
- "Run Emerge on two files, giving another file as the ancestor."
- (interactive
- (let (f)
- (list current-prefix-arg
- (setq f (emerge-read-file-name "File A to merge" emerge-last-dir-A
- nil nil t))
- (emerge-read-file-name "File B to merge" emerge-last-dir-B nil f t)
- (emerge-read-file-name "Ancestor file" emerge-last-dir-ancestor
- nil f t)
- (and current-prefix-arg
- (emerge-read-file-name "Output file" emerge-last-dir-output
- f f nil)))))
- (if file-out
- (add-hook 'quit-hooks `(lambda () (emerge-files-exit ,file-out))))
- (emerge-files-with-ancestor-internal
- file-A file-B file-ancestor startup-hooks
- quit-hooks
- file-out))
-
-;; Write the merge buffer out in place of the file the A buffer is visiting.
-(defun emerge-files-exit (file-out)
- ;; if merge was successful was given, save to disk
- (if (not emerge-prefix-argument)
- (emerge-write-and-delete file-out)))
-
-;;; Functions to start Emerge on buffers
-
-;;;###autoload
-(defun emerge-buffers (buffer-A buffer-B &optional startup-hooks quit-hooks)
- "Run Emerge on two buffers."
- (interactive "bBuffer A to merge: \nbBuffer B to merge: ")
- (let ((emerge-file-A (emerge-make-temp-file "A"))
- (emerge-file-B (emerge-make-temp-file "B")))
- (emerge-eval-in-buffer
- buffer-A
- (write-region (point-min) (point-max) emerge-file-A nil 'no-message))
- (emerge-eval-in-buffer
- buffer-B
- (write-region (point-min) (point-max) emerge-file-B nil 'no-message))
- (emerge-setup (get-buffer buffer-A) emerge-file-A
- (get-buffer buffer-B) emerge-file-B
- (cons `(lambda ()
- (delete-file ,emerge-file-A)
- (delete-file ,emerge-file-B))
- startup-hooks)
- quit-hooks
- nil)))
-
-;;;###autoload
-(defun emerge-buffers-with-ancestor (buffer-A buffer-B buffer-ancestor
- &optional startup-hooks
- quit-hooks)
- "Run Emerge on two buffers, giving another buffer as the ancestor."
- (interactive
- "bBuffer A to merge: \nbBuffer B to merge: \nbAncestor buffer: ")
- (let ((emerge-file-A (emerge-make-temp-file "A"))
- (emerge-file-B (emerge-make-temp-file "B"))
- (emerge-file-ancestor (emerge-make-temp-file "anc")))
- (emerge-eval-in-buffer
- buffer-A
- (write-region (point-min) (point-max) emerge-file-A nil 'no-message))
- (emerge-eval-in-buffer
- buffer-B
- (write-region (point-min) (point-max) emerge-file-B nil 'no-message))
- (emerge-eval-in-buffer
- buffer-ancestor
- (write-region (point-min) (point-max) emerge-file-ancestor nil
- 'no-message))
- (emerge-setup-with-ancestor (get-buffer buffer-A) emerge-file-A
- (get-buffer buffer-B) emerge-file-B
- (get-buffer buffer-ancestor)
- emerge-file-ancestor
- (cons `(lambda ()
- (delete-file ,emerge-file-A)
- (delete-file ,emerge-file-B)
- (delete-file
- ,emerge-file-ancestor))
- startup-hooks)
- quit-hooks
- nil)))
-
-;;; Functions to start Emerge from the command line
-
-;;;###autoload
-(defun emerge-files-command ()
- (let ((file-a (nth 0 command-line-args-left))
- (file-b (nth 1 command-line-args-left))
- (file-out (nth 2 command-line-args-left)))
- (setq command-line-args-left (nthcdr 3 command-line-args-left))
- (emerge-files-internal
- file-a file-b nil
- (list `(lambda () (emerge-command-exit ,file-out))))))
-
-;;;###autoload
-(defun emerge-files-with-ancestor-command ()
- (let (file-a file-b file-anc file-out)
- ;; check for a -a flag, for filemerge compatibility
- (if (string= (car command-line-args-left) "-a")
- ;; arguments are "-a ancestor file-a file-b file-out"
- (progn
- (setq file-a (nth 2 command-line-args-left))
- (setq file-b (nth 3 command-line-args-left))
- (setq file-anc (nth 1 command-line-args-left))
- (setq file-out (nth 4 command-line-args-left))
- (setq command-line-args-left (nthcdr 5 command-line-args-left)))
- ;; arguments are "file-a file-b ancestor file-out"
- (setq file-a (nth 0 command-line-args-left))
- (setq file-b (nth 1 command-line-args-left))
- (setq file-anc (nth 2 command-line-args-left))
- (setq file-out (nth 3 command-line-args-left))
- (setq command-line-args-left (nthcdr 4 command-line-args-left)))
- (emerge-files-with-ancestor-internal
- file-a file-b file-anc nil
- (list `(lambda () (emerge-command-exit ,file-out))))))
-
-(defun emerge-command-exit (file-out)
- (emerge-write-and-delete file-out)
- (kill-emacs (if emerge-prefix-argument 1 0)))
-
-;;; Functions to start Emerge via remote request
-
-;;;###autoload
-(defun emerge-files-remote (file-a file-b file-out)
- (setq emerge-file-out file-out)
- (emerge-files-internal
- file-a file-b nil
- (list `(lambda () (emerge-remote-exit ,file-out ',emerge-exit-func)))
- file-out)
- (throw 'client-wait nil))
-
-;;;###autoload
-(defun emerge-files-with-ancestor-remote (file-a file-b file-anc file-out)
- (setq emerge-file-out file-out)
- (emerge-files-with-ancestor-internal
- file-a file-b file-anc nil
- (list `(lambda () (emerge-remote-exit ,file-out ',emerge-exit-func)))
- file-out)
- (throw 'client-wait nil))
-
-(defun emerge-remote-exit (file-out emerge-exit-func)
- (emerge-write-and-delete file-out)
- (kill-buffer emerge-merge-buffer)
- (funcall emerge-exit-func (if emerge-prefix-argument 1 0)))
-
-;;; Functions to start Emerge on RCS versions
-
-;;;###autoload
-(defun emerge-revisions (arg file revision-A revision-B
- &optional startup-hooks quit-hooks)
- "Emerge two RCS revisions of a file."
- (interactive
- (list current-prefix-arg
- (read-file-name "File to merge: " nil nil 'confirm)
- (read-string "Revision A to merge: " emerge-last-revision-A)
- (read-string "Revision B to merge: " emerge-last-revision-B)))
- (setq emerge-last-revision-A revision-A
- emerge-last-revision-B revision-B)
- (emerge-revisions-internal
- file revision-A revision-B startup-hooks
- (if arg
- (cons `(lambda ()
- (shell-command
- ,(format "%s %s" emerge-rcs-ci-program file)))
- quit-hooks)
- quit-hooks)))
-
-;;;###autoload
-(defun emerge-revisions-with-ancestor (arg file revision-A
- revision-B ancestor
- &optional
- startup-hooks quit-hooks)
- "Emerge two RCS revisions of a file, with another revision as ancestor."
- (interactive
- (list current-prefix-arg
- (read-file-name "File to merge: " nil nil 'confirm)
- (read-string "Revision A to merge: " emerge-last-revision-A)
- (read-string "Revision B to merge: " emerge-last-revision-B)
- (read-string "Ancestor: " emerge-last-revision-ancestor)))
- (setq emerge-last-revision-A revision-A
- emerge-last-revision-B revision-B
- emerge-last-revision-ancestor ancestor)
- (emerge-revision-with-ancestor-internal
- file revision-A revision-B ancestor startup-hooks
- (if arg
- (let ((cmd ))
- (cons `(lambda ()
- (shell-command
- ,(format "%s %s" emerge-rcs-ci-program file)))
- quit-hooks))
- quit-hooks)))
-
-(defun emerge-revisions-internal (file revision-A revision-B &optional
- startup-hooks quit-hooks output-file)
- (let ((buffer-A (get-buffer-create (format "%s,%s" file revision-A)))
- (buffer-B (get-buffer-create (format "%s,%s" file revision-B)))
- (emerge-file-A (emerge-make-temp-file "A"))
- (emerge-file-B (emerge-make-temp-file "B")))
- ;; Get the revisions into buffers
- (emerge-eval-in-buffer
- buffer-A
- (erase-buffer)
- (shell-command
- (format "%s -q -p%s %s" emerge-rcs-co-program revision-A file)
- t)
- (write-region (point-min) (point-max) emerge-file-A nil 'no-message)
- (set-buffer-modified-p nil))
- (emerge-eval-in-buffer
- buffer-B
- (erase-buffer)
- (shell-command
- (format "%s -q -p%s %s" emerge-rcs-co-program revision-B file)
- t)
- (write-region (point-min) (point-max) emerge-file-B nil 'no-message)
- (set-buffer-modified-p nil))
- ;; Do the merge
- (emerge-setup buffer-A emerge-file-A
- buffer-B emerge-file-B
- (cons `(lambda ()
- (delete-file ,emerge-file-A)
- (delete-file ,emerge-file-B))
- startup-hooks)
- (cons `(lambda () (emerge-files-exit ,file))
- quit-hooks)
- nil)))
-
-(defun emerge-revision-with-ancestor-internal (file revision-A revision-B
- ancestor
- &optional startup-hooks
- quit-hooks output-file)
- (let ((buffer-A (get-buffer-create (format "%s,%s" file revision-A)))
- (buffer-B (get-buffer-create (format "%s,%s" file revision-B)))
- (buffer-ancestor (get-buffer-create (format "%s,%s" file ancestor)))
- (emerge-file-A (emerge-make-temp-file "A"))
- (emerge-file-B (emerge-make-temp-file "B"))
- (emerge-ancestor (emerge-make-temp-file "ancestor")))
- ;; Get the revisions into buffers
- (emerge-eval-in-buffer
- buffer-A
- (erase-buffer)
- (shell-command
- (format "%s -q -p%s %s" emerge-rcs-co-program
- revision-A file)
- t)
- (write-region (point-min) (point-max) emerge-file-A nil 'no-message)
- (set-buffer-modified-p nil))
- (emerge-eval-in-buffer
- buffer-B
- (erase-buffer)
- (shell-command
- (format "%s -q -p%s %s" emerge-rcs-co-program revision-B file)
- t)
- (write-region (point-min) (point-max) emerge-file-B nil 'no-message)
- (set-buffer-modified-p nil))
- (emerge-eval-in-buffer
- buffer-ancestor
- (erase-buffer)
- (shell-command
- (format "%s -q -p%s %s" emerge-rcs-co-program ancestor file)
- t)
- (write-region (point-min) (point-max) emerge-ancestor nil 'no-message)
- (set-buffer-modified-p nil))
- ;; Do the merge
- (emerge-setup-with-ancestor
- buffer-A emerge-file-A buffer-B emerge-file-B
- buffer-ancestor emerge-ancestor
- (cons `(lambda ()
- (delete-file ,emerge-file-A)
- (delete-file ,emerge-file-B)
- (delete-file ,emerge-ancestor))
- startup-hooks)
- (cons `(lambda () (emerge-files-exit ,file))
- quit-hooks)
- output-file)))
-
-;;; Function to start Emerge based on a line in a file
-
-(defun emerge-execute-line ()
- "Run Emerge using files named in current text line.
-Looks in that line for whitespace-separated entries of these forms:
- a=file1
- b=file2
- ancestor=file3
- output=file4
-to specify the files to use in Emerge.
-
-In addition, if only one of `a=file' or `b=file' is present, and `output=file'
-is present:
-If `emerge-execute-line-deletions' is non-nil and `ancestor=file' is present,
-it is assumed that the file in question has been deleted, and it is
-not copied to the output file.
-Otherwise, the A or B file present is copied to the output file."
- (interactive)
- (let (file-A file-B file-ancestor file-out
- (case-fold-search t))
- ;; Stop if at end of buffer (even though we might be in a line, if
- ;; the line does not end with newline)
- (if (eobp)
- (error "At end of buffer"))
- ;; Go to the beginning of the line
- (beginning-of-line)
- ;; Skip any initial whitespace
- (if (looking-at "[ \t]*")
- (goto-char (match-end 0)))
- ;; Process the entire line
- (while (not (eolp))
- ;; Get the next entry
- (if (looking-at "\\([a-z]+\\)=\\([^ \t\n]+\\)[ \t]*")
- ;; Break apart the tab (before =) and the filename (after =)
- (let ((tag (downcase
- (buffer-substring (match-beginning 1) (match-end 1))))
- (file (buffer-substring (match-beginning 2) (match-end 2))))
- ;; Move point after the entry
- (goto-char (match-end 0))
- ;; Store the filename in the right variable
- (cond
- ((string-equal tag "a")
- (if file-A
- (error "This line has two `A' entries"))
- (setq file-A file))
- ((string-equal tag "b")
- (if file-B
- (error "This line has two `B' entries"))
- (setq file-B file))
- ((or (string-equal tag "anc") (string-equal tag "ancestor"))
- (if file-ancestor
- (error "This line has two `ancestor' entries"))
- (setq file-ancestor file))
- ((or (string-equal tag "out") (string-equal tag "output"))
- (if file-out
- (error "This line has two `output' entries"))
- (setq file-out file))
- (t
- (error "Unrecognized entry"))))
- ;; If the match on the entry pattern failed
- (error "Unparsable entry")))
- ;; Make sure that file-A and file-B are present
- (if (not (or (and file-A file-B) file-out))
- (error "Must have both `A' and `B' entries"))
- (if (not (or file-A file-B))
- (error "Must have `A' or `B' entry"))
- ;; Go to the beginning of the next line, so next execution will use
- ;; next line in buffer.
- (beginning-of-line 2)
- ;; Execute the correct command
- (cond
- ;; Merge of two files with ancestor
- ((and file-A file-B file-ancestor)
- (message "Merging %s and %s..." file-A file-B)
- (emerge-files-with-ancestor (not (not file-out)) file-A file-B
- file-ancestor file-out
- nil
- ;; When done, return to this buffer.
- (list
- `(lambda ()
- (switch-to-buffer ,(current-buffer))
- (message "Merge done.")))))
- ;; Merge of two files without ancestor
- ((and file-A file-B)
- (message "Merging %s and %s..." file-A file-B)
- (emerge-files (not (not file-out)) file-A file-B file-out
- nil
- ;; When done, return to this buffer.
- (list
- `(lambda ()
- (switch-to-buffer ,(current-buffer))
- (message "Merge done.")))))
- ;; There is an output file (or there would have been an error above),
- ;; but only one input file.
- ;; The file appears to have been deleted in one version; do nothing.
- ((and file-ancestor emerge-execute-line-deletions)
- (message "No action."))
- ;; The file should be copied from the version that contains it
- (t (let ((input-file (or file-A file-B)))
- (message "Copying...")
- (copy-file input-file file-out)
- (message "%s copied to %s." input-file file-out))))))
-
-;;; Sample function for creating information for emerge-execute-line
-
-(defcustom emerge-merge-directories-filename-regexp "[^.]"
- "Regexp describing files to be processed by `emerge-merge-directories'."
- :type 'regexp
- :group 'emerge)
-
-;;;###autoload
-(defun emerge-merge-directories (a-dir b-dir ancestor-dir output-dir)
- (interactive
- (list
- (read-file-name "A directory: " nil nil 'confirm)
- (read-file-name "B directory: " nil nil 'confirm)
- (read-file-name "Ancestor directory (null for none): " nil nil 'confirm)
- (read-file-name "Output directory (null for none): " nil nil 'confirm)))
- ;; Check that we're not on a line
- (if (not (and (bolp) (eolp)))
- (error "There is text on this line"))
- ;; Turn null strings into nil to indicate directories not used.
- (if (and ancestor-dir (string-equal ancestor-dir ""))
- (setq ancestor-dir nil))
- (if (and output-dir (string-equal output-dir ""))
- (setq output-dir nil))
- ;; Canonicalize the directory names
- (setq a-dir (expand-file-name a-dir))
- (if (not (string-equal (substring a-dir -1) "/"))
- (setq a-dir (concat a-dir "/")))
- (setq b-dir (expand-file-name b-dir))
- (if (not (string-equal (substring b-dir -1) "/"))
- (setq b-dir (concat b-dir "/")))
- (if ancestor-dir
- (progn
- (setq ancestor-dir (expand-file-name ancestor-dir))
- (if (not (string-equal (substring ancestor-dir -1) "/"))
- (setq ancestor-dir (concat ancestor-dir "/")))))
- (if output-dir
- (progn
- (setq output-dir (expand-file-name output-dir))
- (if (not (string-equal (substring output-dir -1) "/"))
- (setq output-dir (concat output-dir "/")))))
- ;; Set the mark to where we start
- (push-mark)
- ;; Find out what files are in the directories.
- (let* ((a-dir-files
- (directory-files a-dir nil emerge-merge-directories-filename-regexp))
- (b-dir-files
- (directory-files b-dir nil emerge-merge-directories-filename-regexp))
- (ancestor-dir-files
- (and ancestor-dir
- (directory-files ancestor-dir nil
- emerge-merge-directories-filename-regexp)))
- (all-files (sort (nconc (copy-sequence a-dir-files)
- (copy-sequence b-dir-files)
- (copy-sequence ancestor-dir-files))
- (function string-lessp))))
- ;; Remove duplicates from all-files.
- (let ((p all-files))
- (while p
- (if (and (cdr p) (string-equal (car p) (car (cdr p))))
- (setcdr p (cdr (cdr p)))
- (setq p (cdr p)))))
- ;; Generate the control lines for the various files.
- (while all-files
- (let ((f (car all-files)))
- (setq all-files (cdr all-files))
- (if (and a-dir-files (string-equal (car a-dir-files) f))
- (progn
- (insert "A=" a-dir f "\t")
- (setq a-dir-files (cdr a-dir-files))))
- (if (and b-dir-files (string-equal (car b-dir-files) f))
- (progn
- (insert "B=" b-dir f "\t")
- (setq b-dir-files (cdr b-dir-files))))
- (if (and ancestor-dir-files (string-equal (car ancestor-dir-files) f))
- (progn
- (insert "ancestor=" ancestor-dir f "\t")
- (setq ancestor-dir-files (cdr ancestor-dir-files))))
- (if output-dir
- (insert "output=" output-dir f "\t"))
- (backward-delete-char 1)
- (insert "\n")))))
-
-;;; Common setup routines
-
-;; Set up the window configuration. If POS is given, set the points to
-;; the beginnings of the buffers.
-(defun emerge-setup-windows (buffer-A buffer-B merge-buffer &optional pos)
- ;; Make sure we are not in the minibuffer window when we try to delete
- ;; all other windows.
- (if (eq (selected-window) (minibuffer-window))
- (other-window 1))
- (delete-other-windows)
- (switch-to-buffer merge-buffer)
- (emerge-refresh-mode-line)
- (split-window-vertically)
- (split-window-horizontally)
- (switch-to-buffer buffer-A)
- (if pos
- (goto-char (point-min)))
- (other-window 1)
- (switch-to-buffer buffer-B)
- (if pos
- (goto-char (point-min)))
- (other-window 1)
- (if pos
- (goto-char (point-min)))
- ;; If diff/diff3 reports errors, display them rather than the merge buffer.
- (if (/= 0 (emerge-eval-in-buffer emerge-diff-error-buffer (buffer-size)))
- (progn
- (ding)
- (message "Errors found in diff/diff3 output. Merge buffer is %s."
- (buffer-name emerge-merge-buffer))
- (switch-to-buffer emerge-diff-error-buffer))))
-
-;; Set up the keymap in the merge buffer
-(defun emerge-set-keys ()
- ;; Set up fixed keymaps if necessary
- (if (not emerge-basic-keymap)
- (emerge-setup-fixed-keymaps))
- ;; Save the old local map
- (setq emerge-old-keymap (current-local-map))
- ;; Construct the edit keymap
- (setq emerge-edit-keymap (if emerge-old-keymap
- (copy-keymap emerge-old-keymap)
- (make-sparse-keymap)))
- ;; Install the Emerge commands
- (emerge-force-define-key emerge-edit-keymap emerge-command-prefix
- 'emerge-basic-keymap)
- (define-key emerge-edit-keymap [menu-bar] (make-sparse-keymap))
-
- ;; Create the additional menu bar items.
- (define-key emerge-edit-keymap [menu-bar emerge-options]
- (cons "Merge-Options" emerge-options-menu))
- (define-key emerge-edit-keymap [menu-bar merge]
- (cons "Merge" emerge-merge-menu))
- (define-key emerge-edit-keymap [menu-bar move]
- (cons "Move" emerge-move-menu))
-
- ;; Suppress write-file and save-buffer
- (substitute-key-definition 'write-file
- 'emerge-query-write-file
- emerge-edit-keymap)
- (substitute-key-definition 'save-buffer
- 'emerge-query-save-buffer
- emerge-edit-keymap)
- (define-key emerge-edit-keymap [remap write-file] 'emerge-query-write-file)
- (define-key emerge-edit-keymap [remap save-buffer] 'emerge-query-save-buffer)
- (use-local-map emerge-fast-keymap)
- (setq emerge-edit-mode nil)
- (setq emerge-fast-mode t))
-
-(defun emerge-remember-buffer-characteristics ()
- "Record certain properties of the buffers being merged.
-Must be called in the merge buffer. Remembers read-only, modified,
-auto-save, and saves them in buffer local variables. Sets the buffers
-read-only and turns off `auto-save-mode'.
-These characteristics are restored by `emerge-restore-buffer-characteristics'."
- ;; force auto-save, because we will turn off auto-saving in buffers for the
- ;; duration
- (do-auto-save)
- ;; remember and alter buffer characteristics
- (setq emerge-A-buffer-values
- (emerge-eval-in-buffer
- emerge-A-buffer
- (prog1
- (emerge-save-variables emerge-saved-variables)
- (emerge-restore-variables emerge-saved-variables
- emerge-merging-values))))
- (setq emerge-B-buffer-values
- (emerge-eval-in-buffer
- emerge-B-buffer
- (prog1
- (emerge-save-variables emerge-saved-variables)
- (emerge-restore-variables emerge-saved-variables
- emerge-merging-values)))))
-
-(defun emerge-restore-buffer-characteristics ()
- "Restore characteristics saved by `emerge-remember-buffer-characteristics'."
- (let ((A-values emerge-A-buffer-values)
- (B-values emerge-B-buffer-values))
- (emerge-eval-in-buffer emerge-A-buffer
- (emerge-restore-variables emerge-saved-variables
- A-values))
- (emerge-eval-in-buffer emerge-B-buffer
- (emerge-restore-variables emerge-saved-variables
- B-values))))
-
-;; Move to line DESIRED-LINE assuming we are at line CURRENT-LINE.
-;; Return DESIRED-LINE.
-(defun emerge-goto-line (desired-line current-line)
- (forward-line (- desired-line current-line))
- desired-line)
-
-(defun emerge-convert-diffs-to-markers (A-buffer
- B-buffer
- merge-buffer
- lineno-list)
- (let* (marker-list
- (A-point-min (emerge-eval-in-buffer A-buffer (point-min)))
- (offset (1- A-point-min))
- (B-point-min (emerge-eval-in-buffer B-buffer (point-min)))
- ;; Record current line number in each buffer
- ;; so we don't have to count from the beginning.
- (a-line 1)
- (b-line 1))
- (emerge-eval-in-buffer A-buffer (goto-char (point-min)))
- (emerge-eval-in-buffer B-buffer (goto-char (point-min)))
- (while lineno-list
- (let* ((list-element (car lineno-list))
- a-begin-marker
- a-end-marker
- b-begin-marker
- b-end-marker
- merge-begin-marker
- merge-end-marker
- (a-begin (aref list-element 0))
- (a-end (aref list-element 1))
- (b-begin (aref list-element 2))
- (b-end (aref list-element 3))
- (state (aref list-element 4)))
- ;; place markers at the appropriate places in the buffers
- (emerge-eval-in-buffer
- A-buffer
- (setq a-line (emerge-goto-line a-begin a-line))
- (setq a-begin-marker (point-marker))
- (setq a-line (emerge-goto-line a-end a-line))
- (setq a-end-marker (point-marker)))
- (emerge-eval-in-buffer
- B-buffer
- (setq b-line (emerge-goto-line b-begin b-line))
- (setq b-begin-marker (point-marker))
- (setq b-line (emerge-goto-line b-end b-line))
- (setq b-end-marker (point-marker)))
- (setq merge-begin-marker (set-marker
- (make-marker)
- (- (marker-position a-begin-marker)
- offset)
- merge-buffer))
- (setq merge-end-marker (set-marker
- (make-marker)
- (- (marker-position a-end-marker)
- offset)
- merge-buffer))
- ;; record all the markers for this difference
- (setq marker-list (cons (vector a-begin-marker a-end-marker
- b-begin-marker b-end-marker
- merge-begin-marker merge-end-marker
- state)
- marker-list)))
- (setq lineno-list (cdr lineno-list)))
- ;; convert the list of difference information into a vector for
- ;; fast access
- (setq emerge-difference-list (apply 'vector (nreverse marker-list)))))
-
-;; If we have an ancestor, select all B variants that we prefer
-(defun emerge-select-prefer-Bs ()
- (let ((n 0))
- (while (< n emerge-number-of-differences)
- (if (eq (aref (aref emerge-difference-list n) 6) 'prefer-B)
- (progn
- (emerge-unselect-and-select-difference n t)
- (emerge-select-B)
- (aset (aref emerge-difference-list n) 6 'prefer-B)))
- (setq n (1+ n))))
- (emerge-unselect-and-select-difference -1))
-
-;; Process the local-variables list at the end of the merged file, if
-;; requested.
-(defun emerge-handle-local-variables ()
- (if emerge-process-local-variables
- (condition-case err
- (hack-local-variables)
- (error (message "Local-variables error in merge buffer: %s"
- (prin1-to-string err))))))
-
-;;; Common exit routines
-
-(defun emerge-write-and-delete (file-out)
- ;; clear screen format
- (delete-other-windows)
- ;; delete A, B, and ancestor buffers, if they haven't been changed
- (if (not (buffer-modified-p emerge-A-buffer))
- (kill-buffer emerge-A-buffer))
- (if (not (buffer-modified-p emerge-B-buffer))
- (kill-buffer emerge-B-buffer))
- (if (and emerge-ancestor-buffer
- (not (buffer-modified-p emerge-ancestor-buffer)))
- (kill-buffer emerge-ancestor-buffer))
- ;; Write merge buffer to file
- (and file-out
- (write-file file-out)))
-
-;;; Commands
-
-(defun emerge-recenter (&optional arg)
- "Bring the highlighted region of all three merge buffers into view.
-This brings the buffers into view if they are in windows.
-With an argument, reestablish the default three-window display."
- (interactive "P")
- ;; If there is an argument, rebuild the window structure
- (if arg
- (emerge-setup-windows emerge-A-buffer emerge-B-buffer
- emerge-merge-buffer))
- ;; Redisplay whatever buffers are showing, if there is a selected difference
- (if (and (>= emerge-current-difference 0)
- (< emerge-current-difference emerge-number-of-differences))
- (let* ((merge-buffer emerge-merge-buffer)
- (buffer-A emerge-A-buffer)
- (buffer-B emerge-B-buffer)
- (window-A (get-buffer-window buffer-A 'visible))
- (window-B (get-buffer-window buffer-B 'visible))
- (merge-window (get-buffer-window merge-buffer))
- (diff-vector
- (aref emerge-difference-list emerge-current-difference)))
- (if window-A (progn
- (select-window window-A)
- (emerge-position-region
- (- (aref diff-vector 0)
- (1- emerge-before-flag-length))
- (+ (aref diff-vector 1)
- (1- emerge-after-flag-length))
- (1+ (aref diff-vector 0)))))
- (if window-B (progn
- (select-window window-B)
- (emerge-position-region
- (- (aref diff-vector 2)
- (1- emerge-before-flag-length))
- (+ (aref diff-vector 3)
- (1- emerge-after-flag-length))
- (1+ (aref diff-vector 2)))))
- (if merge-window (progn
- (select-window merge-window)
- (emerge-position-region
- (- (aref diff-vector 4)
- (1- emerge-before-flag-length))
- (+ (aref diff-vector 5)
- (1- emerge-after-flag-length))
- (1+ (aref diff-vector 4))))))))
-
-;;; Window scrolling operations
-;; These operations are designed to scroll all three windows the same amount,
-;; so as to keep the text in them aligned.
-
-;; Perform some operation on all three windows (if they are showing).
-;; Catches all errors on the operation in the A and B windows, but not
-;; in the merge window. Usually, errors come from scrolling off the
-;; beginning or end of the buffer, and this gives a nice error message:
-;; End of buffer is reported in the merge buffer, but if the scroll was
-;; possible in the A or B windows, it is performed there before the error
-;; is reported.
-(defun emerge-operate-on-windows (operation arg)
- (let* ((merge-buffer emerge-merge-buffer)
- (buffer-A emerge-A-buffer)
- (buffer-B emerge-B-buffer)
- (window-A (get-buffer-window buffer-A 'visible))
- (window-B (get-buffer-window buffer-B 'visible))
- (merge-window (get-buffer-window merge-buffer)))
- (if window-A (progn
- (select-window window-A)
- (condition-case nil
- (funcall operation arg)
- (error))))
- (if window-B (progn
- (select-window window-B)
- (condition-case nil
- (funcall operation arg)
- (error))))
- (if merge-window (progn
- (select-window merge-window)
- (funcall operation arg)))))
-
-(defun emerge-scroll-up (&optional arg)
- "Scroll up all three merge buffers, if they are in windows.
-With argument N, scroll N lines; otherwise scroll by nearly
-the height of the merge window.
-`C-u -' alone as argument scrolls half the height of the merge window."
- (interactive "P")
- (emerge-operate-on-windows
- 'scroll-up
- ;; calculate argument to scroll-up
- ;; if there is an explicit argument
- (if (and arg (not (equal arg '-)))
- ;; use it
- (prefix-numeric-value arg)
- ;; if not, see if we can determine a default amount (the window height)
- (let ((merge-window (get-buffer-window emerge-merge-buffer)))
- (if (null merge-window)
- ;; no window, use nil
- nil
- (let ((default-amount
- (- (window-height merge-window) 1 next-screen-context-lines)))
- ;; the window was found
- (if arg
- ;; C-u as argument means half of default amount
- (/ default-amount 2)
- ;; no argument means default amount
- default-amount)))))))
-
-(defun emerge-scroll-down (&optional arg)
- "Scroll down all three merge buffers, if they are in windows.
-With argument N, scroll N lines; otherwise scroll by nearly
-the height of the merge window.
-`C-u -' alone as argument scrolls half the height of the merge window."
- (interactive "P")
- (emerge-operate-on-windows
- 'scroll-down
- ;; calculate argument to scroll-down
- ;; if there is an explicit argument
- (if (and arg (not (equal arg '-)))
- ;; use it
- (prefix-numeric-value arg)
- ;; if not, see if we can determine a default amount (the window height)
- (let ((merge-window (get-buffer-window emerge-merge-buffer)))
- (if (null merge-window)
- ;; no window, use nil
- nil
- (let ((default-amount
- (- (window-height merge-window) 1 next-screen-context-lines)))
- ;; the window was found
- (if arg
- ;; C-u as argument means half of default amount
- (/ default-amount 2)
- ;; no argument means default amount
- default-amount)))))))
-
-(defun emerge-scroll-left (&optional arg)
- "Scroll left all three merge buffers, if they are in windows.
-If an argument is given, that is how many columns are scrolled, else nearly
-the width of the A and B windows. `C-u -' alone as argument scrolls half the
-width of the A and B windows."
- (interactive "P")
- (emerge-operate-on-windows
- 'scroll-left
- ;; calculate argument to scroll-left
- ;; if there is an explicit argument
- (if (and arg (not (equal arg '-)))
- ;; use it
- (prefix-numeric-value arg)
- ;; if not, see if we can determine a default amount
- ;; (half the window width)
- (let ((merge-window (get-buffer-window emerge-merge-buffer)))
- (if (null merge-window)
- ;; no window, use nil
- nil
- (let ((default-amount
- (- (/ (window-width merge-window) 2) 3)))
- ;; the window was found
- (if arg
- ;; C-u as argument means half of default amount
- (/ default-amount 2)
- ;; no argument means default amount
- default-amount)))))))
-
-(defun emerge-scroll-right (&optional arg)
- "Scroll right all three merge buffers, if they are in windows.
-If an argument is given, that is how many columns are scrolled, else nearly
-the width of the A and B windows. `C-u -' alone as argument scrolls half the
-width of the A and B windows."
- (interactive "P")
- (emerge-operate-on-windows
- 'scroll-right
- ;; calculate argument to scroll-right
- ;; if there is an explicit argument
- (if (and arg (not (equal arg '-)))
- ;; use it
- (prefix-numeric-value arg)
- ;; if not, see if we can determine a default amount
- ;; (half the window width)
- (let ((merge-window (get-buffer-window emerge-merge-buffer)))
- (if (null merge-window)
- ;; no window, use nil
- nil
- (let ((default-amount
- (- (/ (window-width merge-window) 2) 3)))
- ;; the window was found
- (if arg
- ;; C-u as argument means half of default amount
- (/ default-amount 2)
- ;; no argument means default amount
- default-amount)))))))
-
-(defun emerge-scroll-reset ()
- "Reset horizontal scrolling in Emerge.
-This resets the horizontal scrolling of all three merge buffers
-to the left margin, if they are in windows."
- (interactive)
- (emerge-operate-on-windows
- (function (lambda (x) (set-window-hscroll (selected-window) 0)))
- nil))
-
-;; Attempt to show the region nicely.
-;; If there are min-lines lines above and below the region, then don't do
-;; anything.
-;; If not, recenter the region to make it so.
-;; If that isn't possible, remove context lines balancedly from top and bottom
-;; so the entire region shows.
-;; If that isn't possible, show the top of the region.
-;; BEG must be at the beginning of a line.
-(defun emerge-position-region (beg end pos)
- ;; First test whether the entire region is visible with
- ;; emerge-min-visible-lines above and below it
- (if (not (and (<= (progn
- (move-to-window-line emerge-min-visible-lines)
- (point))
- beg)
- (<= end (progn
- (move-to-window-line
- (- (1+ emerge-min-visible-lines)))
- (point)))))
- ;; We failed that test, see if it fits at all
- ;; Meanwhile positioning it correctly in case it doesn't fit
- (progn
- (set-window-start (selected-window) beg)
- (if (pos-visible-in-window-p end)
- ;; Determine the number of lines that the region occupies
- (let ((lines 0))
- (while (> end (progn
- (move-to-window-line lines)
- (point)))
- (setq lines (1+ lines)))
- ;; And position the beginning on the right line
- (goto-char beg)
- (recenter (/ (1+ (- (1- (window-height (selected-window)))
- lines))
- 2))))))
- (goto-char pos))
-
-(defun emerge-next-difference ()
- "Advance to the next difference."
- (interactive)
- (if (< emerge-current-difference emerge-number-of-differences)
- (let ((n (1+ emerge-current-difference)))
- (while (and emerge-skip-prefers
- (< n emerge-number-of-differences)
- (memq (aref (aref emerge-difference-list n) 6)
- '(prefer-A prefer-B)))
- (setq n (1+ n)))
- (let ((buffer-read-only nil))
- (emerge-unselect-and-select-difference n)))
- (error "At end")))
-
-(defun emerge-previous-difference ()
- "Go to the previous difference."
- (interactive)
- (if (> emerge-current-difference -1)
- (let ((n (1- emerge-current-difference)))
- (while (and emerge-skip-prefers
- (> n -1)
- (memq (aref (aref emerge-difference-list n) 6)
- '(prefer-A prefer-B)))
- (setq n (1- n)))
- (let ((buffer-read-only nil))
- (emerge-unselect-and-select-difference n)))
- (error "At beginning")))
-
-(defun emerge-jump-to-difference (difference-number)
- "Go to the N-th difference."
- (interactive "p")
- (let ((buffer-read-only nil))
- (setq difference-number (1- difference-number))
- (if (and (>= difference-number -1)
- (< difference-number (1+ emerge-number-of-differences)))
- (emerge-unselect-and-select-difference difference-number)
- (error "Bad difference number"))))
-
-(defun emerge-abort ()
- "Abort the Emerge session."
- (interactive)
- (emerge-quit t))
-
-(defun emerge-quit (arg)
- "Finish the Emerge session and exit Emerge.
-Prefix argument means to abort rather than successfully finish.
-The difference depends on how the merge was started,
-but usually means to not write over one of the original files, or to signal
-to some process which invoked Emerge a failure code.
-
-Unselects the selected difference, if any, restores the read-only and modified
-flags of the merged file buffers, restores the local keymap of the merge
-buffer, and sets off various emerge flags. Using Emerge commands in this
-buffer after this will cause serious problems."
- (interactive "P")
- (if (prog1
- (y-or-n-p
- (if (not arg)
- "Do you really want to successfully finish this merge? "
- "Do you really want to abort this merge? "))
- (message ""))
- (emerge-really-quit arg)))
-
-;; Perform the quit operations.
-(defun emerge-really-quit (arg)
- (setq buffer-read-only nil)
- (emerge-unselect-and-select-difference -1)
- (emerge-restore-buffer-characteristics)
- ;; null out the difference markers so they don't slow down future editing
- ;; operations
- (mapc (function (lambda (d)
- (set-marker (aref d 0) nil)
- (set-marker (aref d 1) nil)
- (set-marker (aref d 2) nil)
- (set-marker (aref d 3) nil)
- (set-marker (aref d 4) nil)
- (set-marker (aref d 5) nil)))
- emerge-difference-list)
- ;; allow them to be garbage collected
- (setq emerge-difference-list nil)
- ;; restore the local map
- (use-local-map emerge-old-keymap)
- ;; turn off all the emerge modes
- (setq emerge-mode nil)
- (setq emerge-fast-mode nil)
- (setq emerge-edit-mode nil)
- (setq emerge-auto-advance nil)
- (setq emerge-skip-prefers nil)
- ;; restore mode line
- (kill-local-variable 'mode-line-buffer-identification)
- (let ((emerge-prefix-argument arg))
- (run-hooks 'emerge-quit-hook)))
-
-(defun emerge-select-A (&optional force)
- "Select the A variant of this difference.
-Refuses to function if this difference has been edited, i.e., if it
-is neither the A nor the B variant.
-A prefix argument forces the variant to be selected
-even if the difference has been edited."
- (interactive "P")
- (let ((operate
- (function (lambda ()
- (emerge-select-A-edit merge-begin merge-end A-begin A-end)
- (if emerge-auto-advance
- (emerge-next-difference)))))
- (operate-no-change
- (function (lambda ()
- (if emerge-auto-advance
- (emerge-next-difference))))))
- (emerge-select-version force operate-no-change operate operate)))
-
-;; Actually select the A variant
-(defun emerge-select-A-edit (merge-begin merge-end A-begin A-end)
- (emerge-eval-in-buffer
- emerge-merge-buffer
- (delete-region merge-begin merge-end)
- (goto-char merge-begin)
- (insert-buffer-substring emerge-A-buffer A-begin A-end)
- (goto-char merge-begin)
- (aset diff-vector 6 'A)
- (emerge-refresh-mode-line)))
-
-(defun emerge-select-B (&optional force)
- "Select the B variant of this difference.
-Refuses to function if this difference has been edited, i.e., if it
-is neither the A nor the B variant.
-A prefix argument forces the variant to be selected
-even if the difference has been edited."
- (interactive "P")
- (let ((operate
- (function (lambda ()
- (emerge-select-B-edit merge-begin merge-end B-begin B-end)
- (if emerge-auto-advance
- (emerge-next-difference)))))
- (operate-no-change
- (function (lambda ()
- (if emerge-auto-advance
- (emerge-next-difference))))))
- (emerge-select-version force operate operate-no-change operate)))
-
-;; Actually select the B variant
-(defun emerge-select-B-edit (merge-begin merge-end B-begin B-end)
- (emerge-eval-in-buffer
- emerge-merge-buffer
- (delete-region merge-begin merge-end)
- (goto-char merge-begin)
- (insert-buffer-substring emerge-B-buffer B-begin B-end)
- (goto-char merge-begin)
- (aset diff-vector 6 'B)
- (emerge-refresh-mode-line)))
-
-(defun emerge-default-A ()
- "Make the A variant the default from here down.
-This selects the A variant for all differences from here down in the buffer
-which are still defaulted, i.e., which the user has not selected and for
-which there is no preference."
- (interactive)
- (let ((buffer-read-only nil))
- (let ((selected-difference emerge-current-difference)
- (n (max emerge-current-difference 0)))
- (while (< n emerge-number-of-differences)
- (let ((diff-vector (aref emerge-difference-list n)))
- (if (eq (aref diff-vector 6) 'default-B)
- (progn
- (emerge-unselect-and-select-difference n t)
- (emerge-select-A)
- (aset diff-vector 6 'default-A))))
- (setq n (1+ n))
- (if (zerop (% n 10))
- (message "Setting default to A...%d" n)))
- (emerge-unselect-and-select-difference selected-difference)))
- (message "Default choice is now A"))
-
-(defun emerge-default-B ()
- "Make the B variant the default from here down.
-This selects the B variant for all differences from here down in the buffer
-which are still defaulted, i.e., which the user has not selected and for
-which there is no preference."
- (interactive)
- (let ((buffer-read-only nil))
- (let ((selected-difference emerge-current-difference)
- (n (max emerge-current-difference 0)))
- (while (< n emerge-number-of-differences)
- (let ((diff-vector (aref emerge-difference-list n)))
- (if (eq (aref diff-vector 6) 'default-A)
- (progn
- (emerge-unselect-and-select-difference n t)
- (emerge-select-B)
- (aset diff-vector 6 'default-B))))
- (setq n (1+ n))
- (if (zerop (% n 10))
- (message "Setting default to B...%d" n)))
- (emerge-unselect-and-select-difference selected-difference)))
- (message "Default choice is now B"))
-
-(defun emerge-fast-mode ()
- "Set fast mode, for Emerge.
-In this mode ordinary Emacs commands are disabled, and Emerge commands
-need not be prefixed with \\<emerge-fast-keymap>\\[emerge-basic-keymap]."
- (interactive)
- (setq buffer-read-only t)
- (use-local-map emerge-fast-keymap)
- (setq emerge-mode t)
- (setq emerge-fast-mode t)
- (setq emerge-edit-mode nil)
- (message "Fast mode set")
- (force-mode-line-update))
-
-(defun emerge-edit-mode ()
- "Set edit mode, for Emerge.
-In this mode ordinary Emacs commands are available, and Emerge commands
-must be prefixed with \\<emerge-fast-keymap>\\[emerge-basic-keymap]."
- (interactive)
- (setq buffer-read-only nil)
- (use-local-map emerge-edit-keymap)
- (setq emerge-mode t)
- (setq emerge-fast-mode nil)
- (setq emerge-edit-mode t)
- (message "Edit mode set")
- (force-mode-line-update))
-
-(defun emerge-auto-advance (arg)
- "Toggle Auto-Advance mode, for Emerge.
-This mode causes `emerge-select-A' and `emerge-select-B' to automatically
-advance to the next difference.
-With a positive argument, turn on Auto-Advance mode.
-With a negative argument, turn off Auto-Advance mode."
- (interactive "P")
- (setq emerge-auto-advance (if (null arg)
- (not emerge-auto-advance)
- (> (prefix-numeric-value arg) 0)))
- (message (if emerge-auto-advance
- "Auto-advance set"
- "Auto-advance cleared"))
- (force-mode-line-update))
-
-(defun emerge-skip-prefers (arg)
- "Toggle Skip-Prefers mode, for Emerge.
-This mode causes `emerge-next-difference' and `emerge-previous-difference'
-to automatically skip over differences for which there is a preference.
-With a positive argument, turn on Skip-Prefers mode.
-With a negative argument, turn off Skip-Prefers mode."
- (interactive "P")
- (setq emerge-skip-prefers (if (null arg)
- (not emerge-skip-prefers)
- (> (prefix-numeric-value arg) 0)))
- (message (if emerge-skip-prefers
- "Skip-prefers set"
- "Skip-prefers cleared"))
- (force-mode-line-update))
-
-(defun emerge-copy-as-kill-A ()
- "Put the A variant of this difference in the kill ring."
- (interactive)
- (emerge-validate-difference)
- (let* ((diff-vector
- (aref emerge-difference-list emerge-current-difference))
- (A-begin (1+ (aref diff-vector 0)))
- (A-end (1- (aref diff-vector 1)))
- ;; so further kills don't append
- this-command)
- (with-current-buffer emerge-A-buffer
- (copy-region-as-kill A-begin A-end))))
-
-(defun emerge-copy-as-kill-B ()
- "Put the B variant of this difference in the kill ring."
- (interactive)
- (emerge-validate-difference)
- (let* ((diff-vector
- (aref emerge-difference-list emerge-current-difference))
- (B-begin (1+ (aref diff-vector 2)))
- (B-end (1- (aref diff-vector 3)))
- ;; so further kills don't append
- this-command)
- (with-current-buffer emerge-B-buffer
- (copy-region-as-kill B-begin B-end))))
-
-(defun emerge-insert-A (arg)
- "Insert the A variant of this difference at the point.
-Leaves point after text, mark before.
-With prefix argument, puts point before, mark after."
- (interactive "P")
- (emerge-validate-difference)
- (let* ((diff-vector
- (aref emerge-difference-list emerge-current-difference))
- (A-begin (1+ (aref diff-vector 0)))
- (A-end (1- (aref diff-vector 1)))
- (opoint (point))
- (buffer-read-only nil))
- (insert-buffer-substring emerge-A-buffer A-begin A-end)
- (if (not arg)
- (set-mark opoint)
- (set-mark (point))
- (goto-char opoint))))
-
-(defun emerge-insert-B (arg)
- "Insert the B variant of this difference at the point.
-Leaves point after text, mark before.
-With prefix argument, puts point before, mark after."
- (interactive "P")
- (emerge-validate-difference)
- (let* ((diff-vector
- (aref emerge-difference-list emerge-current-difference))
- (B-begin (1+ (aref diff-vector 2)))
- (B-end (1- (aref diff-vector 3)))
- (opoint (point))
- (buffer-read-only nil))
- (insert-buffer-substring emerge-B-buffer B-begin B-end)
- (if (not arg)
- (set-mark opoint)
- (set-mark (point))
- (goto-char opoint))))
-
-(defun emerge-mark-difference (arg)
- "Leaves the point before this difference and the mark after it.
-With prefix argument, puts mark before, point after."
- (interactive "P")
- (emerge-validate-difference)
- (let* ((diff-vector
- (aref emerge-difference-list emerge-current-difference))
- (merge-begin (1+ (aref diff-vector 4)))
- (merge-end (1- (aref diff-vector 5))))
- (if (not arg)
- (progn
- (goto-char merge-begin)
- (set-mark merge-end))
- (goto-char merge-end)
- (set-mark merge-begin))))
-
-(defun emerge-file-names ()
- "Show the names of the buffers or files being operated on by Emerge.
-Use C-u l to reset the windows afterward."
- (interactive)
- (delete-other-windows)
- (let ((temp-buffer-show-function
- (function (lambda (buf)
- (split-window-vertically)
- (switch-to-buffer buf)
- (other-window 1)))))
- (with-output-to-temp-buffer "*Help*"
- (emerge-eval-in-buffer emerge-A-buffer
- (if buffer-file-name
- (progn
- (princ "File A is: ")
- (princ buffer-file-name))
- (progn
- (princ "Buffer A is: ")
- (princ (buffer-name))))
- (princ "\n"))
- (emerge-eval-in-buffer emerge-B-buffer
- (if buffer-file-name
- (progn
- (princ "File B is: ")
- (princ buffer-file-name))
- (progn
- (princ "Buffer B is: ")
- (princ (buffer-name))))
- (princ "\n"))
- (if emerge-ancestor-buffer
- (emerge-eval-in-buffer emerge-ancestor-buffer
- (if buffer-file-name
- (progn
- (princ "Ancestor file is: ")
- (princ buffer-file-name))
- (progn
- (princ "Ancestor buffer is: ")
- (princ (buffer-name))))
- (princ "\n")))
- (princ emerge-output-description)
- (with-current-buffer standard-output
- (help-mode)))))
-
-(defun emerge-join-differences (arg)
- "Join the selected difference with the following one.
-With a prefix argument, join with the preceding one."
- (interactive "P")
- (let ((n emerge-current-difference))
- ;; adjust n to be first difference to join
- (if arg
- (setq n (1- n)))
- ;; n and n+1 are the differences to join
- ;; check that they are both differences
- (if (or (< n 0) (>= n (1- emerge-number-of-differences)))
- (error "Incorrect differences to join"))
- ;; remove the flags
- (emerge-unselect-difference emerge-current-difference)
- ;; decrement total number of differences
- (setq emerge-number-of-differences (1- emerge-number-of-differences))
- ;; build new differences vector
- (let ((i 0)
- (new-differences (make-vector emerge-number-of-differences nil)))
- (while (< i emerge-number-of-differences)
- (aset new-differences i
- (cond
- ((< i n) (aref emerge-difference-list i))
- ((> i n) (aref emerge-difference-list (1+ i)))
- (t (let ((prev (aref emerge-difference-list i))
- (next (aref emerge-difference-list (1+ i))))
- (vector (aref prev 0)
- (aref next 1)
- (aref prev 2)
- (aref next 3)
- (aref prev 4)
- (aref next 5)
- (let ((ps (aref prev 6))
- (ns (aref next 6)))
- (cond
- ((eq ps ns)
- ps)
- ((and (or (eq ps 'B) (eq ps 'prefer-B))
- (or (eq ns 'B) (eq ns 'prefer-B)))
- 'B)
- (t 'A))))))))
- (setq i (1+ i)))
- (setq emerge-difference-list new-differences))
- ;; set the current difference correctly
- (setq emerge-current-difference n)
- ;; fix the mode line
- (emerge-refresh-mode-line)
- ;; reinsert the flags
- (emerge-select-difference emerge-current-difference)
- (emerge-recenter)))
-
-(defun emerge-split-difference ()
- "Split the current difference where the points are in the three windows."
- (interactive)
- (let ((n emerge-current-difference))
- ;; check that this is a valid difference
- (emerge-validate-difference)
- ;; get the point values and old difference
- (let ((A-point (emerge-eval-in-buffer emerge-A-buffer
- (point-marker)))
- (B-point (emerge-eval-in-buffer emerge-B-buffer
- (point-marker)))
- (merge-point (point-marker))
- (old-diff (aref emerge-difference-list n)))
- ;; check location of the points, give error if they aren't in the
- ;; differences
- (if (or (< A-point (aref old-diff 0))
- (> A-point (aref old-diff 1)))
- (error "Point outside of difference in A buffer"))
- (if (or (< B-point (aref old-diff 2))
- (> B-point (aref old-diff 3)))
- (error "Point outside of difference in B buffer"))
- (if (or (< merge-point (aref old-diff 4))
- (> merge-point (aref old-diff 5)))
- (error "Point outside of difference in merge buffer"))
- ;; remove the flags
- (emerge-unselect-difference emerge-current-difference)
- ;; increment total number of differences
- (setq emerge-number-of-differences (1+ emerge-number-of-differences))
- ;; build new differences vector
- (let ((i 0)
- (new-differences (make-vector emerge-number-of-differences nil)))
- (while (< i emerge-number-of-differences)
- (aset new-differences i
- (cond
- ((< i n)
- (aref emerge-difference-list i))
- ((> i (1+ n))
- (aref emerge-difference-list (1- i)))
- ((= i n)
- (vector (aref old-diff 0)
- A-point
- (aref old-diff 2)
- B-point
- (aref old-diff 4)
- merge-point
- (aref old-diff 6)))
- (t
- (vector (copy-marker A-point)
- (aref old-diff 1)
- (copy-marker B-point)
- (aref old-diff 3)
- (copy-marker merge-point)
- (aref old-diff 5)
- (aref old-diff 6)))))
- (setq i (1+ i)))
- (setq emerge-difference-list new-differences))
- ;; set the current difference correctly
- (setq emerge-current-difference n)
- ;; fix the mode line
- (emerge-refresh-mode-line)
- ;; reinsert the flags
- (emerge-select-difference emerge-current-difference)
- (emerge-recenter))))
-
-(defun emerge-trim-difference ()
- "Trim lines off top and bottom of difference that are the same.
-If lines are the same in both the A and the B versions, strip them off.
-\(This can happen when the A and B versions have common lines that the
-ancestor version does not share.)"
- (interactive)
- ;; make sure we are in a real difference
- (emerge-validate-difference)
- ;; remove the flags
- (emerge-unselect-difference emerge-current-difference)
- (let* ((diff (aref emerge-difference-list emerge-current-difference))
- (top-a (marker-position (aref diff 0)))
- (bottom-a (marker-position (aref diff 1)))
- (top-b (marker-position (aref diff 2)))
- (bottom-b (marker-position (aref diff 3)))
- (top-m (marker-position (aref diff 4)))
- (bottom-m (marker-position (aref diff 5)))
- size success sa sb sm)
- ;; move down the tops of the difference regions as much as possible
- ;; Try advancing comparing 1000 chars at a time.
- ;; When that fails, go 500 chars at a time, and so on.
- (setq size 1000)
- (while (> size 0)
- (setq success t)
- (while success
- (setq size (min size (- bottom-a top-a) (- bottom-b top-b)
- (- bottom-m top-m)))
- (setq sa (emerge-eval-in-buffer emerge-A-buffer
- (buffer-substring top-a
- (+ size top-a))))
- (setq sb (emerge-eval-in-buffer emerge-B-buffer
- (buffer-substring top-b
- (+ size top-b))))
- (setq sm (buffer-substring top-m (+ size top-m)))
- (setq success (and (> size 0) (equal sa sb) (equal sb sm)))
- (if success
- (setq top-a (+ top-a size)
- top-b (+ top-b size)
- top-m (+ top-m size))))
- (setq size (/ size 2)))
- ;; move up the bottoms of the difference regions as much as possible
- ;; Try advancing comparing 1000 chars at a time.
- ;; When that fails, go 500 chars at a time, and so on.
- (setq size 1000)
- (while (> size 0)
- (setq success t)
- (while success
- (setq size (min size (- bottom-a top-a) (- bottom-b top-b)
- (- bottom-m top-m)))
- (setq sa (emerge-eval-in-buffer emerge-A-buffer
- (buffer-substring (- bottom-a size)
- bottom-a)))
- (setq sb (emerge-eval-in-buffer emerge-B-buffer
- (buffer-substring (- bottom-b size)
- bottom-b)))
- (setq sm (buffer-substring (- bottom-m size) bottom-m))
- (setq success (and (> size 0) (equal sa sb) (equal sb sm)))
- (if success
- (setq bottom-a (- bottom-a size)
- bottom-b (- bottom-b size)
- bottom-m (- bottom-m size))))
- (setq size (/ size 2)))
- ;; {top,bottom}-{a,b,m} are now set at the new beginnings and ends
- ;; of the difference regions. Move them to the beginning of lines, as
- ;; appropriate.
- (emerge-eval-in-buffer emerge-A-buffer
- (goto-char top-a)
- (beginning-of-line)
- (aset diff 0 (point-marker))
- (goto-char bottom-a)
- (beginning-of-line 2)
- (aset diff 1 (point-marker)))
- (emerge-eval-in-buffer emerge-B-buffer
- (goto-char top-b)
- (beginning-of-line)
- (aset diff 2 (point-marker))
- (goto-char bottom-b)
- (beginning-of-line 2)
- (aset diff 3 (point-marker)))
- (goto-char top-m)
- (beginning-of-line)
- (aset diff 4 (point-marker))
- (goto-char bottom-m)
- (beginning-of-line 2)
- (aset diff 5 (point-marker))
- ;; put the flags back in, recenter the display
- (emerge-select-difference emerge-current-difference)
- (emerge-recenter)))
-
-;; FIXME the manual advertised this as working in the A or B buffers,
-;; but it does not, because all the buffer locals are nil there.
-;; It would work to call it from the merge buffer and specify that one
-;; wants to use the value of point in the A or B buffer.
-;; But with the prefix argument already in use, there is no easy way
-;; to have it ask for a buffer.
-(defun emerge-find-difference (arg)
- "Find the difference containing the current position of the point.
-If there is no containing difference and the prefix argument is positive,
-it finds the nearest following difference. A negative prefix argument finds
-the nearest previous difference."
- (interactive "P")
- (cond ((eq (current-buffer) emerge-A-buffer)
- (emerge-find-difference-A arg))
- ((eq (current-buffer) emerge-B-buffer)
- (emerge-find-difference-B arg))
- (t (emerge-find-difference-merge arg))))
-
-(defun emerge-find-difference-merge (arg)
- "Find the difference containing point, in the merge buffer.
-If there is no containing difference and the prefix argument is positive,
-it finds the nearest following difference. A negative prefix argument finds
-the nearest previous difference."
- (interactive "P")
- ;; search for the point in the merge buffer, using the markers
- ;; for the beginning and end of the differences in the merge buffer
- (emerge-find-difference1 arg (point) 4 5))
-
-(defun emerge-find-difference-A (arg)
- "Find the difference containing point, in the A buffer.
-This command must be executed in the merge buffer.
-If there is no containing difference and the prefix argument is positive,
-it finds the nearest following difference. A negative prefix argument finds
-the nearest previous difference."
- (interactive "P")
- ;; search for the point in the A buffer, using the markers
- ;; for the beginning and end of the differences in the A buffer
- (emerge-find-difference1 arg
- (emerge-eval-in-buffer emerge-A-buffer (point))
- 0 1))
-
-(defun emerge-find-difference-B (arg)
- "Find the difference containing point, in the B buffer.
-This command must be executed in the merge buffer.
-If there is no containing difference and the prefix argument is positive,
-it finds the nearest following difference. A negative prefix argument finds
-the nearest previous difference."
- (interactive "P")
- ;; search for the point in the B buffer, using the markers
- ;; for the beginning and end of the differences in the B buffer
- (emerge-find-difference1 arg
- (emerge-eval-in-buffer emerge-B-buffer (point))
- 2 3))
-
-(defun emerge-find-difference1 (arg location begin end)
- (let* ((index
- ;; find first difference containing or after the current position
- (catch 'search
- (let ((n 0))
- (while (< n emerge-number-of-differences)
- (let ((diff-vector (aref emerge-difference-list n)))
- (if (<= location (marker-position (aref diff-vector end)))
- (throw 'search n)))
- (setq n (1+ n))))
- emerge-number-of-differences))
- (contains
- ;; whether the found difference contains the current position
- (and (< index emerge-number-of-differences)
- (<= (marker-position (aref (aref emerge-difference-list index)
- begin))
- location)))
- (arg-value
- ;; numeric value of prefix argument
- (prefix-numeric-value arg)))
- (emerge-unselect-and-select-difference
- (cond
- ;; if the point is in a difference, select it
- (contains index)
- ;; if the arg is nil and the point is not in a difference, error
- ((null arg) (error "No difference contains point"))
- ;; if the arg is positive, select the following difference
- ((> arg-value 0)
- (if (< index emerge-number-of-differences)
- index
- (error "No difference contains or follows point")))
- ;; if the arg is negative, select the preceding difference
- (t
- (if (> index 0)
- (1- index)
- (error "No difference contains or precedes point")))))))
-
-(defun emerge-line-numbers ()
- "Display the current line numbers.
-This function displays the line numbers of the points in the A, B, and
-merge buffers."
- (interactive)
- (let* ((valid-diff
- (and (>= emerge-current-difference 0)
- (< emerge-current-difference emerge-number-of-differences)))
- (diff (and valid-diff
- (aref emerge-difference-list emerge-current-difference)))
- (merge-line (emerge-line-number-in-buf 4 5))
- (A-line (emerge-eval-in-buffer emerge-A-buffer
- (emerge-line-number-in-buf 0 1)))
- (B-line (emerge-eval-in-buffer emerge-B-buffer
- (emerge-line-number-in-buf 2 3))))
- (message "At lines: merge = %d, A = %d, B = %d"
- merge-line A-line B-line)))
-
-(defun emerge-line-number-in-buf (begin-marker end-marker)
- (let (temp)
- (setq temp (save-excursion
- (beginning-of-line)
- (1+ (count-lines 1 (point)))))
- (if valid-diff
- (progn
- (if (> (point) (aref diff begin-marker))
- (setq temp (- temp emerge-before-flag-lines)))
- (if (> (point) (aref diff end-marker))
- (setq temp (- temp emerge-after-flag-lines)))))
- temp))
-
-(defun emerge-set-combine-template (string &optional localize)
- "Set `emerge-combine-versions-template' to STRING.
-This value controls how `emerge-combine-versions' combines the two versions.
-With prefix argument, `emerge-combine-versions-template' is made local to this
-merge buffer. Localization is permanent for any particular merge buffer."
- (interactive "s\nP")
- (if localize
- (make-local-variable 'emerge-combine-versions-template))
- (setq emerge-combine-versions-template string)
- (message
- (if (assq 'emerge-combine-versions-template (buffer-local-variables))
- "emerge-set-combine-versions-template set locally"
- "emerge-set-combine-versions-template set")))
-
-(defun emerge-set-combine-versions-template (start end &optional localize)
- "Copy region into `emerge-combine-versions-template'.
-This controls how `emerge-combine-versions' will combine the two versions.
-With prefix argument, `emerge-combine-versions-template' is made local to this
-merge buffer. Localization is permanent for any particular merge buffer."
- (interactive "r\nP")
- (if localize
- (make-local-variable 'emerge-combine-versions-template))
- (setq emerge-combine-versions-template (buffer-substring start end))
- (message
- (if (assq 'emerge-combine-versions-template (buffer-local-variables))
- "emerge-set-combine-versions-template set locally."
- "emerge-set-combine-versions-template set.")))
-
-(defun emerge-combine-versions (&optional force)
- "Combine versions using the template in `emerge-combine-versions-template'.
-Refuses to function if this difference has been edited, i.e., if it is
-neither the A nor the B variant.
-An argument forces the variant to be selected even if the difference has
-been edited."
- (interactive "P")
- (emerge-combine-versions-internal emerge-combine-versions-template force))
-
-(defun emerge-combine-versions-register (char &optional force)
- "Combine the two versions using the template in register REG.
-See documentation of the variable `emerge-combine-versions-template'
-for how the template is interpreted.
-Refuses to function if this difference has been edited, i.e., if it is
-neither the A nor the B variant.
-An argument forces the variant to be selected even if the difference has
-been edited."
- (interactive "cRegister containing template: \nP")
- (let ((template (get-register char)))
- (if (not (stringp template))
- (error "Register does not contain text"))
- (emerge-combine-versions-internal template force)))
-
-(defun emerge-combine-versions-internal (template force)
- (let ((operate
- (function (lambda ()
- (emerge-combine-versions-edit merge-begin merge-end
- A-begin A-end B-begin B-end)
- (if emerge-auto-advance
- (emerge-next-difference))))))
- (emerge-select-version force operate operate operate)))
-
-(defun emerge-combine-versions-edit (merge-begin merge-end
- A-begin A-end B-begin B-end)
- (emerge-eval-in-buffer
- emerge-merge-buffer
- (delete-region merge-begin merge-end)
- (goto-char merge-begin)
- (let ((i 0))
- (while (< i (length template))
- (let ((c (aref template i)))
- (if (= c ?%)
- (progn
- (setq i (1+ i))
- (setq c
- (condition-case nil
- (aref template i)
- (error ?%)))
- (cond ((= c ?a)
- (insert-buffer-substring emerge-A-buffer A-begin A-end))
- ((= c ?b)
- (insert-buffer-substring emerge-B-buffer B-begin B-end))
- ((= c ?%)
- (insert ?%))
- (t
- (insert c))))
- (insert c)))
- (setq i (1+ i))))
- (goto-char merge-begin)
- (aset diff-vector 6 'combined)
- (emerge-refresh-mode-line)))
-
-(defun emerge-set-merge-mode (mode)
- "Set the major mode in a merge buffer.
-Overrides any change that the mode might make to the mode line or local
-keymap. Leaves merge in fast mode."
- (interactive
- (list (intern (completing-read "New major mode for merge buffer: "
- obarray 'commandp t nil))))
- (funcall mode)
- (emerge-refresh-mode-line)
- (if emerge-fast-mode
- (emerge-fast-mode)
- (emerge-edit-mode)))
-
-(defun emerge-one-line-window ()
- (interactive)
- (let ((window-min-height 1))
- (shrink-window (- (window-height) 2))))
-
-;;; Support routines
-
-;; Select a difference by placing the visual flags around the appropriate
-;; group of lines in the A, B, and merge buffers
-(defun emerge-select-difference (n)
- (let ((emerge-globalized-difference-list emerge-difference-list)
- (emerge-globalized-number-of-differences emerge-number-of-differences))
- (emerge-place-flags-in-buffer emerge-A-buffer n 0 1)
- (emerge-place-flags-in-buffer emerge-B-buffer n 2 3)
- (emerge-place-flags-in-buffer nil n 4 5))
- (run-hooks 'emerge-select-hook))
-
-(defun emerge-place-flags-in-buffer (buffer difference before-index
- after-index)
- (if buffer
- (emerge-eval-in-buffer
- buffer
- (emerge-place-flags-in-buffer1 difference before-index after-index))
- (emerge-place-flags-in-buffer1 difference before-index after-index)))
-
-(defun emerge-place-flags-in-buffer1 (difference before-index after-index)
- (let ((buffer-read-only nil))
- ;; insert the flag before the difference
- (let ((before (aref (aref emerge-globalized-difference-list difference)
- before-index))
- here)
- (goto-char before)
- ;; insert the flag itself
- (insert-before-markers emerge-before-flag)
- (setq here (point))
- ;; Put the marker(s) referring to this position 1 character before the
- ;; end of the flag, so it won't be damaged by the user.
- ;; This gets a bit tricky, as there could be a number of markers
- ;; that have to be moved.
- (set-marker before (1- before))
- (let ((n (1- difference)) after-marker before-marker diff-list)
- (while (and
- (>= n 0)
- (progn
- (setq diff-list (aref emerge-globalized-difference-list n)
- after-marker (aref diff-list after-index))
- (= after-marker here)))
- (set-marker after-marker (1- after-marker))
- (setq before-marker (aref diff-list before-index))
- (if (= before-marker here)
- (setq before-marker (1- before-marker)))
- (setq n (1- n)))))
- ;; insert the flag after the difference
- (let* ((after (aref (aref emerge-globalized-difference-list difference)
- after-index))
- (here (marker-position after)))
- (goto-char here)
- ;; insert the flag itself
- (insert emerge-after-flag)
- ;; Put the marker(s) referring to this position 1 character after the
- ;; beginning of the flag, so it won't be damaged by the user.
- ;; This gets a bit tricky, as there could be a number of markers
- ;; that have to be moved.
- (set-marker after (1+ after))
- (let ((n (1+ difference)) before-marker after-marker diff-list)
- (while (and
- (< n emerge-globalized-number-of-differences)
- (progn
- (setq diff-list (aref emerge-globalized-difference-list n)
- before-marker (aref diff-list before-index))
- (= before-marker here)))
- (set-marker before-marker (1+ before-marker))
- (setq after-marker (aref diff-list after-index))
- (if (= after-marker here)
- (setq after-marker (1+ after-marker)))
- (setq n (1+ n)))))))
-
-;; Unselect a difference by removing the visual flags in the buffers.
-(defun emerge-unselect-difference (n)
- (let ((diff-vector (aref emerge-difference-list n)))
- (emerge-remove-flags-in-buffer emerge-A-buffer
- (aref diff-vector 0) (aref diff-vector 1))
- (emerge-remove-flags-in-buffer emerge-B-buffer
- (aref diff-vector 2) (aref diff-vector 3))
- (emerge-remove-flags-in-buffer emerge-merge-buffer
- (aref diff-vector 4) (aref diff-vector 5)))
- (run-hooks 'emerge-unselect-hook))
-
-(defun emerge-remove-flags-in-buffer (buffer before after)
- (emerge-eval-in-buffer
- buffer
- (let ((buffer-read-only nil))
- ;; remove the flags, if they're there
- (goto-char (- before (1- emerge-before-flag-length)))
- (if (looking-at emerge-before-flag-match)
- (delete-char emerge-before-flag-length)
- ;; the flag isn't there
- (ding)
- (message "Trouble removing flag"))
- (goto-char (1- after))
- (if (looking-at emerge-after-flag-match)
- (delete-char emerge-after-flag-length)
- ;; the flag isn't there
- (ding)
- (message "Trouble removing flag")))))
-
-;; Select a difference, removing any flags that exist now.
-(defun emerge-unselect-and-select-difference (n &optional suppress-display)
- (if (and (>= emerge-current-difference 0)
- (< emerge-current-difference emerge-number-of-differences))
- (emerge-unselect-difference emerge-current-difference))
- (if (and (>= n 0) (< n emerge-number-of-differences))
- (progn
- (emerge-select-difference n)
- (let* ((diff-vector (aref emerge-difference-list n))
- (selection-type (aref diff-vector 6)))
- (if (eq selection-type 'default-A)
- (aset diff-vector 6 'A)
- (if (eq selection-type 'default-B)
- (aset diff-vector 6 'B))))))
- (setq emerge-current-difference n)
- (if (not suppress-display)
- (progn
- (emerge-recenter)
- (emerge-refresh-mode-line))))
-
-;; Perform tests to see whether user should be allowed to select a version
-;; of this difference:
-;; a valid difference has been selected; and
-;; the difference text in the merge buffer is:
-;; the A version (execute a-version), or
-;; the B version (execute b-version), or
-;; empty (execute neither-version), or
-;; argument FORCE is true (execute neither-version)
-;; Otherwise, signal an error.
-(defun emerge-select-version (force a-version b-version neither-version)
- (emerge-validate-difference)
- (let ((buffer-read-only nil))
- (let* ((diff-vector
- (aref emerge-difference-list emerge-current-difference))
- (A-begin (1+ (aref diff-vector 0)))
- (A-end (1- (aref diff-vector 1)))
- (B-begin (1+ (aref diff-vector 2)))
- (B-end (1- (aref diff-vector 3)))
- (merge-begin (1+ (aref diff-vector 4)))
- (merge-end (1- (aref diff-vector 5))))
- (if (emerge-compare-buffers emerge-A-buffer A-begin A-end
- emerge-merge-buffer merge-begin
- merge-end)
- (funcall a-version)
- (if (emerge-compare-buffers emerge-B-buffer B-begin B-end
- emerge-merge-buffer merge-begin
- merge-end)
- (funcall b-version)
- (if (or force (= merge-begin merge-end))
- (funcall neither-version)
- (error "This difference region has been edited")))))))
-
-;; Read a file name, handling all of the various defaulting rules.
-
-(defun emerge-read-file-name (prompt alternative-default-dir default-file
- A-file must-match)
- ;; `prompt' should not have trailing ": ", so that it can be modified
- ;; according to context.
- ;; If alternative-default-dir is non-nil, it should be used as the default
- ;; directory instead if default-directory, if emerge-default-last-directories
- ;; is set.
- ;; If default-file is set, it should be used as the default value.
- ;; If A-file is set, and its directory is different from
- ;; alternative-default-dir, and if emerge-default-last-directories is set,
- ;; the default file should be the last part of A-file in the default
- ;; directory. (Overriding default-file.)
- (cond
- ;; If this is not the A-file argument (shown by non-nil A-file), and
- ;; if emerge-default-last-directories is set, and
- ;; the default directory exists but is not the same as the directory of the
- ;; A-file,
- ;; then make the default file have the same name as the A-file, but in
- ;; the default directory.
- ((and emerge-default-last-directories
- A-file
- alternative-default-dir
- (not (string-equal alternative-default-dir
- (file-name-directory A-file))))
- (read-file-name (format "%s (default %s): "
- prompt (file-name-nondirectory A-file))
- alternative-default-dir
- (concat alternative-default-dir
- (file-name-nondirectory A-file))
- (and must-match 'confirm)))
- ;; If there is a default file, use it.
- (default-file
- (read-file-name (format "%s (default %s): " prompt default-file)
- ;; If emerge-default-last-directories is set, use the
- ;; directory from the same argument of the last call of
- ;; Emerge as the default for this argument.
- (and emerge-default-last-directories
- alternative-default-dir)
- default-file (and must-match 'confirm)))
- (t
- (read-file-name (concat prompt ": ")
- ;; If emerge-default-last-directories is set, use the
- ;; directory from the same argument of the last call of
- ;; Emerge as the default for this argument.
- (and emerge-default-last-directories
- alternative-default-dir)
- nil (and must-match 'confirm)))))
-
-;; Revise the mode line to display which difference we have selected
-
-(defun emerge-refresh-mode-line ()
- (setq mode-line-buffer-identification
- (list (format "Emerge: %%b diff %d of %d%s"
- (1+ emerge-current-difference)
- emerge-number-of-differences
- (if (and (>= emerge-current-difference 0)
- (< emerge-current-difference
- emerge-number-of-differences))
- (cdr (assq (aref (aref emerge-difference-list
- emerge-current-difference)
- 6)
- '((A . " - A")
- (B . " - B")
- (prefer-A . " - A*")
- (prefer-B . " - B*")
- (combined . " - comb"))))
- ""))))
- (force-mode-line-update))
-
-;; compare two regions in two buffers for containing the same text
-(defun emerge-compare-buffers (buffer-x x-begin x-end buffer-y y-begin y-end)
- ;; first check that the two regions are the same length
- (if (not (and (= (- x-end x-begin) (- y-end y-begin))))
- nil
- (catch 'exit
- (while (< x-begin x-end)
- ;; bite off and compare no more than 1000 characters at a time
- (let* ((compare-length (min (- x-end x-begin) 1000))
- (x-string (emerge-eval-in-buffer
- buffer-x
- (buffer-substring x-begin
- (+ x-begin compare-length))))
- (y-string (emerge-eval-in-buffer
- buffer-y
- (buffer-substring y-begin
- (+ y-begin compare-length)))))
- (if (not (string-equal x-string y-string))
- (throw 'exit nil)
- (setq x-begin (+ x-begin compare-length))
- (setq y-begin (+ y-begin compare-length)))))
- t)))
-
-;; Construct a unique buffer name.
-;; The first one tried is prefixsuffix, then prefix<2>suffix,
-;; prefix<3>suffix, etc.
-(defun emerge-unique-buffer-name (prefix suffix)
- (if (null (get-buffer (concat prefix suffix)))
- (concat prefix suffix)
- (let ((n 2))
- (while (get-buffer (format "%s<%d>%s" prefix n suffix))
- (setq n (1+ n)))
- (format "%s<%d>%s" prefix n suffix))))
-
-;; Verify that we have a difference selected.
-(defun emerge-validate-difference ()
- (if (not (and (>= emerge-current-difference 0)
- (< emerge-current-difference emerge-number-of-differences)))
- (error "No difference selected")))
-
-;;; Functions for saving and restoring a batch of variables
-
-;; These functions save (get the values of) and restore (set the values of)
-;; a list of variables. The argument is a list of symbols (the names of
-;; the variables). A list element can also be a list of two functions,
-;; the first of which (when called with no arguments) gets the value, and
-;; the second (when called with a value as an argument) sets the value.
-;; A "function" is anything that funcall can handle as an argument.
-
-(defun emerge-save-variables (vars)
- (mapcar (function (lambda (v) (if (symbolp v)
- (symbol-value v)
- (funcall (car v)))))
- vars))
-
-(defun emerge-restore-variables (vars values)
- (while vars
- (let ((var (car vars))
- (value (car values)))
- (if (symbolp var)
- (set var value)
- (funcall (car (cdr var)) value)))
- (setq vars (cdr vars))
- (setq values (cdr values))))
-
-;; Make a temporary file that only we have access to.
-;; PREFIX is appended to emerge-temp-file-prefix to make the filename prefix.
-(defun emerge-make-temp-file (prefix)
- (let (f (old-modes (default-file-modes)))
- (unwind-protect
- (progn
- (set-default-file-modes emerge-temp-file-mode)
- (setq f (make-temp-file (concat emerge-temp-file-prefix prefix))))
- (set-default-file-modes old-modes))
- f))
-
-;;; Functions that query the user before he can write out the current buffer.
-
-(defun emerge-query-write-file ()
- "Ask the user whether to write out an incomplete merge.
-If answer is yes, call `write-file' to do so. See `emerge-query-and-call'
-for details of the querying process."
- (interactive)
- (emerge-query-and-call 'write-file))
-
-(defun emerge-query-save-buffer ()
- "Ask the user whether to save an incomplete merge.
-If answer is yes, call `save-buffer' to do so. See `emerge-query-and-call'
-for details of the querying process."
- (interactive)
- (emerge-query-and-call 'save-buffer))
-
-(defun emerge-query-and-call (command)
- "Ask the user whether to save or write out the incomplete merge.
-If answer is yes, call COMMAND interactively. During the call, the flags
-around the current difference are removed."
- (if (yes-or-no-p "Do you really write to write out this unfinished merge? ")
- ;; He really wants to do it -- unselect the difference for the duration
- (progn
- (if (and (>= emerge-current-difference 0)
- (< emerge-current-difference emerge-number-of-differences))
- (emerge-unselect-difference emerge-current-difference))
- ;; call-interactively takes the value of current-prefix-arg as the
- ;; prefix argument value to be passed to the command. Thus, we have
- ;; to do nothing special to make sure the prefix argument is
- ;; transmitted to the command.
- (call-interactively command)
- (if (and (>= emerge-current-difference 0)
- (< emerge-current-difference emerge-number-of-differences))
- (progn
- (emerge-select-difference emerge-current-difference)
- (emerge-recenter))))
- ;; He's being smart and not doing it
- (message "Not written")))
-
-;; Make sure the current buffer (for a file) has the same contents as the
-;; file on disk, and attempt to remedy the situation if not.
-;; Signal an error if we can't make them the same, or the user doesn't want
-;; to do what is necessary to make them the same.
-(defun emerge-verify-file-buffer ()
- ;; First check if the file has been modified since the buffer visited it.
- (if (verify-visited-file-modtime (current-buffer))
- (if (buffer-modified-p)
- ;; If buffer is not obsolete and is modified, offer to save
- (if (yes-or-no-p (format "Save file %s? " buffer-file-name))
- (save-buffer)
- (error "Buffer out of sync for file %s" buffer-file-name))
- ;; If buffer is not obsolete and is not modified, do nothing
- nil)
- (if (buffer-modified-p)
- ;; If buffer is obsolete and is modified, give error
- (error "Buffer out of sync for file %s" buffer-file-name)
- ;; If buffer is obsolete and is not modified, offer to revert
- (if (yes-or-no-p (format "Revert file %s? " buffer-file-name))
- (revert-buffer t t)
- (error "Buffer out of sync for file %s" buffer-file-name)))))
-\f
-;; Utilities that might have value outside of Emerge.
-
-;; Set up the mode in the current buffer to duplicate the mode in another
-;; buffer.
-(defun emerge-copy-modes (buffer)
- ;; Set the major mode
- (funcall (emerge-eval-in-buffer buffer major-mode)))
-
-;; Define a key, even if a prefix of it is defined
-(defun emerge-force-define-key (keymap key definition)
- "Like `define-key', but forcibly creates prefix characters as needed.
-If some prefix of KEY has a non-prefix definition, it is redefined."
- ;; Find out if a prefix of key is defined
- (let ((v (lookup-key keymap key)))
- ;; If so, undefine it
- (if (integerp v)
- (define-key keymap (substring key 0 v) nil)))
- ;; Now define the key
- (define-key keymap key definition))
-
-;;;;; Improvements to describe-mode, so that it describes minor modes as well
-;;;;; as the major mode
-;;(defun describe-mode (&optional minor)
-;; "Display documentation of current major mode.
-;;If optional arg MINOR is non-nil (or prefix argument is given if interactive),
-;;display documentation of active minor modes as well.
-;;For this to work correctly for a minor mode, the mode's indicator variable
-;;\(listed in `minor-mode-alist') must also be a function whose documentation
-;;describes the minor mode."
-;; (interactive)
-;; (with-output-to-temp-buffer "*Help*"
-;; (princ mode-name)
-;; (princ " Mode:\n")
-;; (princ (documentation major-mode))
-;; (let ((minor-modes minor-mode-alist)
-;; (locals (buffer-local-variables)))
-;; (while minor-modes
-;; (let* ((minor-mode (car (car minor-modes)))
-;; (indicator (car (cdr (car minor-modes))))
-;; (local-binding (assq minor-mode locals)))
-;; ;; Document a minor mode if it is listed in minor-mode-alist,
-;; ;; bound locally in this buffer, non-nil, and has a function
-;; ;; definition.
-;; (if (and local-binding
-;; (cdr local-binding)
-;; (fboundp minor-mode))
-;; (progn
-;; (princ (format "\n\n\n%s minor mode (indicator%s):\n"
-;; minor-mode indicator))
-;; (princ (documentation minor-mode)))))
-;; (setq minor-modes (cdr minor-modes))))
-;; (with-current-buffer standard-output
-;; (help-mode))
-;; (help-print-return-message)))
-
-;; This goes with the redefinition of describe-mode.
-;;;; Adjust things so that keyboard macro definitions are documented correctly.
-;;(fset 'defining-kbd-macro (symbol-function 'start-kbd-macro))
-
-;; substitute-key-definition should work now.
-;;;; Function to shadow a definition in a keymap with definitions in another.
-;;(defun emerge-shadow-key-definition (olddef newdef keymap shadowmap)
-;; "Shadow OLDDEF with NEWDEF for any keys in KEYMAP with entries in SHADOWMAP.
-;;In other words, SHADOWMAP will now shadow all definitions of OLDDEF in KEYMAP
-;;with NEWDEF. Does not affect keys that are already defined in SHADOWMAP,
-;;including those whose definition is OLDDEF."
-;; ;; loop through all keymaps accessible from keymap
-;; (let ((maps (accessible-keymaps keymap)))
-;; (while maps
-;; (let ((prefix (car (car maps)))
-;; (map (cdr (car maps))))
-;; ;; examine a keymap
-;; (if (arrayp map)
-;; ;; array keymap
-;; (let ((len (length map))
-;; (i 0))
-;; (while (< i len)
-;; (if (eq (aref map i) olddef)
-;; ;; set the shadowing definition
-;; (let ((key (concat prefix (char-to-string i))))
-;; (emerge-define-key-if-possible shadowmap key newdef)))
-;; (setq i (1+ i))))
-;; ;; sparse keymap
-;; (while map
-;; (if (eq (cdr-safe (car-safe map)) olddef)
-;; ;; set the shadowing definition
-;; (let ((key
-;; (concat prefix (char-to-string (car (car map))))))
-;; (emerge-define-key-if-possible shadowmap key newdef)))
-;; (setq map (cdr map)))))
-;; (setq maps (cdr maps)))))
-
-;; Define a key if it (or a prefix) is not already defined in the map.
-(defun emerge-define-key-if-possible (keymap key definition)
- ;; look up the present definition of the key
- (let ((present (lookup-key keymap key)))
- (if (integerp present)
- ;; if it is "too long", look up the valid prefix
- (if (not (lookup-key keymap (substring key 0 present)))
- ;; if the prefix isn't defined, define it
- (define-key keymap key definition))
- ;; if there is no present definition, define it
- (if (not present)
- (define-key keymap key definition)))))
-
-;; Ordinary substitute-key-definition should do this now.
-;;(defun emerge-recursively-substitute-key-definition (olddef newdef keymap)
-;; "Like `substitute-key-definition', but act recursively on subkeymaps.
-;;Make sure that subordinate keymaps aren't shared with other keymaps!
-;;\(`copy-keymap' will suffice.)"
-;; ;; Loop through all keymaps accessible from keymap
-;; (let ((maps (accessible-keymaps keymap)))
-;; (while maps
-;; ;; Substitute in this keymap
-;; (substitute-key-definition olddef newdef (cdr (car maps)))
-;; (setq maps (cdr maps)))))
-
-;; Show the name of the file in the buffer.
-(defun emerge-show-file-name ()
- "Displays the name of the file loaded into the current buffer.
-If the name won't fit on one line, the minibuffer is expanded to hold it,
-and the command waits for a keystroke from the user. If the keystroke is
-SPC, it is ignored; if it is anything else, it is processed as a command."
- (interactive)
- (let ((name (buffer-file-name)))
- (or name
- (setq name "Buffer has no file name."))
- (save-window-excursion
- (select-window (minibuffer-window))
- (unwind-protect
- (progn
- (erase-buffer)
- (insert name)
- (while (and (not (pos-visible-in-window-p))
- (not (window-full-height-p)))
- (enlarge-window 1))
- (let* ((echo-keystrokes 0)
- (c (read-event)))
- (if (not (eq c 32))
- (setq unread-command-events (list c)))))
- (erase-buffer)))))
-
-;; Improved auto-save file names.
-;; This function fixes many problems with the standard auto-save file names:
-;; Auto-save files for non-file buffers get put in the default directory
-;; for the buffer, whether that makes sense or not.
-;; Auto-save files for file buffers get put in the directory of the file,
-;; regardless of whether we can write into it or not.
-;; Auto-save files for non-file buffers don't use the process id, so if a
-;; user runs more than on Emacs, they can make auto-save files that overwrite
-;; each other.
-;; To use this function, do:
-;; (fset 'make-auto-save-file-name
-;; (symbol-function 'emerge-make-auto-save-file-name))
-(defun emerge-make-auto-save-file-name ()
- "Return file name to use for auto-saves of current buffer.
-Does not consider `auto-save-visited-file-name';
-that is checked before calling this function.
-You can redefine this for customization.
-See also `auto-save-file-name-p'."
- (if buffer-file-name
- ;; if buffer has a file, try the format <file directory>/#<file name>#
- (let ((f (concat (file-name-directory buffer-file-name)
- "#"
- (file-name-nondirectory buffer-file-name)
- "#")))
- (if (file-writable-p f)
- ;; the file is writable, so use it
- f
- ;; the file isn't writable, so use the format
- ;; ~/#&<file name>&<hash of directory>#
- (concat (getenv "HOME")
- "/#&"
- (file-name-nondirectory buffer-file-name)
- "&"
- (emerge-hash-string-into-string
- (file-name-directory buffer-file-name))
- "#")))
- ;; if buffer has no file, use the format ~/#%<buffer name>%<process id>#
- (expand-file-name (concat (getenv "HOME")
- "/#%"
- ;; quote / into \! and \ into \\
- (emerge-unslashify-name (buffer-name))
- "%"
- (make-temp-name "")
- "#"))))
-
-;; Hash a string into five characters more-or-less suitable for use in a file
-;; name. (Allowed characters are ! through ~, except /.)
-(defun emerge-hash-string-into-string (s)
- (let ((bins (vector 0 0 0 0 0))
- (i 0))
- (while (< i (length s))
- (aset bins (% i 5) (% (+ (* (aref bins (% i 5)) 35)
- (aref s i))
- 65536))
- (setq i (1+ i)))
- (mapconcat (function (lambda (b)
- (setq b (+ (% b 93) ?!))
- (if (>= b ?/)
- (setq b (1+ b)))
- (char-to-string b)))
- bins "")))
-
-;; Quote any /s in a string by replacing them with \!.
-;; Also, replace any \s by \\, to make it one-to-one.
-(defun emerge-unslashify-name (s)
- (let ((limit 0))
- (while (string-match "[/\\]" s limit)
- (setq s (concat (substring s 0 (match-beginning 0))
- (if (string= (substring s (match-beginning 0)
- (match-end 0))
- "/")
- "\\!"
- "\\\\")
- (substring s (match-end 0))))
- (setq limit (1+ (match-end 0)))))
- s)
-
-;; Metacharacters that have to be protected from the shell when executing
-;; a diff/diff3 command.
-(defcustom emerge-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]"
- "Characters that must be quoted with \\ when used in a shell command line.
-More precisely, a [...] regexp to match any one such character."
- :type 'regexp
- :group 'emerge)
-
-;; Quote metacharacters (using \) when executing a diff/diff3 command.
-(defun emerge-protect-metachars (s)
- (let ((limit 0))
- (while (string-match emerge-metachars s limit)
- (setq s (concat (substring s 0 (match-beginning 0))
- "\\"
- (substring s (match-beginning 0))))
- (setq limit (1+ (match-end 0)))))
- s)
-
-(provide 'emerge)
-
-;; arch-tag: a575f092-6e44-400e-b8a2-4124e9377585
-;;; emerge.el ends here
+++ /dev/null
-;;; log-edit.el --- Major mode for editing CVS commit messages
-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: pcl-cvs cvs commit log
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Todo:
-
-;; - Move in VC's code
-;; - Add compatibility for VC's hook variables
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'add-log) ; for all the ChangeLog goodies
-(require 'pcvs-util)
-(require 'ring)
-
-;;;;
-;;;; Global Variables
-;;;;
-
-(defgroup log-edit nil
- "Major mode for editing RCS and CVS commit messages."
- :group 'pcl-cvs
- :group 'vc ; It's used by VC.
- :version "21.1"
- :prefix "log-edit-")
-
-;; compiler pacifiers
-(defvar cvs-buffer)
-
-\f
-;; The main keymap
-
-(easy-mmode-defmap log-edit-mode-map
- `(("\C-c\C-c" . log-edit-done)
- ("\C-c\C-a" . log-edit-insert-changelog)
- ("\C-c\C-d" . log-edit-show-diff)
- ("\C-c\C-f" . log-edit-show-files)
- ("\M-n" . log-edit-next-comment)
- ("\M-p" . log-edit-previous-comment)
- ("\M-r" . log-edit-comment-search-backward)
- ("\M-s" . log-edit-comment-search-forward)
- ("\C-c?" . log-edit-mode-help))
- "Keymap for the `log-edit-mode' (to edit version control log messages)."
- :group 'log-edit)
-
-;; Compatibility with old names. Should we bother ?
-(defvar vc-log-mode-map log-edit-mode-map)
-(defvar vc-log-entry-mode vc-log-mode-map)
-
-(easy-menu-define log-edit-menu log-edit-mode-map
- "Menu used for `log-edit-mode'."
- '("Log-Edit"
- ["Done" log-edit-done
- :help "Exit log-edit and proceed with the actual action."]
- "--"
- ["Insert ChangeLog" log-edit-insert-changelog
- :help "Insert a log message by looking at the ChangeLog"]
- ["Add to ChangeLog" log-edit-add-to-changelog
- :help "Insert this log message into the appropriate ChangeLog file"]
- "--"
- ["Show diff" log-edit-show-diff
- :help "Show the diff for the files to be committed."]
- ["List files" log-edit-show-files
- :help "Show the list of relevant files."]
- "--"
- ["Previous comment" log-edit-previous-comment
- :help "Cycle backwards through comment history"]
- ["Next comment" log-edit-next-comment
- :help "Cycle forwards through comment history."]
- ["Search comment forward" log-edit-comment-search-forward
- :help "Search forwards through comment history for a substring match of str"]
- ["Search comment backward" log-edit-comment-search-backward
- :help "Search backwards through comment history for substring match of str"]))
-
-(defcustom log-edit-confirm 'changed
- "If non-nil, `log-edit-done' will request confirmation.
-If 'changed, only request confirmation if the list of files has
- changed since the beginning of the log-edit session."
- :group 'log-edit
- :type '(choice (const changed) (const t) (const nil)))
-
-(defcustom log-edit-keep-buffer nil
- "If non-nil, don't hide the buffer after `log-edit-done'."
- :group 'log-edit
- :type 'boolean)
-
-(defvar cvs-commit-buffer-require-final-newline t)
-(make-obsolete-variable 'cvs-commit-buffer-require-final-newline
- 'log-edit-require-final-newline
- "21.1")
-
-(defcustom log-edit-require-final-newline
- cvs-commit-buffer-require-final-newline
- "Enforce a newline at the end of commit log messages.
-Enforce it silently if t, query if non-nil and don't do anything if nil."
- :group 'log-edit
- :type '(choice (const ask) (const t) (const nil)))
-
-(defcustom log-edit-setup-invert nil
- "Non-nil means `log-edit' should invert the meaning of its SETUP arg.
-If SETUP is 'force, this variable has no effect."
- :group 'log-edit
- :type 'boolean)
-
-(defcustom log-edit-hook '(log-edit-insert-cvs-template
- log-edit-show-files
- log-edit-insert-changelog)
- "Hook run at the end of `log-edit'."
- :group 'log-edit
- :type '(hook :options (log-edit-insert-changelog
- log-edit-insert-cvs-rcstemplate
- log-edit-insert-cvs-template
- log-edit-insert-filenames)))
-
-(defcustom log-edit-mode-hook (if (boundp 'vc-log-mode-hook) vc-log-mode-hook)
- "Hook run when entering `log-edit-mode'."
- :group 'log-edit
- :type 'hook)
-
-(defcustom log-edit-done-hook nil
- "Hook run before doing the actual commit.
-This hook can be used to cleanup the message, enforce various
-conventions, or to allow recording the message in some other database,
-such as a bug-tracking system. The list of files about to be committed
-can be obtained from `log-edit-files'."
- :group 'log-edit
- :type '(hook :options (log-edit-set-common-indentation
- log-edit-add-to-changelog)))
-
-(defcustom log-edit-strip-single-file-name nil
- "If non-nil, remove file name from single-file log entries."
- :type 'boolean
- :safe 'booleanp
- :group 'log-edit
- :version "24.1")
-
-(defvar cvs-changelog-full-paragraphs t)
-(make-obsolete-variable 'cvs-changelog-full-paragraphs
- 'log-edit-changelog-full-paragraphs
- "21.1")
-
-(defvar log-edit-changelog-full-paragraphs cvs-changelog-full-paragraphs
- "*If non-nil, include full ChangeLog paragraphs in the log.
-This may be set in the ``local variables'' section of a ChangeLog, to
-indicate the policy for that ChangeLog.
-
-A ChangeLog paragraph is a bunch of log text containing no blank lines;
-a paragraph usually describes a set of changes with a single purpose,
-but perhaps spanning several functions in several files. Changes in
-different paragraphs are unrelated.
-
-You could argue that the log entry for a file should contain the
-full ChangeLog paragraph mentioning the change to the file, even though
-it may mention other files, because that gives you the full context you
-need to understand the change. This is the behavior you get when this
-variable is set to t.
-
-On the other hand, you could argue that the log entry for a change
-should contain only the text for the changes which occurred in that
-file, because the log is per-file. This is the behavior you get
-when this variable is set to nil.")
-
-;;;; Internal global or buffer-local vars
-
-(defconst log-edit-files-buf "*log-edit-files*")
-(defvar log-edit-initial-files nil)
-(defvar log-edit-callback nil)
-(defvar log-edit-diff-function nil)
-(defvar log-edit-listfun nil)
-
-(defvar log-edit-parent-buffer nil)
-
-;;; Originally taken from VC-Log mode
-
-(defconst log-edit-maximum-comment-ring-size 32
- "Maximum number of saved comments in the comment ring.")
-(defvar log-edit-comment-ring (make-ring log-edit-maximum-comment-ring-size))
-(defvar log-edit-comment-ring-index nil)
-(defvar log-edit-last-comment-match "")
-
-(defun log-edit-new-comment-index (stride len)
- "Return the comment index STRIDE elements from the current one.
-LEN is the length of `log-edit-comment-ring'."
- (mod (cond
- (log-edit-comment-ring-index (+ log-edit-comment-ring-index stride))
- ;; Initialize the index on the first use of this command
- ;; so that the first M-p gets index 0, and the first M-n gets
- ;; index -1.
- ((> stride 0) (1- stride))
- (t stride))
- len))
-
-(defun log-edit-previous-comment (arg)
- "Cycle backwards through comment history.
-With a numeric prefix ARG, go back ARG comments."
- (interactive "*p")
- (let ((len (ring-length log-edit-comment-ring)))
- (if (<= len 0)
- (progn (message "Empty comment ring") (ding))
- ;; Don't use `erase-buffer' because we don't want to `widen'.
- (delete-region (point-min) (point-max))
- (setq log-edit-comment-ring-index (log-edit-new-comment-index arg len))
- (message "Comment %d" (1+ log-edit-comment-ring-index))
- (insert (ring-ref log-edit-comment-ring log-edit-comment-ring-index)))))
-
-(defun log-edit-next-comment (arg)
- "Cycle forwards through comment history.
-With a numeric prefix ARG, go forward ARG comments."
- (interactive "*p")
- (log-edit-previous-comment (- arg)))
-
-(defun log-edit-comment-search-backward (str &optional stride)
- "Search backwards through comment history for substring match of STR.
-If the optional argument STRIDE is present, that is a step-width to use
-when going through the comment ring."
- ;; Why substring rather than regexp ? -sm
- (interactive
- (list (read-string "Comment substring: " nil nil log-edit-last-comment-match)))
- (unless stride (setq stride 1))
- (if (string= str "")
- (setq str log-edit-last-comment-match)
- (setq log-edit-last-comment-match str))
- (let* ((str (regexp-quote str))
- (len (ring-length log-edit-comment-ring))
- (n (log-edit-new-comment-index stride len)))
- (while (progn (when (or (>= n len) (< n 0)) (error "Not found"))
- (not (string-match str (ring-ref log-edit-comment-ring n))))
- (setq n (+ n stride)))
- (setq log-edit-comment-ring-index n)
- (log-edit-previous-comment 0)))
-
-(defun log-edit-comment-search-forward (str)
- "Search forwards through comment history for a substring match of STR."
- (interactive
- (list (read-string "Comment substring: " nil nil log-edit-last-comment-match)))
- (log-edit-comment-search-backward str -1))
-
-(defun log-edit-comment-to-change-log (&optional whoami file-name)
- "Enter last VC comment into the change log for the current file.
-WHOAMI (interactive prefix) non-nil means prompt for user name
-and site. FILE-NAME is the name of the change log; if nil, use
-`change-log-default-name'.
-
-This may be useful as a `log-edit-checkin-hook' to update change logs
-automatically."
- (interactive (if current-prefix-arg
- (list current-prefix-arg
- (prompt-for-change-log-name))))
- (let (;; Extract the comment first so we get any error before doing anything.
- (comment (ring-ref log-edit-comment-ring 0))
- ;; Don't let add-change-log-entry insert a defun name.
- (add-log-current-defun-function 'ignore)
- end)
- ;; Call add-log to do half the work.
- (add-change-log-entry whoami file-name t t)
- ;; Insert the VC comment, leaving point before it.
- (setq end (save-excursion (insert comment) (point-marker)))
- (if (looking-at "\\s *\\s(")
- ;; It starts with an open-paren, as in "(foo): Frobbed."
- ;; So remove the ": " add-log inserted.
- (delete-char -2))
- ;; Canonicalize the white space between the file name and comment.
- (just-one-space)
- ;; Indent rest of the text the same way add-log indented the first line.
- (let ((indentation (current-indentation)))
- (save-excursion
- (while (< (point) end)
- (forward-line 1)
- (indent-to indentation))
- (setq end (point))))
- ;; Fill the inserted text, preserving open-parens at bol.
- (let ((paragraph-start (concat paragraph-start "\\|\\s *\\s(")))
- (beginning-of-line)
- (fill-region (point) end))
- ;; Canonicalize the white space at the end of the entry so it is
- ;; separated from the next entry by a single blank line.
- (skip-syntax-forward " " end)
- (delete-char (- (skip-syntax-backward " ")))
- (or (eobp) (looking-at "\n\n")
- (insert "\n"))))
-
-;; Compatibility with old names.
-(define-obsolete-variable-alias 'vc-comment-ring 'log-edit-comment-ring "22.1")
-(define-obsolete-variable-alias 'vc-comment-ring-index 'log-edit-comment-ring-index "22.1")
-(define-obsolete-function-alias 'vc-previous-comment 'log-edit-previous-comment "22.1")
-(define-obsolete-function-alias 'vc-next-comment 'log-edit-next-comment "22.1")
-(define-obsolete-function-alias 'vc-comment-search-reverse 'log-edit-comment-search-backward "22.1")
-(define-obsolete-function-alias 'vc-comment-search-forward 'log-edit-comment-search-forward "22.1")
-(define-obsolete-function-alias 'vc-comment-to-change-log 'log-edit-comment-to-change-log "22.1")
-
-;;;
-;;; Actual code
-;;;
-
-(defface log-edit-summary '((t :inherit font-lock-function-name-face))
- "Face for the summary in `log-edit-mode' buffers.")
-
-(defface log-edit-header '((t :inherit font-lock-keyword-face))
- "Face for the headers in `log-edit-mode' buffers.")
-
-(defface log-edit-unknown-header '((t :inherit font-lock-comment-face))
- "Face for unknown headers in `log-edit-mode' buffers.")
-
-(defvar log-edit-headers-alist '(("Summary" . log-edit-summary)
- ("Fixes") ("Author"))
- "AList of known headers and the face to use to highlight them.")
-
-(defconst log-edit-header-contents-regexp
- "[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?")
-
-(defun log-edit-match-to-eoh (limit)
- ;; FIXME: copied from message-match-to-eoh.
- (let ((start (point)))
- (rfc822-goto-eoh)
- ;; Typical situation: some temporary change causes the header to be
- ;; incorrect, so EOH comes earlier than intended: the last lines of the
- ;; intended headers are now not considered part of the header any more,
- ;; so they don't have the multiline property set. When the change is
- ;; completed and the header has its correct shape again, the lack of the
- ;; multiline property means we won't rehighlight the last lines of
- ;; the header.
- (if (< (point) start)
- nil ;No header within start..limit.
- ;; Here we disregard LIMIT so that we may extend the area again.
- (set-match-data (list start (point)))
- (point))))
-
-(defvar log-edit-font-lock-keywords
- ;; Copied/inspired by message-font-lock-keywords.
- `((log-edit-match-to-eoh
- (,(concat "^\\(\\([a-z]+\\):\\)" log-edit-header-contents-regexp
- "\\|\\(.*\\)")
- (progn (goto-char (match-beginning 0)) (match-end 0)) nil
- (1 (if (assoc (match-string 2) log-edit-headers-alist)
- 'log-edit-header
- 'log-edit-unknown-header)
- nil lax)
- (3 (or (cdr (assoc (match-string 2) log-edit-headers-alist))
- 'log-edit-header)
- nil lax)
- (4 font-lock-warning-face nil lax)))))
-
-;;;###autoload
-(defun log-edit (callback &optional setup params buffer mode &rest ignore)
- "Setup a buffer to enter a log message.
-\\<log-edit-mode-map>The buffer will be put in mode MODE or `log-edit-mode'
-if MODE is nil.
-If SETUP is non-nil, the buffer is then erased and `log-edit-hook' is run.
-Mark and point will be set around the entire contents of the buffer so
-that it is easy to kill the contents of the buffer with \\[kill-region].
-Once you're done editing the message, pressing \\[log-edit-done] will call
-`log-edit-done' which will end up calling CALLBACK to do the actual commit.
-
-PARAMS if non-nil is an alist. Possible keys and associated values:
- `log-edit-listfun' -- function taking no arguments that returns the list of
- files that are concerned by the current operation (using relative names);
- `log-edit-diff-function' -- function taking no arguments that
- displays a diff of the files concerned by the current operation.
-
-If BUFFER is non-nil `log-edit' will jump to that buffer, use it to edit the
-log message and go back to the current buffer when done. Otherwise, it
-uses the current buffer."
- (let ((parent (current-buffer)))
- (if buffer (pop-to-buffer buffer))
- (when (and log-edit-setup-invert (not (eq setup 'force)))
- (setq setup (not setup)))
- (when setup
- (erase-buffer)
- (insert "Summary: ")
- (save-excursion (insert "\n\n")))
- (if mode
- (funcall mode)
- (log-edit-mode))
- (set (make-local-variable 'log-edit-callback) callback)
- (if (listp params)
- (dolist (crt params)
- (set (make-local-variable (car crt)) (cdr crt)))
- ;; For backward compatibility with log-edit up to version 22.2
- ;; accept non-list PARAMS to mean `log-edit-list'.
- (set (make-local-variable 'log-edit-listfun) params))
-
- (if buffer (set (make-local-variable 'log-edit-parent-buffer) parent))
- (set (make-local-variable 'log-edit-initial-files) (log-edit-files))
- (when setup (run-hooks 'log-edit-hook))
- (goto-char (point-min)) (push-mark (point-max))
- (message "%s" (substitute-command-keys
- "Press \\[log-edit-done] when you are done editing."))))
-
-(define-derived-mode log-edit-mode text-mode "Log-Edit"
- "Major mode for editing version-control log messages.
-When done editing the log entry, just type \\[log-edit-done] which
-will trigger the actual commit of the file(s).
-Several other handy support commands are provided of course and
-the package from which this is used might also provide additional
-commands (under C-x v for VC, for example).
-
-\\{log-edit-mode-map}"
- (set (make-local-variable 'font-lock-defaults)
- '(log-edit-font-lock-keywords t t))
- (make-local-variable 'log-edit-comment-ring-index)
- (hack-dir-local-variables-non-file-buffer))
-
-(defun log-edit-hide-buf (&optional buf where)
- (when (setq buf (get-buffer (or buf log-edit-files-buf)))
- (let ((win (get-buffer-window buf where)))
- (if win (ignore-errors (delete-window win))))
- (bury-buffer buf)))
-
-(defun log-edit-done ()
- "Finish editing the log message and commit the files.
-If you want to abort the commit, simply delete the buffer."
- (interactive)
- ;; Clean up empty headers.
- (goto-char (point-min))
- (while (looking-at (concat "^[a-z]*:" log-edit-header-contents-regexp))
- (let ((beg (match-beginning 0)))
- (goto-char (match-end 0))
- (if (string-match "\\`[ \n\t]*\\'" (match-string 1))
- (delete-region beg (point)))))
- ;; Get rid of leading empty lines.
- (goto-char (point-min))
- (when (looking-at "\\([ \t]*\n\\)+")
- (delete-region (match-beginning 0) (match-end 0)))
- ;; Get rid of trailing empty lines
- (goto-char (point-max))
- (skip-syntax-backward " ")
- (when (equal (char-after) ?\n) (forward-char 1))
- (delete-region (point) (point-max))
- ;; Check for final newline
- (if (and (> (point-max) (point-min))
- (/= (char-before (point-max)) ?\n)
- (or (eq log-edit-require-final-newline t)
- (and log-edit-require-final-newline
- (y-or-n-p
- (format "Buffer %s does not end in newline. Add one? "
- (buffer-name))))))
- (save-excursion
- (goto-char (point-max))
- (insert ?\n)))
- (let ((comment (buffer-string)))
- (when (or (ring-empty-p log-edit-comment-ring)
- (not (equal comment (ring-ref log-edit-comment-ring 0))))
- (ring-insert log-edit-comment-ring comment)))
- (let ((win (get-buffer-window log-edit-files-buf)))
- (if (and log-edit-confirm
- (not (and (eq log-edit-confirm 'changed)
- (equal (log-edit-files) log-edit-initial-files)))
- (progn
- (log-edit-show-files)
- (not (y-or-n-p "Really commit? "))))
- (progn (when (not win) (log-edit-hide-buf))
- (message "Oh, well! Later maybe?"))
- (run-hooks 'log-edit-done-hook)
- (log-edit-hide-buf)
- (unless (or log-edit-keep-buffer (not log-edit-parent-buffer))
- (cvs-bury-buffer (current-buffer) log-edit-parent-buffer))
- (call-interactively log-edit-callback))))
-
-(defun log-edit-files ()
- "Return the list of files that are about to be committed."
- (ignore-errors (funcall log-edit-listfun)))
-
-(defun log-edit-mode-help ()
- "Provide help for the `log-edit-mode-map'."
- (interactive)
- (if (eq last-command 'log-edit-mode-help)
- (describe-function major-mode)
- (message "%s"
- (substitute-command-keys
- "Type `\\[log-edit-done]' to finish commit. Try `\\[describe-function] log-edit-done' for more help."))))
-
-(defcustom log-edit-common-indent 0
- "Minimum indentation to use in `log-edit-set-common-indentation'."
- :group 'log-edit
- :type 'integer)
-
-(defun log-edit-set-common-indentation ()
- "(Un)Indent the current buffer rigidly to `log-edit-common-indent'."
- (save-excursion
- (let ((common (point-max)))
- (rfc822-goto-eoh)
- (while (< (point) (point-max))
- (if (not (looking-at "^[ \t]*$"))
- (setq common (min common (current-indentation))))
- (forward-line 1))
- (rfc822-goto-eoh)
- (indent-rigidly (point) (point-max)
- (- log-edit-common-indent common)))))
-
-(defun log-edit-show-diff ()
- "Show the diff for the files to be committed."
- (interactive)
- (if (functionp log-edit-diff-function)
- (funcall log-edit-diff-function)
- (error "Diff functionality has not been setup")))
-
-(defun log-edit-show-files ()
- "Show the list of files to be committed."
- (interactive)
- (let* ((files (log-edit-files))
- (buf (get-buffer-create log-edit-files-buf)))
- (with-current-buffer buf
- (log-edit-hide-buf buf 'all)
- (setq buffer-read-only nil)
- (erase-buffer)
- (cvs-insert-strings files)
- (setq buffer-read-only t)
- (goto-char (point-min))
- (save-selected-window
- (cvs-pop-to-buffer-same-frame buf)
- (shrink-window-if-larger-than-buffer)
- (selected-window)))))
-
-(defun log-edit-insert-cvs-template ()
- "Insert the template specified by the CVS administrator, if any.
-This simply uses the local CVS/Template file."
- (interactive)
- (when (or (called-interactively-p 'interactive)
- (= (point-min) (point-max)))
- (when (file-readable-p "CVS/Template")
- (insert-file-contents "CVS/Template"))))
-
-(defun log-edit-insert-cvs-rcstemplate ()
- "Insert the rcstemplate from the CVS repository.
-This contacts the repository to get the rcstemplate file and
-can thus take some time."
- (interactive)
- (when (or (called-interactively-p 'interactive)
- (= (point-min) (point-max)))
- (when (file-readable-p "CVS/Root")
- ;; Ignore the stderr stuff, even if it's an error.
- (call-process "cvs" nil '(t nil) nil
- "checkout" "-p" "CVSROOT/rcstemplate"))))
-
-(defun log-edit-insert-filenames ()
- "Insert the list of files that are to be committed."
- (interactive)
- (insert "Affected files: \n"
- (mapconcat 'identity (log-edit-files) " \n")))
-
-(defun log-edit-add-to-changelog ()
- "Insert this log message into the appropriate ChangeLog file."
- (interactive)
- ;; Yuck!
- (unless (string= (buffer-string) (ring-ref log-edit-comment-ring 0))
- (ring-insert log-edit-comment-ring (buffer-string)))
- (dolist (f (log-edit-files))
- (let ((buffer-file-name (expand-file-name f)))
- (save-excursion
- (log-edit-comment-to-change-log)))))
-
-(defvar log-edit-changelog-use-first nil)
-(defun log-edit-insert-changelog (&optional use-first)
- "Insert a log message by looking at the ChangeLog.
-The idea is to write your ChangeLog entries first, and then use this
-command to commit your changes.
-
-To select default log text, we:
-- find the ChangeLog entries for the files to be checked in,
-- verify that the top entry in the ChangeLog is on the current date
- and by the current user; if not, we don't provide any default text,
-- search the ChangeLog entry for paragraphs containing the names of
- the files we're checking in, and finally
-- use those paragraphs as the log text.
-
-If the optional prefix arg USE-FIRST is given (via \\[universal-argument]),
-or if the command is repeated a second time in a row, use the first log entry
-regardless of user name or time."
- (interactive "P")
- (let ((eoh (save-excursion (rfc822-goto-eoh) (point))))
- (when (<= (point) eoh)
- (goto-char eoh)
- (if (looking-at "\n") (forward-char 1))))
- (let ((log-edit-changelog-use-first
- (or use-first (eq last-command 'log-edit-insert-changelog))))
- (log-edit-insert-changelog-entries (log-edit-files)))
- (log-edit-set-common-indentation)
- (goto-char (point-min))
- (when (and log-edit-strip-single-file-name (looking-at "\\*\\s-+"))
- (forward-line 1)
- (when (not (re-search-forward "^\\*\\s-+" nil t))
- (goto-char (point-min))
- (skip-chars-forward "^():")
- (skip-chars-forward ": ")
- (delete-region (point-min) (point)))))
-
-;;;;
-;;;; functions for getting commit message from ChangeLog a file...
-;;;; Courtesy Jim Blandy
-;;;;
-
-(defun log-edit-narrow-changelog ()
- "Narrow to the top page of the current buffer, a ChangeLog file.
-Actually, the narrowed region doesn't include the date line.
-A \"page\" in a ChangeLog file is the area between two dates."
- (or (eq major-mode 'change-log-mode)
- (error "log-edit-narrow-changelog: current buffer isn't a ChangeLog"))
-
- (goto-char (point-min))
-
- ;; Skip date line and subsequent blank lines.
- (forward-line 1)
- (if (looking-at "[ \t\n]*\n")
- (goto-char (match-end 0)))
-
- (let ((start (point)))
- (forward-page 1)
- (narrow-to-region start (point))
- (goto-char (point-min))))
-
-(defun log-edit-changelog-paragraph ()
- "Return the bounds of the ChangeLog paragraph containing point.
-If we are between paragraphs, return the previous paragraph."
- (beginning-of-line)
- (if (looking-at "^[ \t]*$")
- (skip-chars-backward " \t\n" (point-min)))
- (list (progn
- (if (re-search-backward "^[ \t]*\n" nil 'or-to-limit)
- (goto-char (match-end 0)))
- (point))
- (if (re-search-forward "^[ \t\n]*$" nil t)
- (match-beginning 0)
- (point-max))))
-
-(defun log-edit-changelog-subparagraph ()
- "Return the bounds of the ChangeLog subparagraph containing point.
-A subparagraph is a block of non-blank lines beginning with an asterisk.
-If we are between sub-paragraphs, return the previous subparagraph."
- (end-of-line)
- (if (search-backward "*" nil t)
- (list (progn (beginning-of-line) (point))
- (progn
- (forward-line 1)
- (if (re-search-forward "^[ \t]*[\n*]" nil t)
- (match-beginning 0)
- (point-max))))
- (list (point) (point))))
-
-(defun log-edit-changelog-entry ()
- "Return the bounds of the ChangeLog entry containing point.
-The variable `log-edit-changelog-full-paragraphs' decides whether an
-\"entry\" is a paragraph or a subparagraph; see its documentation string
-for more details."
- (save-excursion
- (if log-edit-changelog-full-paragraphs
- (log-edit-changelog-paragraph)
- (log-edit-changelog-subparagraph))))
-
-(defvar user-full-name)
-(defvar user-mail-address)
-(defun log-edit-changelog-ours-p ()
- "See if ChangeLog entry at point is for the current user, today.
-Return non-nil if it is."
- ;; Code adapted from add-change-log-entry.
- (let ((name (or (and (boundp 'add-log-full-name) add-log-full-name)
- (and (fboundp 'user-full-name) (user-full-name))
- (and (boundp 'user-full-name) user-full-name)))
- (mail (or (and (boundp 'add-log-mailing-address) add-log-mailing-address)
- ;;(and (fboundp 'user-mail-address) (user-mail-address))
- (and (boundp 'user-mail-address) user-mail-address)))
- (time (or (and (boundp 'add-log-time-format)
- (functionp add-log-time-format)
- (funcall add-log-time-format))
- (format-time-string "%Y-%m-%d"))))
- (looking-at (if log-edit-changelog-use-first
- "[^ \t]"
- (regexp-quote (format "%s %s <%s>" time name mail))))))
-
-(defun log-edit-changelog-entries (file)
- "Return the ChangeLog entries for FILE, and the ChangeLog they came from.
-The return value looks like this:
- (LOGBUFFER (ENTRYSTART ENTRYEND) ...)
-where LOGBUFFER is the name of the ChangeLog buffer, and each
-\(ENTRYSTART . ENTRYEND\) pair is a buffer region."
- (let ((changelog-file-name
- (let ((default-directory
- (file-name-directory (expand-file-name file)))
- (visiting-buffer (find-buffer-visiting file)))
- ;; If there is a buffer visiting FILE, and it has a local
- ;; value for `change-log-default-name', use that.
- (if (and visiting-buffer
- (local-variable-p 'change-log-default-name
- visiting-buffer))
- (with-current-buffer visiting-buffer
- change-log-default-name)
- ;; `find-change-log' uses `change-log-default-name' if set
- ;; and sets it before exiting, so we need to work around
- ;; that memoizing which is undesired here
- (setq change-log-default-name nil)
- (find-change-log)))))
- (with-current-buffer (find-file-noselect changelog-file-name)
- (unless (eq major-mode 'change-log-mode) (change-log-mode))
- (goto-char (point-min))
- (if (looking-at "\\s-*\n") (goto-char (match-end 0)))
- (if (not (log-edit-changelog-ours-p))
- (list (current-buffer))
- (save-restriction
- (log-edit-narrow-changelog)
- (goto-char (point-min))
-
- ;; Search for the name of FILE relative to the ChangeLog. If that
- ;; doesn't occur anywhere, they're not using full relative
- ;; filenames in the ChangeLog, so just look for FILE; we'll accept
- ;; some false positives.
- (let ((pattern (file-relative-name
- file (file-name-directory changelog-file-name))))
- (if (or (string= pattern "")
- (not (save-excursion
- (search-forward pattern nil t))))
- (setq pattern (file-name-nondirectory file)))
-
- (setq pattern (concat "\\(^\\|[^[:alnum:]]\\)"
- pattern
- "\\($\\|[^[:alnum:]]\\)"))
-
- (let (texts
- (pos (point)))
- (while (and (not (eobp)) (re-search-forward pattern nil t))
- (let ((entry (log-edit-changelog-entry)))
- (if (< (elt entry 1) (max (1+ pos) (point)))
- ;; This is not relevant, actually.
- nil
- (push entry texts))
- ;; Make sure we make progress.
- (setq pos (max (1+ pos) (elt entry 1)))
- (goto-char pos)))
-
- (cons (current-buffer) texts))))))))
-
-(defun log-edit-changelog-insert-entries (buffer beg end &rest files)
- "Insert the text from BUFFER between BEG and END.
-Rename relative filenames in the ChangeLog entry as FILES."
- (let ((opoint (point))
- (log-name (buffer-file-name buffer))
- (case-fold-search nil)
- bound)
- (insert-buffer-substring buffer beg end)
- (setq bound (point-marker))
- (when log-name
- (dolist (f files)
- (save-excursion
- (goto-char opoint)
- (when (re-search-forward
- (concat "\\(^\\|[ \t]\\)\\("
- (file-relative-name f (file-name-directory log-name))
- "\\)[, :\n]")
- bound t)
- (replace-match f t t nil 2)))))
- ;; Eliminate tabs at the beginning of the line.
- (save-excursion
- (goto-char opoint)
- (while (re-search-forward "^\\(\t+\\)" bound t)
- (replace-match "")))))
-
-(defun log-edit-insert-changelog-entries (files)
- "Given a list of files FILES, insert the ChangeLog entries for them."
- (let ((log-entries nil))
- ;; Note that any ChangeLog entry can apply to more than one file.
- ;; Here we construct a log-entries list with elements of the form
- ;; ((LOGBUFFER ENTRYSTART ENTRYEND) FILE1 FILE2...)
- (dolist (file files)
- (let* ((entries (log-edit-changelog-entries file))
- (buf (car entries))
- key entry)
- (dolist (region (cdr entries))
- (setq key (cons buf region))
- (if (setq entry (assoc key log-entries))
- (setcdr entry (append (cdr entry) (list file)))
- (push (list key file) log-entries)))))
- ;; Now map over log-entries, and extract the strings.
- (dolist (log-entry (nreverse log-entries))
- (apply 'log-edit-changelog-insert-entries
- (append (car log-entry) (cdr log-entry)))
- (insert "\n"))))
-
-(defun log-edit-extract-headers (headers comment)
- "Extract headers from COMMENT to form command line arguments.
-HEADERS should be an alist with elements of the form (HEADER . CMDARG)
-associating header names to the corresponding cmdline option name and the
-result is then a list of the form (MSG CMDARG1 HDRTEXT1 CMDARG2 HDRTEXT2...).
-where MSG is the remaining text from STRING.
-If \"Summary\" is not in HEADERS, then the \"Summary\" header is extracted
-anyway and put back as the first line of MSG."
- (with-temp-buffer
- (insert comment)
- (rfc822-goto-eoh)
- (narrow-to-region (point-min) (point))
- (let ((case-fold-search t)
- (summary ())
- (res ()))
- (dolist (header (if (assoc "Summary" headers) headers
- (cons '("Summary" . t) headers)))
- (goto-char (point-min))
- (while (re-search-forward (concat "^" (car header)
- ":" log-edit-header-contents-regexp)
- nil t)
- (if (eq t (cdr header))
- (setq summary (match-string 1))
- (push (match-string 1) res)
- (push (or (cdr header) (car header)) res))
- (replace-match "" t t)))
- ;; Remove header separator if the header is empty.
- (widen)
- (goto-char (point-min))
- (when (looking-at "\\([ \t]*\n\\)+")
- (delete-region (match-beginning 0) (match-end 0)))
- (if summary (insert summary "\n"))
- (cons (buffer-string) res))))
-
-(provide 'log-edit)
-
-;; arch-tag: 8089b39c-983b-4e83-93cd-ed0a64c7fdcc
-;;; log-edit.el ends here
+++ /dev/null
-;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output
-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: rcs, sccs, cvs, log, version control, tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Major mode to browse revision log histories.
-;; Currently supports the format output by:
-;; RCS, SCCS, CVS, Subversion, and DaRCS.
-
-;; Examples of log output:
-
-;;;; RCS/CVS:
-
-;; ----------------------------
-;; revision 1.35 locked by: turlutut
-;; date: 2005-03-22 18:48:38 +0000; author: monnier; state: Exp; lines: +6 -8
-;; (gnus-display-time-event-handler):
-;; Check display-time-timer at runtime rather than only at load time
-;; in case display-time-mode is turned off in the mean time.
-;; ----------------------------
-;; revision 1.34
-;; date: 2005-02-09 15:50:38 +0000; author: kfstorm; state: Exp; lines: +7 -7
-;; branches: 1.34.2;
-;; Change release version from 21.4 to 22.1 throughout.
-;; Change development version from 21.3.50 to 22.0.50.
-
-;;;; SCCS:
-
-;;;; Subversion:
-
-;; ------------------------------------------------------------------------
-;; r4622 | ckuethe | 2007-12-23 18:18:01 -0500 (Sun, 23 Dec 2007) | 2 lines
-;;
-;; uBlox AEK-4T in binary mode. Added to unstable because it breaks gpsfake
-;;
-;; ------------------------------------------------------------------------
-;; r4621 | ckuethe | 2007-12-23 16:48:11 -0500 (Sun, 23 Dec 2007) | 3 lines
-;;
-;; Add a note about requiring usbfs to use the garmin gps18 (usb)
-;; Mention firmware testing the AC12 with firmware BQ00 and BQ04
-;;
-;; ------------------------------------------------------------------------
-;; r4620 | ckuethe | 2007-12-23 15:52:34 -0500 (Sun, 23 Dec 2007) | 1 line
-;;
-;; add link to latest hardware reference
-;; ------------------------------------------------------------------------
-;; r4619 | ckuethe | 2007-12-23 14:37:31 -0500 (Sun, 23 Dec 2007) | 1 line
-;;
-;; there is now a regression test for AC12 without raw data output
-
-;;;; Darcs:
-
-;; Changes to darcsum.el:
-;;
-;; Mon Nov 28 15:19:38 GMT 2005 Dave Love <fx@gnu.org>
-;; * Abstract process startup into darcsum-start-process. Use TERM=dumb.
-;; TERM=dumb avoids escape characters, at least, for any old darcs that
-;; doesn't understand DARCS_DONT_COLOR & al.
-;;
-;; Thu Nov 24 15:20:45 GMT 2005 Dave Love <fx@gnu.org>
-;; * darcsum-mode-related changes.
-;; Don't call font-lock-mode (unnecessary) or use-local-map (redundant).
-;; Use mode-class 'special. Add :group.
-;; Add trailing-whitespace option to mode hook and fix
-;; darcsum-display-changeset not to use trailing whitespace.
-
-;;;; Mercurial
-
-;; changeset: 11:8ff1a4166444
-;; tag: tip
-;; user: Eric S. Raymond <esr@thyrsus.com>
-;; date: Wed Dec 26 12:18:58 2007 -0500
-;; summary: Explain keywords. Add markup fixes.
-;;
-;; changeset: 10:20abc7ab09c3
-;; user: Eric S. Raymond <esr@thyrsus.com>
-;; date: Wed Dec 26 11:37:28 2007 -0500
-;; summary: Typo fixes.
-;;
-;; changeset: 9:ada9f4da88aa
-;; user: Eric S. Raymond <esr@thyrsus.com>
-;; date: Wed Dec 26 11:23:00 2007 -0500
-;; summary: Add RCS example session.
-
-;;; Todo:
-
-;; - add ability to modify a log-entry (via cvs-mode-admin ;-)
-;; - remove references to cvs-*
-;; - make it easier to add support for new backends without changing the code.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'pcvs-util)
-(autoload 'vc-find-revision "vc")
-(autoload 'vc-diff-internal "vc")
-
-(defvar cvs-minor-wrap-function)
-
-(defgroup log-view nil
- "Major mode for browsing log output of RCS/CVS/SCCS."
- :group 'pcl-cvs
- :prefix "log-view-")
-
-;; Needed because log-view-mode-map inherits from widget-keymap. (Bug#5311)
-(require 'wid-edit)
-
-(easy-mmode-defmap log-view-mode-map
- '(("z" . kill-this-buffer)
- ("q" . quit-window)
- ("m" . log-view-toggle-mark-entry)
- ("e" . log-view-modify-change-comment)
- ("d" . log-view-diff)
- ("=" . log-view-diff)
- ("D" . log-view-diff-changeset)
- ("a" . log-view-annotate-version)
- ("f" . log-view-find-revision)
- ("n" . log-view-msg-next)
- ("p" . log-view-msg-prev)
- ("\t" . log-view-msg-next)
- ([backtab] . log-view-msg-prev)
- ("N" . log-view-file-next)
- ("P" . log-view-file-prev)
- ("\M-n" . log-view-file-next)
- ("\M-p" . log-view-file-prev))
- "Log-View's keymap."
- :inherit widget-keymap
- :group 'log-view)
-
-(easy-menu-define log-view-mode-menu log-view-mode-map
- "Log-View Display Menu"
- `("Log-View"
- ;; XXX Do we need menu entries for these?
- ;; ["Quit" quit-window]
- ;; ["Kill This Buffer" kill-this-buffer]
- ["Mark Log Entry for Diff" set-mark-command
- :help ""]
- ["Diff Revisions" log-view-diff
- :help "Get the diff between two revisions"]
- ["Changeset Diff" log-view-diff-changeset
- :help "Get the changeset diff between two revisions"]
- ["Visit Version" log-view-find-revision
- :help "Visit the version at point"]
- ["Annotate Version" log-view-annotate-version
- :help "Annotate the version at point"]
- ["Modify Log Comment" log-view-modify-change-comment
- :help "Edit the change comment displayed at point"]
- "-----"
- ["Next Log Entry" log-view-msg-next
- :help "Go to the next count'th log message"]
- ["Previous Log Entry" log-view-msg-prev
- :help "Go to the previous count'th log message"]
- ["Next File" log-view-file-next
- :help "Go to the next count'th file"]
- ["Previous File" log-view-file-prev
- :help "Go to the previous count'th file"]))
-
-(defvar log-view-mode-hook nil
- "Hook run at the end of `log-view-mode'.")
-
-(defface log-view-file
- '((((class color) (background light))
- (:background "grey70" :weight bold))
- (t (:weight bold)))
- "Face for the file header line in `log-view-mode'."
- :group 'log-view)
-(define-obsolete-face-alias 'log-view-file-face 'log-view-file "22.1")
-(defvar log-view-file-face 'log-view-file)
-
-(defface log-view-message
- '((((class color) (background light))
- (:background "grey85"))
- (t (:weight bold)))
- "Face for the message header line in `log-view-mode'."
- :group 'log-view)
-;; backward-compatibility alias
-(define-obsolete-face-alias 'log-view-message-face 'log-view-message "22.1")
-(defvar log-view-message-face 'log-view-message)
-
-(defvar log-view-file-re
- (concat "^\\(?:Working file: \\(?1:.+\\)" ;RCS and CVS.
- ;; Subversion has no such thing??
- "\\|\\(?:SCCS/s\\.\\|Changes to \\)\\(?1:.+\\):" ;SCCS and Darcs.
- "\\)\n") ;Include the \n for font-lock reasons.
- "Regexp matching the text identifying the file.
-The match group number 1 should match the file name itself.")
-
-(defvar log-view-per-file-logs t
- "Set if to t if the logs are shown one file at a time.")
-
-(defvar log-view-message-re
- (concat "^\\(?:revision \\(?1:[.0-9]+\\)\\(?:\t.*\\)?" ; RCS and CVS.
- "\\|r\\(?1:[0-9]+\\) | .* | .*" ; Subversion.
- "\\|D \\(?1:[.0-9]+\\) .*" ; SCCS.
- ;; Darcs doesn't have revision names. VC-darcs uses patch names
- ;; instead. Darcs patch names are hashcodes, which do not appear
- ;; in the log output :-(, but darcs accepts any prefix of the log
- ;; message as a patch name, so we match the first line of the log
- ;; message.
- ;; First loosely match the date format.
- (concat "\\|[^ \n].*[^0-9\n][0-9][0-9]:[0-9][0-9][^0-9\n].*[^ \n]"
- ;;Email of user and finally Msg, used as revision name.
- " .*@.*\n\\(?: \\* \\(?1:.*\\)\\)?")
- "\\)$")
- "Regexp matching the text identifying a revision.
-The match group number 1 should match the revision number itself.")
-
-(defvar log-view-font-lock-keywords
- ;; We use `eval' so as to use the buffer-local value of log-view-file-re
- ;; and log-view-message-re, if applicable.
- '((eval . `(,log-view-file-re
- (1 (if (boundp 'cvs-filename-face) cvs-filename-face))
- (0 log-view-file-face append)))
- (eval . `(,log-view-message-re . log-view-message-face))))
-
-(defconst log-view-font-lock-defaults
- '(log-view-font-lock-keywords t nil nil nil))
-
-(defvar log-view-vc-fileset nil
- "Set this to the fileset corresponding to the current log.")
-
-(defvar log-view-vc-backend nil
- "Set this to the VC backend that created the current log.")
-
-;;;;
-;;;; Actual code
-;;;;
-
-;;;###autoload
-(define-derived-mode log-view-mode special-mode "Log-View"
- "Major mode for browsing CVS log output."
- (setq buffer-read-only t)
- (set (make-local-variable 'font-lock-defaults) log-view-font-lock-defaults)
- (set (make-local-variable 'beginning-of-defun-function)
- 'log-view-beginning-of-defun)
- (set (make-local-variable 'end-of-defun-function)
- 'log-view-end-of-defun)
- (set (make-local-variable 'cvs-minor-wrap-function) 'log-view-minor-wrap)
- (hack-dir-local-variables-non-file-buffer))
-
-;;;;
-;;;; Navigation
-;;;;
-
-;; define log-view-{msg,file}-{next,prev}
-(easy-mmode-define-navigation log-view-msg log-view-message-re "log message")
-(easy-mmode-define-navigation log-view-file log-view-file-re "file")
-
-(defun log-view-goto-rev (rev)
- (goto-char (point-min))
- (ignore-errors
- (while (not (equal rev (log-view-current-tag)))
- (log-view-msg-next))
- t))
-
-;;;;
-;;;; Linkage to PCL-CVS (mostly copied from cvs-status.el)
-;;;;
-
-(defconst log-view-dir-re "^cvs[.ex]* [a-z]+: Logging \\(.+\\)$")
-
-(defun log-view-current-file ()
- (save-excursion
- (forward-line 1)
- (or (re-search-backward log-view-file-re nil t)
- (re-search-forward log-view-file-re nil t)
- (error "Unable to determine the current file"))
- (let* ((file (match-string 1))
- (cvsdir (and (re-search-backward log-view-dir-re nil t)
- (match-string 1)))
- (pcldir (and (boundp 'cvs-pcl-cvs-dirchange-re)
- (re-search-backward cvs-pcl-cvs-dirchange-re nil t)
- (match-string 1)))
- (dir ""))
- (let ((default-directory ""))
- (when pcldir (setq dir (expand-file-name pcldir dir)))
- (when cvsdir (setq dir (expand-file-name cvsdir dir))))
- (expand-file-name file dir))))
-
-(defun log-view-current-tag (&optional where)
- (save-excursion
- (when where (goto-char where))
- (forward-line 1)
- (let ((pt (point)))
- (when (re-search-backward log-view-message-re nil t)
- (let ((rev (match-string-no-properties 1)))
- (unless (re-search-forward log-view-file-re pt t)
- rev))))))
-
-(defun log-view-toggle-mark-entry ()
- "Toggle the marked state for the log entry at point.
-Individual log entries can be marked and unmarked. The marked
-entries are denoted by changing their background color.
-`log-view-get-marked' returns the list of tags for the marked
-log entries."
- (interactive)
- (save-excursion
- (forward-line 1)
- (let ((pt (point)))
- (when (re-search-backward log-view-message-re nil t)
- (let ((beg (match-beginning 0))
- end ov ovlist found tag)
- (unless (re-search-forward log-view-file-re pt t)
- ;; Look to see if the current entry is marked.
- (setq found (get-char-property (point) 'log-view-self))
- (if found
- (delete-overlay found)
- ;; Create an overlay that covers this entry and change
- ;; its color.
- (setq tag (log-view-current-tag (point)))
- (forward-line 1)
- (setq end
- (if (re-search-forward log-view-message-re nil t)
- (match-beginning 0)
- (point-max)))
- (setq ov (make-overlay beg end))
- (overlay-put ov 'face 'log-view-file)
- ;; This is used to check if the overlay is present.
- (overlay-put ov 'log-view-self ov)
- (overlay-put ov 'log-view-marked tag))))))))
-
-(defun log-view-get-marked ()
- "Return the list of tags for the marked log entries."
- (save-excursion
- (let ((pos (point-min))
- marked-list ov)
- (while (setq pos (next-single-property-change pos 'face))
- (when (setq ov (get-char-property pos 'log-view-self))
- (push (overlay-get ov 'log-view-marked) marked-list)
- (setq pos (overlay-end ov))))
- marked-list)))
-
-(defun log-view-beginning-of-defun ()
- ;; This assumes that a log entry starts with a line matching
- ;; `log-view-message-re'. Modes that derive from `log-view-mode'
- ;; for which this assumption is not valid will have to provide
- ;; another implementation of this function. `log-view-msg-prev'
- ;; does a similar job to this function, we can't use it here
- ;; directly because it prints messages that are not appropriate in
- ;; this context and it does not move to the beginning of the buffer
- ;; when the point is before the first log entry.
-
- ;; `log-view-beginning-of-defun' and `log-view-end-of-defun' have
- ;; been checked to work with logs produced by RCS, CVS, git,
- ;; mercurial and subversion.
-
- (re-search-backward log-view-message-re nil 'move))
-
-(defun log-view-end-of-defun ()
- ;; The idea in this function is to search for the beginning of the
- ;; next log entry using `log-view-message-re' and then go back one
- ;; line when finding it. Modes that derive from `log-view-mode' for
- ;; which this assumption is not valid will have to provide another
- ;; implementation of this function.
-
- ;; Look back and if there is no entry there it means we are before
- ;; the first log entry, so go forward until finding one.
- (unless (save-excursion (re-search-backward log-view-message-re nil t))
- (re-search-forward log-view-message-re nil t))
-
- ;; In case we are at the end of log entry going forward a line will
- ;; make us find the next entry when searching. If we are inside of
- ;; an entry going forward a line will still keep the point inside
- ;; the same entry.
- (forward-line 1)
-
- ;; In case we are at the beginning of an entry, move past it.
- (when (looking-at log-view-message-re)
- (goto-char (match-end 0))
- (forward-line 1))
-
- ;; Search for the start of the next log entry. Go to the end of the
- ;; buffer if we could not find a next entry.
- (when (re-search-forward log-view-message-re nil 'move)
- (goto-char (match-beginning 0))
- (forward-line -1)))
-
-(defvar cvs-minor-current-files)
-(defvar cvs-branch-prefix)
-(defvar cvs-secondary-branch-prefix)
-
-(defun log-view-minor-wrap (buf f)
- (let ((data (with-current-buffer buf
- (let* ((beg (point))
- (end (if mark-active (mark) (point)))
- (fr (log-view-current-tag beg))
- (to (log-view-current-tag end)))
- (when (string-equal fr to)
- (save-excursion
- (goto-char end)
- (log-view-msg-next)
- (setq to (log-view-current-tag))))
- (cons
- ;; The first revision has to be the one at point, for
- ;; operations that only take one revision
- ;; (e.g. cvs-mode-edit).
- (cons (log-view-current-file) fr)
- (cons (log-view-current-file) to))))))
- (let ((cvs-branch-prefix (cdar data))
- (cvs-secondary-branch-prefix (and (cdar data) (cddr data)))
- (cvs-minor-current-files
- (cons (caar data)
- (when (and (cadr data) (not (equal (caar data) (cadr data))))
- (list (cadr data)))))
- ;; FIXME: I need to force because the fileinfos are UNKNOWN
- (cvs-force-command "/F"))
- (funcall f))))
-
-(defun log-view-find-revision (pos)
- "Visit the version at point."
- (interactive "d")
- (unless log-view-per-file-logs
- (when (> (length log-view-vc-fileset) 1)
- (error "Multiple files shown in this buffer, cannot use this command here")))
- (save-excursion
- (goto-char pos)
- (switch-to-buffer (vc-find-revision (if log-view-per-file-logs
- (log-view-current-file)
- (car log-view-vc-fileset))
- (log-view-current-tag)))))
-
-
-(defun log-view-extract-comment ()
- "Parse comment from around the current point in the log."
- (save-excursion
- (let (st en (backend (vc-backend (log-view-current-file))))
- (log-view-end-of-defun)
- (cond ((eq backend 'SVN)
- (forward-line -1)))
- (setq en (point))
- (log-view-beginning-of-defun)
- (cond ((memq backend '(SCCS RCS CVS MCVS SVN))
- (forward-line 2))
- ((eq backend 'Hg)
- (forward-line 4)
- (re-search-forward "summary: *" nil t)))
- (setq st (point))
- (buffer-substring st en))))
-
-(declare-function vc-modify-change-comment "vc" (files rev oldcomment))
-
-(defun log-view-modify-change-comment ()
- "Edit the change comment displayed at point."
- (interactive)
- (vc-modify-change-comment (list (if log-view-per-file-logs
- (log-view-current-file)
- (car log-view-vc-fileset)))
- (log-view-current-tag)
- (log-view-extract-comment)))
-
-(defun log-view-annotate-version (pos)
- "Annotate the version at point."
- (interactive "d")
- (unless log-view-per-file-logs
- (when (> (length log-view-vc-fileset) 1)
- (error "Multiple files shown in this buffer, cannot use this command here")))
- (save-excursion
- (goto-char pos)
- (vc-annotate (if log-view-per-file-logs
- (log-view-current-file)
- (car log-view-vc-fileset))
- (log-view-current-tag))))
-
-;;
-;; diff
-;;
-
-(defun log-view-diff (beg end)
- "Get the diff between two revisions.
-If the mark is not active or the mark is on the revision at point,
-get the diff between the revision at point and its previous revision.
-Otherwise, get the diff between the revisions where the region starts
-and ends.
-Contrary to `log-view-diff-changeset', it will only show the part of the
-changeset that affected the currently considered file(s)."
- (interactive
- (list (if mark-active (region-beginning) (point))
- (if mark-active (region-end) (point))))
- (let ((fr (log-view-current-tag beg))
- (to (log-view-current-tag end)))
- (when (string-equal fr to)
- (save-excursion
- (goto-char end)
- (log-view-msg-next)
- (setq to (log-view-current-tag))))
- (vc-diff-internal
- t (list log-view-vc-backend
- (if log-view-per-file-logs
- (list (log-view-current-file))
- log-view-vc-fileset))
- to fr)))
-
-(declare-function vc-diff-internal "vc"
- (async vc-fileset rev1 rev2 &optional verbose))
-
-(defun log-view-diff-changeset (beg end)
- "Get the diff between two revisions.
-If the mark is not active or the mark is on the revision at point,
-get the diff between the revision at point and its previous revision.
-Otherwise, get the diff between the revisions where the region starts
-and ends.
-Contrary to `log-view-diff', it will show the whole changeset including
-the changes that affected other files than the currently considered file(s)."
- (interactive
- (list (if mark-active (region-beginning) (point))
- (if mark-active (region-end) (point))))
- (when (eq (vc-call-backend log-view-vc-backend 'revision-granularity) 'file)
- (error "The %s backend does not support changeset diffs" log-view-vc-backend))
- (let ((fr (log-view-current-tag beg))
- (to (log-view-current-tag end)))
- (when (string-equal fr to)
- ;; TO and FR are the same, look at the previous revision.
- (setq to (vc-call-backend log-view-vc-backend 'previous-revision nil fr)))
- (vc-diff-internal
- t
- ;; We want to see the diff for all the files in the changeset, so
- ;; pass NIL for the file list. The value passed here should
- ;; follow what `vc-deduce-fileset' returns.
- (list log-view-vc-backend nil)
- to fr)))
-
-(provide 'log-view)
-
-;; arch-tag: 0d64220b-ce7e-4f62-9c2a-6b04c2f81f4f
-;;; log-view.el ends here
+++ /dev/null
-;;; pcvs-defs.el --- variable definitions for PCL-CVS
-
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: pcl-cvs
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'pcvs-util)
-
-;;;; -------------------------------------------------------
-;;;; START OF THINGS TO CHECK WHEN INSTALLING
-
-(defvar cvs-program "cvs"
- "*Name or full path of the cvs executable.")
-
-(defvar cvs-version
- ;; With the divergence of the CVSNT codebase and version numbers, this is
- ;; not really good any more.
- (ignore-errors
- (with-temp-buffer
- (call-process cvs-program nil t nil "-v")
- (goto-char (point-min))
- (when (re-search-forward "(CVS\\(NT\\)?) \\([0-9]+\\)\\.\\([0-9]+\\)"
- nil t)
- (cons (string-to-number (match-string 1))
- (string-to-number (match-string 2))))))
- "*Version of `cvs' installed on your system.
-It must be in the (MAJOR . MINOR) format.")
-
-;; FIXME: this is only used by cvs-mode-diff-backup
-(defvar cvs-diff-program (or (and (boundp 'diff-command) diff-command) "diff")
- "*Name or full path of the best diff program you've got.
-NOTE: there are some nasty bugs in the context diff variants of some vendor
-versions, such as the one in SunOS-4.")
-
-;;;; END OF THINGS TO CHECK WHEN INSTALLING
-;;;; --------------------------------------------------------
-
-;;;;
-;;;; User configuration variables:
-;;;;
-;;;; NOTE: these should be set in your ~/.emacs (or site-lisp/default.el) file.
-;;;;
-
-(defgroup pcl-cvs nil
- "Special support for the CVS versioning system."
- :version "21.1"
- :group 'tools
- :prefix "cvs-")
-
-;;
-;; cvsrc options
-;;
-
-(defcustom cvs-cvsrc-file (convert-standard-filename "~/.cvsrc")
- "Path to your cvsrc file."
- :group 'pcl-cvs
- :type '(file))
-
-(defvar cvs-shared-start 4
- "Index of the first shared flag.
-If set to 4, for instance, a numeric argument smaller than 4 will
-select a non-shared flag, while a numeric argument greater than 3
-will select a shared-flag.")
-
-(defvar cvs-shared-flags (make-list cvs-shared-start nil)
- "List of flags whose settings is shared among several commands.")
-
-(defvar cvs-cvsroot nil
- "*Specifies where the (current) cvs master repository is.
-Overrides the environment variable $CVSROOT by sending \" -d dir\" to
-all CVS commands. This switch is useful if you have multiple CVS
-repositories. It can be set interactively with \\[cvs-change-cvsroot.]
-There is no need to set this if $CVSROOT is set to a correct value.")
-
-(defcustom cvs-auto-remove-handled nil
- "If up-to-date files should be acknowledged automatically.
-If T, they will be removed from the *cvs* buffer after every command.
-If DELAYED, they will be removed from the *cvs* buffer before every command.
-If STATUS, they will only be removed after a `cvs-mode-status' command.
-Else, they will never be automatically removed from the *cvs* buffer."
- :group 'pcl-cvs
- :type '(choice (const nil) (const status) (const delayed) (const t)))
-
-(defcustom cvs-auto-remove-directories 'handled
- "If ALL, directory entries will never be shown.
-If HANDLED, only non-handled directories will be shown.
-If EMPTY, only non-empty directories will be shown."
- :group 'pcl-cvs
- :type '(choice (const :tag "No" nil) (const all) (const handled) (const empty)))
-
-(defcustom cvs-auto-revert t
- "Non-nil if changed files should automatically be reverted."
- :group 'pcl-cvs
- :type '(boolean))
-
-(defcustom cvs-sort-ignore-file t
- "Non-nil if `cvs-mode-ignore' should sort the .cvsignore automatically."
- :group 'pcl-cvs
- :type '(boolean))
-
-(defcustom cvs-force-dir-tag t
- "If non-nil, tagging can only be applied to directories.
-Tagging should generally be applied a directory at a time, but sometimes it is
-useful to be able to tag a single file. The normal way to do that is to use
-`cvs-mode-force-command' so as to temporarily override the restrictions,"
- :group 'pcl-cvs
- :type '(boolean))
-
-(defcustom cvs-default-ignore-marks nil
- "Non-nil if cvs mode commands should ignore any marked files.
-Normally they run on the files that are marked (with `cvs-mode-mark'),
-or the file under the cursor if no files are marked. If this variable
-is set to a non-nil value they will by default run on the file on the
-current line. See also `cvs-invert-ignore-marks'"
- :group 'pcl-cvs
- :type '(boolean))
-
-(defvar cvs-diff-ignore-marks t)
-(make-obsolete-variable 'cvs-diff-ignore-marks
- 'cvs-invert-ignore-marks
- "21.1")
-
-(defcustom cvs-invert-ignore-marks
- (let ((l ()))
- (unless (equal cvs-diff-ignore-marks cvs-default-ignore-marks)
- (push "diff" l))
- (when (and cvs-force-dir-tag (not cvs-default-ignore-marks))
- (push "tag" l))
- l)
- "List of cvs commands that invert the default ignore-mark behavior.
-Commands in this set will use the opposite default from the one set
-in `cvs-default-ignore-marks'."
- :group 'pcl-cvs
- :type '(set (const "diff")
- (const "tag")
- (const "ignore")))
-
-(defcustom cvs-confirm-removals t
- "Ask for confirmation before removing files.
-Non-nil means that PCL-CVS will ask confirmation before removing files
-except for files whose content can readily be recovered from the repository.
-A value of `list' means that the list of files to be deleted will be
-displayed when asking for confirmation."
- :group 'pcl-cvs
- :type '(choice (const list)
- (const t)
- (const nil)))
-
-(defcustom cvs-add-default-message nil
- "Default message to use when adding files.
-If set to nil, `cvs-mode-add' will always prompt for a message."
- :group 'pcl-cvs
- :type '(choice (const :tag "Prompt" nil)
- (string)))
-
-(defvar cvs-diff-buffer-name "*cvs-diff*")
-(make-obsolete-variable 'cvs-diff-buffer-name
- 'cvs-buffer-name-alist
- "21.1")
-
-(defcustom cvs-find-file-and-jump nil
- "Jump to the modified area when finding a file.
-If non-nil, `cvs-mode-file-file' will place the cursor at the beginning of
-the modified area. If the file is not locally modified, this will obviously
-have no effect."
- :group 'pcl-cvs
- :type '(boolean))
-
-(defcustom cvs-buffer-name-alist
- '(("diff" cvs-diff-buffer-name diff-mode)
- ("status" "*cvs-info*" cvs-status-mode)
- ("tree" "*cvs-info*" cvs-status-mode)
- ("message" "*cvs-commit*" nil log-edit)
- ("log" "*cvs-info*" log-view-mode))
- "Buffer name and mode to be used for each command.
-This is a list of elements of the form
-
- (CMD BUFNAME MODE &optional POSTPROC)
-
-CMD is the name of the command.
-BUFNAME is an expression that should evaluate to a string used as
- a buffer name. It can use the variable CMD if it wants to.
-MODE is the command to use to setup the buffer.
-POSTPROC is a function that should be executed when the command terminates
-
-The CMD used for `cvs-mode-commit' is \"message\". For that special
- case, POSTPROC is called just after MODE with special arguments."
- :group 'pcl-cvs
- :type '(repeat
- (list (choice (const "diff")
- (const "status")
- (const "tree")
- (const "message")
- (const "log")
- (string))
- (choice (const "*vc-diff*")
- (const "*cvs-info*")
- (const "*cvs-commit*")
- (const (expand-file-name "*cvs-commit*"))
- (const (format "*cvs-%s*" cmd))
- (const (expand-file-name (format "*cvs-%s*" cmd)))
- (sexp :value "my-cvs-info-buffer")
- (const nil))
- (choice (function-item diff-mode)
- (function-item cvs-edit-mode)
- (function-item cvs-status-mode)
- function
- (const nil))
- (set :inline t
- (choice (function-item cvs-status-cvstrees)
- (function-item cvs-status-trees)
- function)))))
-
-(defvar cvs-buffer-name '(expand-file-name "*cvs*" dir) ;; "*cvs*"
- "Name of the cvs buffer.
-This expression will be evaluated in an environment where DIR is set to
-the directory name of the cvs buffer.")
-
-(defvar cvs-temp-buffer-name
- ;; Was '(expand-file-name " *cvs-tmp*" dir), but that causes them to
- ;; become non-hidden if uniquification is done `forward'.
- " *cvs-tmp*"
- "*Name of the cvs temporary buffer.
-Output from cvs is placed here for asynchronous commands.")
-
-(defcustom cvs-idiff-imerge-handlers
- (if (fboundp 'ediff)
- '(cvs-ediff-diff . cvs-ediff-merge)
- '(cvs-emerge-diff . cvs-emerge-merge))
- "Pair of functions to be used for resp. diff'ing and merg'ing interactively."
- :group 'pcl-cvs
- :type '(choice (const :tag "Ediff" (cvs-ediff-diff . cvs-ediff-merge))
- (const :tag "Emerge" (cvs-emerge-diff . cvs-emerge-merge))))
-
-(defvar cvs-mode-hook nil
- "Run after `cvs-mode' was setup.")
-
-\f
-;;;;
-;;;; Internal variables, used in the process buffer.
-;;;;
-
-(defvar cvs-postprocess nil
- "(Buffer local) what to do once the process exits.")
-
-;;;;
-;;;; Internal variables for the *cvs* buffer.
-;;;;
-
-(defcustom cvs-reuse-cvs-buffer 'subdir
- "When to reuse an existing cvs buffer.
-Alternatives are:
- CURRENT: just reuse the current buffer if it is a cvs buffer
- SAMEDIR: reuse any cvs buffer displaying the same directory
- SUBDIR: or reuse any cvs buffer displaying any sub- or super- directory
- ALWAYS: reuse any cvs buffer."
- :group 'pcl-cvs
- :type '(choice (const always) (const subdir) (const samedir) (const current)))
-
-(defvar cvs-temp-buffer nil
- "(Buffer local) The temporary buffer associated with this *cvs* buffer.")
-
-(defvar cvs-lock-file nil
- "Full path to a lock file that CVS is waiting for (or was waiting for).
-This variable is buffer local and only used in the *cvs* buffer.")
-
-(defvar cvs-lock-file-regexp "^#cvs\\.\\([trw]fl\\.[-.a-z0-9]+\\|lock\\)\\'"
- "Regexp matching the possible names of locks in the CVS repository.")
-
-(defconst cvs-cursor-column 22
- "Column to position cursor in in `cvs-mode'.")
-
-;;;;
-;;;; Global internal variables
-;;;;
-
-(defconst cvs-vendor-branch "1.1.1"
- "The default branch used by CVS for vendor code.")
-
-(easy-mmode-defmap cvs-mode-diff-map
- '(("E" "imerge" . cvs-mode-imerge)
- ("=" . cvs-mode-diff)
- ("e" "idiff" . cvs-mode-idiff)
- ("2" "other" . cvs-mode-idiff-other)
- ("d" "diff" . cvs-mode-diff)
- ("b" "backup" . cvs-mode-diff-backup)
- ("h" "head" . cvs-mode-diff-head)
- ("r" "repository" . cvs-mode-diff-repository)
- ("y" "yesterday" . cvs-mode-diff-yesterday)
- ("v" "vendor" . cvs-mode-diff-vendor))
- "Keymap for diff-related operations in `cvs-mode'."
- :name "Diff")
-;; This is necessary to allow correct handling of \\[cvs-mode-diff-map]
-;; in substitute-command-keys.
-(fset 'cvs-mode-diff-map cvs-mode-diff-map)
-
-(easy-mmode-defmap cvs-mode-map
- ;;(define-prefix-command 'cvs-mode-map-diff-prefix)
- ;;(define-prefix-command 'cvs-mode-map-control-c-prefix)
- '(;; various
- ;; (undo . cvs-mode-undo)
- ("?" . cvs-help)
- ("h" . cvs-help)
- ("q" . cvs-bury-buffer)
- ("z" . kill-this-buffer)
- ("F" . cvs-mode-set-flags)
- ;; ("\M-f" . cvs-mode-force-command)
- ("!" . cvs-mode-force-command)
- ("\C-c\C-c" . cvs-mode-kill-process)
- ;; marking
- ("m" . cvs-mode-mark)
- ("M" . cvs-mode-mark-all-files)
- ("S" . cvs-mode-mark-on-state)
- ("u" . cvs-mode-unmark)
- ("\C-?". cvs-mode-unmark-up)
- ("%" . cvs-mode-mark-matching-files)
- ("T" . cvs-mode-toggle-marks)
- ("\M-\C-?" . cvs-mode-unmark-all-files)
- ;; navigation keys
- (" " . cvs-mode-next-line)
- ("n" . cvs-mode-next-line)
- ("p" . cvs-mode-previous-line)
- ("\t" . cvs-mode-next-line)
- ([backtab] . cvs-mode-previous-line)
- ;; M- keys are usually those that operate on modules
- ;;("\M-C". cvs-mode-rcs2log) ; i.e. "Create a ChangeLog"
- ;;("\M-t". cvs-rtag)
- ;;("\M-l". cvs-rlog)
- ("\M-c". cvs-checkout)
- ("\M-e". cvs-examine)
- ("g" . cvs-mode-revert-buffer)
- ("\M-u". cvs-update)
- ("\M-s". cvs-status)
- ;; diff commands
- ("=" . cvs-mode-diff)
- ("d" . cvs-mode-diff-map)
- ;; keys that operate on individual files
- ("\C-k" . cvs-mode-acknowledge)
- ("A" . cvs-mode-add-change-log-entry-other-window)
- ;;("B" . cvs-mode-byte-compile-files)
- ("C" . cvs-mode-commit-setup)
- ("O" . cvs-mode-update)
- ("U" . cvs-mode-undo)
- ("I" . cvs-mode-insert)
- ("a" . cvs-mode-add)
- ("b" . cvs-set-branch-prefix)
- ("B" . cvs-set-secondary-branch-prefix)
- ("c" . cvs-mode-commit)
- ("e" . cvs-mode-examine)
- ("f" . cvs-mode-find-file)
- ("\C-m" . cvs-mode-find-file)
- ("i" . cvs-mode-ignore)
- ("l" . cvs-mode-log)
- ("o" . cvs-mode-find-file-other-window)
- ("r" . cvs-mode-remove)
- ("s" . cvs-mode-status)
- ("t" . cvs-mode-tag)
- ("v" . cvs-mode-view-file)
- ("x" . cvs-mode-remove-handled)
- ;; cvstree bindings
- ("+" . cvs-mode-tree)
- ;; mouse bindings
- ([mouse-2] . cvs-mode-find-file)
- ([follow-link] . (lambda (pos)
- (if (eq (get-char-property pos 'face) 'cvs-filename) t)))
- ([(down-mouse-3)] . cvs-menu)
- ;; dired-like bindings
- ("\C-o" . cvs-mode-display-file)
- ;; Emacs-21 toolbar
- ;;([tool-bar item1] . (menu-item "Examine" cvs-examine :image (image :file "/usr/share/icons/xpaint.xpm" :type xpm)))
- ;;([tool-bar item2] . (menu-item "Update" cvs-update :image (image :file "/usr/share/icons/mail1.xpm" :type xpm)))
- )
- "Keymap for `cvs-mode'."
- :dense t
- :suppress t)
-
-(fset 'cvs-mode-map cvs-mode-map)
-
-(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'."
- '("CVS"
- ["Open file" cvs-mode-find-file t]
- ["Open in other window" cvs-mode-find-file-other-window t]
- ["Display in other window" cvs-mode-display-file t]
- ["Interactive merge" cvs-mode-imerge t]
- ("View diff"
- ["Interactive diff" cvs-mode-idiff t]
- ["Current diff" cvs-mode-diff t]
- ["Diff with head" cvs-mode-diff-head t]
- ["Diff with vendor" cvs-mode-diff-vendor t]
- ["Diff against yesterday" cvs-mode-diff-yesterday t]
- ["Diff with backup" cvs-mode-diff-backup t])
- ["View log" cvs-mode-log t]
- ["View status" cvs-mode-status t]
- ["View tag tree" cvs-mode-tree t]
- "----"
- ["Insert" cvs-mode-insert]
- ["Update" cvs-mode-update (cvs-enabledp 'update)]
- ["Re-examine" cvs-mode-examine t]
- ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)]
- ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))]
- ["Undo changes" cvs-mode-undo (cvs-enabledp 'undo)]
- ["Add" cvs-mode-add (cvs-enabledp 'add)]
- ["Remove" cvs-mode-remove (cvs-enabledp 'remove)]
- ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)]
- ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t]
- "----"
- ["Mark" cvs-mode-mark t]
- ["Mark all" cvs-mode-mark-all-files t]
- ["Mark by regexp..." cvs-mode-mark-matching-files t]
- ["Mark by state..." cvs-mode-mark-on-state t]
- ["Unmark" cvs-mode-unmark t]
- ["Unmark all" cvs-mode-unmark-all-files t]
- ["Hide handled" cvs-mode-remove-handled t]
- "----"
- ["PCL-CVS Manual" (lambda () (interactive)
- (info "(pcl-cvs)Top")) t]
- "----"
- ["Quit" cvs-mode-quit t]))
-
-;;;;
-;;;; CVS-Minor mode
-;;;;
-
-(defcustom cvs-minor-mode-prefix "\C-xc"
- "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'."
- :group 'pcl-cvs)
-
-(easy-mmode-defmap cvs-minor-mode-map
- `((,cvs-minor-mode-prefix . cvs-mode-map)
- ("e" . (menu-item nil cvs-mode-edit-log
- :filter (lambda (x) (if (derived-mode-p 'log-view-mode) x)))))
- "Keymap for `cvs-minor-mode', used in buffers related to PCL-CVS.")
-
-(defvar cvs-buffer nil
- "(Buffer local) The *cvs* buffer associated with this buffer.")
-(put 'cvs-buffer 'permanent-local t)
-;;(make-variable-buffer-local 'cvs-buffer)
-
-(defvar cvs-minor-wrap-function nil
- "Function to call when switching to the *cvs* buffer.
-Takes two arguments:
-- a *cvs* buffer.
-- a zero-arg function which is guaranteed not to switch buffer.
-It is expected to call the function.")
-;;(make-variable-buffer-local 'cvs-minor-wrap-function)
-
-(defvar cvs-minor-current-files)
-;;"Current files in a `cvs-minor-mode' buffer."
-;; This should stay `void' because we want to be able to tell the difference
-;; between an empty list and no list at all.
-
-(defconst cvs-pcl-cvs-dirchange-re "^pcl-cvs: descending directory \\(.*\\)$")
-
-;;;;
-;;;; autoload the global menu
-;;;;
-
-;;;###autoload
-(defvar cvs-global-menu
- (let ((m (make-sparse-keymap "PCL-CVS")))
- (define-key m [status]
- `(menu-item ,(purecopy "Directory Status") cvs-status
- :help ,(purecopy "A more verbose status of a workarea")))
- (define-key m [checkout]
- `(menu-item ,(purecopy "Checkout Module") cvs-checkout
- :help ,(purecopy "Check out a module from the repository")))
- (define-key m [update]
- `(menu-item ,(purecopy "Update Directory") cvs-update
- :help ,(purecopy "Fetch updates from the repository")))
- (define-key m [examine]
- `(menu-item ,(purecopy "Examine Directory") cvs-examine
- :help ,(purecopy "Examine the current state of a workarea")))
- (fset 'cvs-global-menu m)))
-
-
-;; cvs-1.10 and above can take file arguments in other directories
-;; while others need to be executed once per directory
-(defvar cvs-execute-single-dir
- (if (or (null cvs-version)
- (or (>= (cdr cvs-version) 10) (> (car cvs-version) 1)))
- ;; Supposedly some recent versions of CVS output some directory info
- ;; as they recurse downthe tree, but it's not good enough in the case
- ;; where we run "cvs status foo bar/foo".
- '("status")
- t)
- "Whether cvs commands should be executed a directory at a time.
-If a list, specifies for which commands the single-dir mode should be used.
-If T, single-dir mode should be used for all operations.
-
-CVS versions before 1.10 did not allow passing them arguments in different
-directories, so pcl-cvs checks what version you're using to determine
-whether to use the new feature or not.
-Sadly, even with a new cvs executable, if you connect to an older cvs server
-\(typically a cvs-1.9 on the server), the old restriction applies. In such
-a case the sanity check made by pcl-cvs fails and you will have to manually
-set this variable to t (until the cvs server is upgraded).
-When the above problem occurs, pcl-cvs should (hopefully) catch cvs' error
-message and replace it with a message telling you to change this variable.")
-
-;;
-(provide 'pcvs-defs)
-
-;; arch-tag: c7c701d0-d1d4-4aa9-a302-007bb03aca5e
-;;; pcvs-defs.el ends here
+++ /dev/null
-;;; pcvs-info.el --- internal representation of a fileinfo entry
-
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: pcl-cvs
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; The cvs-fileinfo data structure:
-;;
-;; When the `cvs update' is ready we parse the output. Every file
-;; that is affected in some way is added to the cookie collection as
-;; a "fileinfo" (as defined below in cvs-create-fileinfo).
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'pcvs-util)
-;;(require 'pcvs-defs)
-
-;;;;
-;;;; config variables
-;;;;
-
-(define-obsolete-variable-alias 'cvs-display-full-path
- 'cvs-display-full-name "22.1")
-
-(defcustom cvs-display-full-name t
- "Specifies how the filenames should be displayed in the listing.
-If non-nil, their full filename name will be displayed, else only the
-non-directory part."
- :group 'pcl-cvs
- :type '(boolean))
-
-(defcustom cvs-allow-dir-commit nil
- "Allow `cvs-mode-commit' on directories.
-If you commit without any marked file and with the cursor positioned
-on a directory entry, cvs would commit the whole directory. This seems
-to confuse some users sometimes."
- :group 'pcl-cvs
- :type '(boolean))
-
-;;;;
-;;;; Faces for fontification
-;;;;
-
-(defface cvs-header
- '((((class color) (background dark))
- (:foreground "lightyellow" :weight bold))
- (((class color) (background light))
- (:foreground "blue4" :weight bold))
- (t (:weight bold)))
- "PCL-CVS face used to highlight directory changes."
- :group 'pcl-cvs)
-(define-obsolete-face-alias 'cvs-header-face 'cvs-header "22.1")
-
-(defface cvs-filename
- '((((class color) (background dark))
- (:foreground "lightblue"))
- (((class color) (background light))
- (:foreground "blue4"))
- (t ()))
- "PCL-CVS face used to highlight file names."
- :group 'pcl-cvs)
-(define-obsolete-face-alias 'cvs-filename-face 'cvs-filename "22.1")
-
-(defface cvs-unknown
- '((((class color) (background dark))
- (:foreground "red1"))
- (((class color) (background light))
- (:foreground "red1"))
- (t (:slant italic)))
- "PCL-CVS face used to highlight unknown file status."
- :group 'pcl-cvs)
-(define-obsolete-face-alias 'cvs-unknown-face 'cvs-unknown "22.1")
-
-(defface cvs-handled
- '((((class color) (background dark))
- (:foreground "pink"))
- (((class color) (background light))
- (:foreground "pink"))
- (t ()))
- "PCL-CVS face used to highlight handled file status."
- :group 'pcl-cvs)
-(define-obsolete-face-alias 'cvs-handled-face 'cvs-handled "22.1")
-
-(defface cvs-need-action
- '((((class color) (background dark))
- (:foreground "orange"))
- (((class color) (background light))
- (:foreground "orange"))
- (t (:slant italic)))
- "PCL-CVS face used to highlight status of files needing action."
- :group 'pcl-cvs)
-(define-obsolete-face-alias 'cvs-need-action-face 'cvs-need-action "22.1")
-
-(defface cvs-marked
- '((((min-colors 88) (class color) (background dark))
- (:foreground "green1" :weight bold))
- (((class color) (background dark))
- (:foreground "green" :weight bold))
- (((class color) (background light))
- (:foreground "green3" :weight bold))
- (t (:weight bold)))
- "PCL-CVS face used to highlight marked file indicator."
- :group 'pcl-cvs)
-(define-obsolete-face-alias 'cvs-marked-face 'cvs-marked "22.1")
-
-(defface cvs-msg
- '((t (:slant italic)))
- "PCL-CVS face used to highlight CVS messages."
- :group 'pcl-cvs)
-(define-obsolete-face-alias 'cvs-msg-face 'cvs-msg "22.1")
-
-(defvar cvs-fi-up-to-date-face 'cvs-handled)
-(defvar cvs-fi-unknown-face 'cvs-unknown)
-(defvar cvs-fi-conflict-face 'font-lock-warning-face)
-
-;; There is normally no need to alter the following variable, but if
-;; your site has installed CVS in a non-standard way you might have
-;; to change it.
-
-(defvar cvs-bakprefix ".#"
- "The prefix that CVS prepends to files when rcsmerge'ing.")
-
-(easy-mmode-defmap cvs-status-map
- '(([(mouse-2)] . cvs-mode-toggle-mark))
- "Local keymap for text properties of status")
-
-;; Constructor:
-
-(defstruct (cvs-fileinfo
- (:constructor nil)
- (:copier nil)
- (:constructor -cvs-create-fileinfo (type dir file full-log
- &key marked subtype
- merge
- base-rev
- head-rev))
- (:conc-name cvs-fileinfo->))
- marked ;; t/nil.
- type ;; See below
- subtype ;; See below
- dir ;; Relative directory the file resides in.
- ;; (concat dir file) should give a valid path.
- file ;; The file name sans the directory.
- base-rev ;; During status: This is the revision that the
- ;; working file is based on.
- head-rev ;; During status: This is the highest revision in
- ;; the repository.
- merge ;; A cons cell containing the (ancestor . head) revisions
- ;; of the merge that resulted in the current file.
- ;;removed ;; t if the file no longer exists.
- full-log ;; The output from cvs, unparsed.
- ;;mod-time ;; Not used.
-
- ;; In addition to the above, the following values can be extracted:
-
- ;; handled ;; t if this file doesn't require further action.
- ;; full-name ;; The complete relative filename.
- ;; pp-name ;; The printed file name
- ;; backup-file;; For MERGED and CONFLICT files after a \"cvs update\",
- ;; this is a full path to the backup file where the
- ;; untouched version resides.
-
- ;; The meaning of the type field:
-
- ;; Value ---Used by--- Explanation
- ;; update status
- ;; NEED-UPDATE x file needs update
- ;; MODIFIED x x modified by you, unchanged in repository
- ;; MERGED x x successful merge
- ;; ADDED x x added by you, not yet committed
- ;; MISSING x rm'd, but not yet `cvs remove'd
- ;; REMOVED x x removed by you, not yet committed
- ;; NEED-MERGE x need merge
- ;; CONFLICT x conflict when merging
- ;; ;;MOD-CONFLICT x removed locally, changed in repository.
- ;; DIRCHANGE x x A change of directory.
- ;; UNKNOWN x An unknown file.
- ;; UP-TO-DATE x The file is up-to-date.
- ;; UPDATED x x file copied from repository
- ;; PATCHED x x diff applied from repository
- ;; COMMITTED x x cvs commit'd
- ;; DEAD An entry that should be removed
- ;; MESSAGE x x This is a special fileinfo that is used
- ;; to display a text that should be in
- ;; full-log."
- ;; TEMP A temporary message that should be removed
- )
-(defun cvs-create-fileinfo (type dir file msg &rest keys)
- (cvs-check-fileinfo (apply #'-cvs-create-fileinfo type dir file msg keys)))
-
-;; Fake selectors:
-
-(defun cvs-fileinfo->full-name (fileinfo)
- "Return the full path for the file that is described in FILEINFO."
- (let ((dir (cvs-fileinfo->dir fileinfo)))
- (if (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE)
- (if (string= dir "") "." (directory-file-name dir))
- ;; Here, I use `concat' rather than `expand-file-name' because I want
- ;; the resulting path to stay relative if `dir' is relative.
- (concat dir (cvs-fileinfo->file fileinfo)))))
-(define-obsolete-function-alias 'cvs-fileinfo->full-path
- 'cvs-fileinfo->full-name "22.1")
-
-(defun cvs-fileinfo->pp-name (fi)
- "Return the filename of FI as it should be displayed."
- (if cvs-display-full-name
- (cvs-fileinfo->full-name fi)
- (cvs-fileinfo->file fi)))
-
-(defun cvs-fileinfo->backup-file (fileinfo)
- "Construct the file name of the backup file for FILEINFO."
- (let* ((dir (cvs-fileinfo->dir fileinfo))
- (file (cvs-fileinfo->file fileinfo))
- (default-directory (file-name-as-directory (expand-file-name dir)))
- (files (directory-files "." nil
- (concat "\\`" (regexp-quote cvs-bakprefix)
- (regexp-quote file) "\\(\\.[0-9]+\\.[0-9]+\\)+\\'")))
- bf)
- (dolist (f files)
- (when (and (file-readable-p f)
- (or (null bf) (file-newer-than-file-p f bf)))
- (setq bf f)))
- (concat dir bf)))
-
-;; (defun cvs-fileinfo->handled (fileinfo)
-;; "Tell if this requires further action"
-;; (memq (cvs-fileinfo->type fileinfo) '(UP-TO-DATE DEAD)))
-
-\f
-;; Predicate:
-
-(defun cvs-check-fileinfo (fi)
- "Check FI's conformance to some conventions."
- (let ((check 'none)
- (type (cvs-fileinfo->type fi))
- (subtype (cvs-fileinfo->subtype fi))
- (marked (cvs-fileinfo->marked fi))
- (dir (cvs-fileinfo->dir fi))
- (file (cvs-fileinfo->file fi))
- (base-rev (cvs-fileinfo->base-rev fi))
- (head-rev (cvs-fileinfo->head-rev fi))
- (full-log (cvs-fileinfo->full-log fi)))
- (if (and (setq check 'marked) (memq marked '(t nil))
- (setq check 'base-rev) (or (null base-rev) (stringp base-rev))
- (setq check 'head-rev) (or (null head-rev) (stringp head-rev))
- (setq check 'full-log) (stringp full-log)
- (setq check 'dir)
- (and (stringp dir)
- (not (file-name-absolute-p dir))
- (or (string= dir "")
- (string= dir (file-name-as-directory dir))))
- (setq check 'file)
- (and (stringp file)
- (string= file (file-name-nondirectory file)))
- (setq check 'type) (symbolp type)
- (setq check 'consistency)
- (case type
- (DIRCHANGE (and (null subtype) (string= "." file)))
- ((NEED-UPDATE ADDED MISSING DEAD MODIFIED MESSAGE UP-TO-DATE
- REMOVED NEED-MERGE CONFLICT UNKNOWN MESSAGE)
- t)))
- fi
- (error "Invalid :%s in cvs-fileinfo %s" check fi))))
-
-\f
-;;;;
-;;;; State table to indicate what you can do when.
-;;;;
-
-(defconst cvs-states
- `((NEED-UPDATE update diff ignore)
- (UP-TO-DATE update nil remove diff safe-rm revert)
- (MODIFIED update commit undo remove diff merge diff-base)
- (ADDED update commit remove)
- (MISSING remove undo update safe-rm revert)
- (REMOVED commit add undo safe-rm)
- (NEED-MERGE update undo diff diff-base)
- (CONFLICT merge remove undo commit diff diff-base)
- (DIRCHANGE remove update diff ,(if cvs-allow-dir-commit 'commit) tag)
- (UNKNOWN ignore add remove)
- (DEAD )
- (MESSAGE))
- "Fileinfo state descriptions for pcl-cvs.
-This is an assoc list. Each element consists of (STATE . FUNS)
-- STATE (described in `cvs-create-fileinfo') is the key
-- FUNS is the list of applicable operations.
- The first one (if any) should be the \"default\" action.
-Most of the actions have the obvious meaning.
-`safe-rm' indicates that the file can be removed without losing
- any information.")
-
-;;;;
-;;;; Utility functions
-;;;;
-
-(defun cvs-applicable-p (fi-or-type func)
- "Check if FUNC is applicable to FI-OR-TYPE.
-If FUNC is nil, always return t.
-FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo."
- (let ((type (if (symbolp fi-or-type) fi-or-type
- (cvs-fileinfo->type fi-or-type))))
- (and (not (eq type 'MESSAGE))
- (eq (car (memq func (cdr (assq type cvs-states)))) func))))
-
-(defun cvs-add-face (str face &optional keymap &rest props)
- (when keymap
- (when (keymapp keymap)
- (setq props (list* 'keymap keymap props)))
- (setq props (list* 'mouse-face 'highlight props)))
- (add-text-properties 0 (length str) (list* 'font-lock-face face props) str)
- str)
-
-(defun cvs-fileinfo-pp (fileinfo)
- "Pretty print FILEINFO. Insert a printed representation in current buffer.
-For use by the cookie package."
- (cvs-check-fileinfo fileinfo)
- (let ((type (cvs-fileinfo->type fileinfo))
- (subtype (cvs-fileinfo->subtype fileinfo)))
- (insert
- (case type
- (DIRCHANGE (concat "In directory "
- (cvs-add-face (cvs-fileinfo->full-name fileinfo)
- 'cvs-header t 'cvs-goal-column t)
- ":"))
- (MESSAGE
- (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo))
- 'cvs-msg))
- (t
- (let* ((status (if (cvs-fileinfo->marked fileinfo)
- (cvs-add-face "*" 'cvs-marked)
- " "))
- (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo)
- 'cvs-filename t 'cvs-goal-column t))
- (base (or (cvs-fileinfo->base-rev fileinfo) ""))
- (head (cvs-fileinfo->head-rev fileinfo))
- (type
- (let ((str (case type
- ;;(MOD-CONFLICT "Not Removed")
- (DEAD "")
- (t (capitalize (symbol-name type)))))
- (face (let ((sym (intern
- (concat "cvs-fi-"
- (downcase (symbol-name type))
- "-face"))))
- (or (and (boundp sym) (symbol-value sym))
- 'cvs-need-action))))
- (cvs-add-face str face cvs-status-map)))
- (side (or
- ;; maybe a subtype
- (when subtype (downcase (symbol-name subtype)))
- ;; or the head-rev
- (when (and head (not (string= head base))) head)
- ;; or nothing
- "")))
- (format "%-11s %s %-11s %-11s %s"
- side status type base file))))
- "\n")))
-
-
-(defun cvs-fileinfo-update (fi fi-new)
- "Update FI with the information provided in FI-NEW."
- (let ((type (cvs-fileinfo->type fi-new))
- (merge (cvs-fileinfo->merge fi-new)))
- (setf (cvs-fileinfo->type fi) type)
- (setf (cvs-fileinfo->subtype fi) (cvs-fileinfo->subtype fi-new))
- (setf (cvs-fileinfo->full-log fi) (cvs-fileinfo->full-log fi-new))
- (setf (cvs-fileinfo->base-rev fi) (cvs-fileinfo->base-rev fi-new))
- (setf (cvs-fileinfo->head-rev fi) (cvs-fileinfo->head-rev fi-new))
- (cond
- (merge (setf (cvs-fileinfo->merge fi) merge))
- ((memq type '(UP-TO-DATE NEED-UPDATE))
- (setf (cvs-fileinfo->merge fi) nil)))))
-
-(defun cvs-fileinfo< (a b)
- "Compare fileinfo A with fileinfo B and return t if A is `less'.
-The ordering defined by this function is such that directories are
-sorted alphabetically, and inside every directory the DIRCHANGE
-fileinfo will appear first, followed by all files (alphabetically)."
- (let ((subtypea (cvs-fileinfo->subtype a))
- (subtypeb (cvs-fileinfo->subtype b)))
- (cond
- ;; Sort according to directories.
- ((string< (cvs-fileinfo->dir a) (cvs-fileinfo->dir b)) t)
- ((not (string= (cvs-fileinfo->dir a) (cvs-fileinfo->dir b))) nil)
-
- ;; The DIRCHANGE entry is always first within the directory.
- ((eq (cvs-fileinfo->type b) 'DIRCHANGE) nil)
- ((eq (cvs-fileinfo->type a) 'DIRCHANGE) t)
-
- ;; All files are sorted by file name.
- ((string< (cvs-fileinfo->file a) (cvs-fileinfo->file b))))))
-
-;;;
-;;; Look at CVS/Entries to quickly find a first approximation of the status
-;;;
-
-(defun cvs-fileinfo-from-entries (dir &optional all)
- "List of fileinfos for DIR, extracted from CVS/Entries.
-Unless ALL is optional, returns only the files that are not up-to-date.
-DIR can also be a file."
- (let* ((singlefile
- (cond
- ((equal dir "") nil)
- ((file-directory-p dir) (setq dir (file-name-as-directory dir)) nil)
- (t (prog1 (file-name-nondirectory dir)
- (setq dir (or (file-name-directory dir) ""))))))
- (file (expand-file-name "CVS/Entries" dir))
- (fis nil))
- (if (not (file-readable-p file))
- (push (cvs-create-fileinfo (if singlefile 'UNKNOWN 'DIRCHANGE)
- dir (or singlefile ".") "") fis)
- (with-temp-buffer
- (insert-file-contents file)
- (goto-char (point-min))
- ;; Select the single file entry in case we're only interested in a file.
- (cond
- ((not singlefile)
- (push (cvs-create-fileinfo 'DIRCHANGE dir "." "") fis))
- ((re-search-forward
- (concat "^[^/]*/" (regexp-quote singlefile) "/.*") nil t)
- (setq all t)
- (goto-char (match-beginning 0))
- (narrow-to-region (point) (match-end 0)))
- (t
- (push (cvs-create-fileinfo 'UNKNOWN dir singlefile "") fis)
- (narrow-to-region (point-min) (point-min))))
- (while (looking-at "\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/")
- (if (/= (match-beginning 1) (match-end 1))
- (setq fis (append (cvs-fileinfo-from-entries
- (concat dir (file-name-as-directory
- (match-string 2)))
- all)
- fis))
- (let ((f (match-string 2))
- (rev (match-string 3))
- (date (match-string 4))
- timestamp
- (type 'MODIFIED)
- (subtype nil))
- (cond
- ((equal (substring rev 0 1) "-")
- (setq type 'REMOVED rev (substring rev 1)))
- ((not (file-exists-p (concat dir f))) (setq type 'MISSING))
- ((equal rev "0") (setq type 'ADDED rev nil))
- ((equal date "Result of merge") (setq subtype 'MERGED))
- ((let ((mtime (nth 5 (file-attributes (concat dir f))))
- (system-time-locale "C"))
- (setq timestamp (format-time-string "%c" mtime 'utc))
- ;; Solaris sometimes uses "Wed Sep 05", not "Wed Sep 5".
- ;; See "grep '[^a-z_]ctime' cvs/src/*.c" for reference.
- (if (= (aref timestamp 8) ?0)
- (setq timestamp (concat (substring timestamp 0 8)
- " " (substring timestamp 9))))
- (equal timestamp date))
- (setq type (if all 'UP-TO-DATE)))
- ((equal date (concat "Result of merge+" timestamp))
- (setq type 'CONFLICT)))
- (when type
- (push (cvs-create-fileinfo type dir f ""
- :base-rev rev :subtype subtype)
- fis))))
- (forward-line 1))))
- fis))
-
-(provide 'pcvs-info)
-
-;; arch-tag: d85dde07-bdc2-400a-882f-92f398c7b0ba
-;;; pcvs-info.el ends here
+++ /dev/null
-;;; pcvs-parse.el --- the CVS output parser
-
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: pcl-cvs
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Bugs:
-
-;; - when merging a modified file, if the merge says that the file already
-;; contained in the changes, it marks the file as `up-to-date' although
-;; it might still contain further changes.
-;; Example: merging a zero-change commit.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'pcvs-util)
-(require 'pcvs-info)
-
-;; imported from pcvs.el
-(defvar cvs-execute-single-dir)
-
-;; parse vars
-
-(defcustom cvs-update-prog-output-skip-regexp "$"
- "A regexp that matches the end of the output from all cvs update programs.
-That is, output from any programs that are run by CVS (by the flag -u
-in the `modules' file - see cvs(5)) when `cvs update' is performed should
-terminate with a line that this regexp matches. It is enough that
-some part of the line is matched.
-
-The default (a single $) fits programs without output."
- :group 'pcl-cvs
- :type '(regexp :value "$"))
-
-(defcustom cvs-parse-ignored-messages
- '("Executing ssh-askpass to query the password.*$"
- ".*Remote host denied X11 forwarding.*$")
- "A list of regexps matching messages that should be ignored by the parser.
-Each regexp should match a whole set of lines and should hence be terminated
-by `$'."
- :group 'pcl-cvs
- :type '(repeat regexp))
-
-;; a few more defvars just to shut up the compiler
-(defvar cvs-start)
-(defvar cvs-current-dir)
-(defvar cvs-current-subdir)
-(defvar dont-change-disc)
-
-;;;; The parser
-
-(defconst cvs-parse-known-commands
- '("status" "add" "commit" "update" "remove" "checkout" "ci")
- "List of CVS commands whose output is understood by the parser.")
-
-(defun cvs-parse-buffer (parse-spec dont-change-disc &optional subdir)
- "Parse current buffer according to PARSE-SPEC.
-PARSE-SPEC is a function of no argument advancing the point and returning
- either a fileinfo or t (if the matched text should be ignored) or
- nil if it didn't match anything.
-DONT-CHANGE-DISC just indicates whether the command was changing the disc
- or not (useful to tell the difference between `cvs-examine' and `cvs-update'
- output.
-The path names should be interpreted as relative to SUBDIR (defaults
- to the `default-directory').
-Return a list of collected entries, or t if an error occurred."
- (goto-char (point-min))
- (let ((fileinfos ())
- (cvs-current-dir "")
- (case-fold-search nil)
- (cvs-current-subdir (or subdir "")))
- (while (not (or (eobp) (eq fileinfos t)))
- (let ((ret (cvs-parse-run-table parse-spec)))
- (cond
- ;; it matched a known information message
- ((cvs-fileinfo-p ret) (push ret fileinfos))
- ;; it didn't match anything at all (impossible)
- ((and (consp ret) (cvs-fileinfo-p (car ret)))
- (setq fileinfos (append ret fileinfos)))
- ((null ret) (setq fileinfos t))
- ;; it matched something that should be ignored
- (t nil))))
- (nreverse fileinfos)))
-
-
-;; All those parsing macros/functions should return a success indicator
-(defsubst cvs-parse-msg () (buffer-substring cvs-start (1- (point))))
-
-;;(defsubst COLLECT (exp) (push exp *result*))
-;;(defsubst PROG (e) t)
-;;(defmacro SEQ (&rest seqs) (cons 'and seqs))
-
-(defmacro cvs-match (re &rest matches)
- "Try to match RE and extract submatches.
-If RE matches, advance the point until the line after the match and
-then assign the variables as specified in MATCHES (via `setq')."
- (cons 'cvs-do-match
- (cons re (mapcar (lambda (match)
- `(cons ',(first match) ,(second match)))
- matches))))
-
-(defun cvs-do-match (re &rest matches)
- "Internal function for the `cvs-match' macro.
-Match RE and if successful, execute MATCHES."
- ;; Is it a match?
- (when (looking-at re)
- (goto-char (match-end 0))
- ;; Skip the newline (unless we already are at the end of the buffer).
- (when (and (eolp) (< (point) (point-max))) (forward-char))
- ;; assign the matches
- (dolist (match matches t)
- (let ((val (cdr match)))
- (set (car match) (if (integerp val) (match-string val) val))))))
-
-(defmacro cvs-or (&rest alts)
- "Try each one of the ALTS alternatives until one matches."
- `(let ((-cvs-parse-point (point)))
- ,(cons 'or
- (mapcar (lambda (es)
- `(or ,es (ignore (goto-char -cvs-parse-point))))
- alts))))
-(def-edebug-spec cvs-or t)
-
-;; This is how parser tables should be executed
-(defun cvs-parse-run-table (parse-spec)
- "Run PARSE-SPEC and provide sensible default behavior."
- (unless (bolp) (forward-line 1)) ;this should never be needed
- (let ((cvs-start (point)))
- (cvs-or
- (funcall parse-spec)
-
- (dolist (re cvs-parse-ignored-messages)
- (when (cvs-match re) (return t)))
-
- ;; This is a parse error. Create a message-type fileinfo.
- (and
- (cvs-match ".*$")
- (cvs-create-fileinfo 'MESSAGE cvs-current-dir " "
- ;; (concat " Unknown msg: '"
- (cvs-parse-msg) ;; "'")
- :subtype 'ERROR)))))
-
-\f
-(defun cvs-parsed-fileinfo (type path &optional directory &rest keys)
- "Create a fileinfo.
-TYPE can either be a type symbol or a cons of the form (TYPE . SUBTYPE).
-PATH is the filename.
-DIRECTORY influences the way PATH is interpreted:
-- if it's a string, it denotes the directory in which PATH (which should then be
- a plain file name with no directory component) resides.
-- if it's nil, the PATH should not be trusted: if it has a directory
- component, use it, else, assume it is relative to the current directory.
-- else, the PATH should be trusted to be relative to the root
- directory (i.e. if there is no directory component, it means the file
- is inside the main directory).
-The remaining KEYS are passed directly to `cvs-create-fileinfo'."
- (let ((dir directory)
- (file path))
- ;; only trust the directory if it's a string
- (unless (stringp directory)
- ;; else, if the directory is true, the path should be trusted
- (setq dir (or (file-name-directory path) (if directory "")))
- (setq file (file-name-nondirectory path)))
-
- (let ((type (if (consp type) (car type) type))
- (subtype (if (consp type) (cdr type))))
- (when dir (setq cvs-current-dir dir))
- (apply 'cvs-create-fileinfo type
- (concat cvs-current-subdir (or dir cvs-current-dir))
- file (cvs-parse-msg) :subtype subtype keys))))
-\f
-;;;; CVS Process Parser Tables:
-;;;;
-;;;; The table for status and update could actually be merged since they
-;;;; don't conflict. But they don't overlap much either.
-
-(defun cvs-parse-table ()
- "Table of message objects for `cvs-parse-process'."
- (let (c file dir path base-rev subtype)
- (cvs-or
-
- (cvs-parse-status)
- (cvs-parse-merge)
- (cvs-parse-commit)
-
- ;; this is not necessary because the fileinfo merging will remove
- ;; such duplicate info and luckily the second info is the one we want.
- ;; (and (cvs-match "M \\(.*\\)$" (path 1))
- ;; (cvs-parse-merge path))
-
- ;; Normal file state indicator.
- (and
- (cvs-match "\\([MARCUPNJ?]\\) \\(.*\\)$" (c 1) (path 2))
- ;; M: The file is modified by the user, and untouched in the repository.
- ;; A: The file is "cvs add"ed, but not "cvs ci"ed.
- ;; R: The file is "cvs remove"ed, but not "cvs ci"ed.
- ;; C: Conflict
- ;; U: The file is copied from the repository.
- ;; P: The file was patched from the repository.
- ;; ?: Unknown file.
- (let ((code (aref c 0)))
- (cvs-parsed-fileinfo
- (case code
- (?M 'MODIFIED)
- (?A 'ADDED)
- (?R 'REMOVED)
- (?? 'UNKNOWN)
- (?C
- (if (not dont-change-disc) 'CONFLICT
- ;; This is ambiguous. We should look for conflict markers in the
- ;; file to decide between CONFLICT and NEED-MERGE. With CVS-1.10
- ;; servers, this should not be necessary, because they return
- ;; a complete merge output.
- (with-temp-buffer
- (ignore-errors (insert-file-contents path))
- (goto-char (point-min))
- (if (re-search-forward "^<<<<<<< " nil t)
- 'CONFLICT 'NEED-MERGE))))
- (?J 'NEED-MERGE) ;not supported by standard CVS
- ((?U ?P)
- (if dont-change-disc 'NEED-UPDATE
- (cons 'UP-TO-DATE (if (eq code ?U) 'UPDATED 'PATCHED)))))
- path 'trust)))
-
- (and
- (cvs-match "pcl-cvs: descending directory \\(.*\\)$" (dir 1))
- (setq cvs-current-subdir dir))
-
- ;; A special cvs message
- (and
- (let ((case-fold-search t))
- (cvs-match "cvs[.a-z]* [a-z]+: "))
- (cvs-or
-
- ;; CVS is descending a subdirectory
- ;; (status says `examining' while update says `updating')
- (and
- (cvs-match "\\(Examining\\|Updating\\) \\(.*\\)$" (dir 2))
- (let ((dir (if (string= "." dir) "" (file-name-as-directory dir))))
- (cvs-parsed-fileinfo 'DIRCHANGE "." dir)))
-
- ;; [-n update] A new (or pruned) directory appeared but isn't traversed
- (and
- (cvs-match "New directory `\\(.*\\)' -- ignored$" (dir 1))
- ;; (cvs-parsed-fileinfo 'MESSAGE " " (file-name-as-directory dir))
- ;; These messages either correspond to a true new directory
- ;; that an update will bring in, or to a directory that's empty
- ;; on the current branch (either because it only exists in other
- ;; branches, or because it's been removed).
- (if (ignore-errors
- (with-temp-buffer
- (ignore-errors
- (insert-file-contents
- (expand-file-name ".cvsignore" (file-name-directory dir))))
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote (file-name-nondirectory dir)) "/$")
- nil t)))
- t ;The user requested to ignore those messages.
- (cvs-parsed-fileinfo '(NEED-UPDATE . NEW-DIR) dir t)))
-
- ;; File removed, since it is removed (by third party) in repository.
- (and
- (cvs-or
- ;; some cvs versions output quotes around these files
- (cvs-match "warning: `\\(.*\\)' is not (any longer) pertinent$" (file 1))
- (cvs-match "warning: \\(.*\\) is not (any longer) pertinent$" (file 1))
- (cvs-match "`\\(.*\\)' is no longer in the repository$" (file 1))
- (cvs-match "\\(.*\\) is no longer in the repository$" (file 1)))
- (cvs-parsed-fileinfo
- (if dont-change-disc '(NEED-UPDATE . REMOVED) 'DEAD) file))
-
- ;; [add]
- (and
- (cvs-or
- (cvs-match "scheduling file `\\(.*\\)' for addition.*$" (path 1))
- (cvs-match "re-adding file \\(.*\\) (in place of .*)$" (path 1)))
- (cvs-parsed-fileinfo 'ADDED path))
-
- ;; [add] this will also show up as a `U <file>'
- (and
- (cvs-match "`?\\(.*?\\)'?, version \\(.*\\), resurrected$"
- (path 1) (base-rev 2))
- ;; FIXME: resurrection only brings back the original version,
- ;; not the latest on the branch, so `up-to-date' is not always
- ;; what we want.
- (cvs-parsed-fileinfo '(UP-TO-DATE . RESURRECTED) path nil
- :base-rev base-rev))
-
- ;; [remove]
- (and
- (cvs-match "removed `\\(.*\\)'$" (path 1))
- (cvs-parsed-fileinfo 'DEAD path))
-
- ;; [remove,merge]
- (and
- (cvs-match "scheduling `\\(.*\\)' for removal$" (file 1))
- (cvs-parsed-fileinfo 'REMOVED file))
-
- ;; [update] File removed by you, but not cvs rm'd
- (and
- (cvs-match "warning: \\(.*\\) was lost$" (path 1))
- (cvs-match (concat "U " (regexp-quote path) "$"))
- (cvs-parsed-fileinfo (if dont-change-disc
- 'MISSING
- '(UP-TO-DATE . UPDATED))
- path))
-
- ;; Mode conflicts (rather than contents)
- (and
- (cvs-match "conflict: ")
- (cvs-or
- (cvs-match "removed \\(.*\\) was modified by second party$"
- (path 1) (subtype 'REMOVED))
- (cvs-match "\\(.*\\) created independently by second party$"
- (path 1) (subtype 'ADDED))
- (cvs-match "\\(.*\\) is modified but no longer in the repository$"
- (path 1) (subtype 'MODIFIED)))
- (cvs-match (concat "C " (regexp-quote path)))
- (cvs-parsed-fileinfo (cons 'CONFLICT subtype) path))
-
- ;; Messages that should be shown to the user
- (and
- (cvs-or
- (cvs-match "move away \\(.*\\); it is in the way$" (file 1))
- (cvs-match "warning: new-born \\(.*\\) has disappeared$" (file 1))
- (cvs-match "sticky tag .* for file `\\(.*\\)' is not a branch$"
- (file 1)))
- (cvs-parsed-fileinfo 'MESSAGE file))
-
- ;; File unknown.
- (and (cvs-match "use `.+ add' to create an entry for \\(.*\\)$" (path 1))
- (cvs-parsed-fileinfo 'UNKNOWN path))
-
- ;; [commit]
- (and (cvs-match "Up-to-date check failed for `\\(.+\\)'$" (file 1))
- (cvs-parsed-fileinfo 'NEED-MERGE file))
-
- ;; We use cvs-execute-multi-dir but cvs can't handle it
- ;; Probably because the cvs-client can but the cvs-server can't
- (and (cvs-match ".* files with '?/'? in their name.*$")
- (not cvs-execute-single-dir)
- (setq cvs-execute-single-dir t)
- (cvs-create-fileinfo
- 'MESSAGE "" " "
- "*** Add (setq cvs-execute-single-dir t) to your .emacs ***
- See the FAQ file or the variable's documentation for more info."))
-
- ;; Cvs waits for a lock. Ignored: already handled by the process filter
- (cvs-match "\\[..:..:..\\] \\(waiting for\\|obtained\\) .*lock in .*$")
- ;; File you removed still exists. Ignore (will be noted as removed).
- (cvs-match ".* should be removed and is still there$")
- ;; just a note
- (cvs-match "use ['`].+ commit' to \\sw+ th\\sw+ files? permanently$")
- ;; [add,status] followed by a more complete status description anyway
- (and (cvs-match "nothing known about \\(.*\\)$" (path 1))
- (cvs-parsed-fileinfo 'DEAD path 'trust))
- ;; [update] problem with patch
- (cvs-match "checksum failure after patch to .*; will refetch$")
- (cvs-match "refetching unpatchable files$")
- ;; [commit]
- (cvs-match "Rebuilding administrative file database$")
- ;; ???
- (cvs-match "--> Using per-directory sticky tag `.*'")
-
- ;; CVS is running a *info program.
- (and
- (cvs-match "Executing.*$")
- ;; Skip by any output the program may generate to stdout.
- ;; Note that pcl-cvs will get seriously confused if the
- ;; program prints anything to stderr.
- (re-search-forward cvs-update-prog-output-skip-regexp))))
-
- (and
- (cvs-match "cvs[.ex]* \\[[a-z]+ aborted\\]:.*$")
- (cvs-parsed-fileinfo 'MESSAGE ""))
-
- ;; sadly you can't do much with these since the path is in the repository
- (cvs-match "Directory .* added to the repository$")
- )))
-
-
-(defun cvs-parse-merge ()
- (let (path base-rev head-rev type)
- ;; A merge (maybe with a conflict).
- (and
- (cvs-match "RCS file: .*$")
- ;; Squirrel away info about the files that were retrieved for merging
- (cvs-match "retrieving revision \\([0-9.]+\\)$" (base-rev 1))
- (cvs-match "retrieving revision \\([0-9.]+\\)$" (head-rev 1))
- (cvs-match "Merging differences between [0-9.]+ and [0-9.]+ into \\(.*\\)$"
- (path 1))
-
- ;; eat up potential conflict warnings
- (cvs-or (cvs-match "\\(rcs\\)?merge:?\\( warning\\)?: \\(overlaps\\|conflicts\\) \\(or other problems \\)?during merge$" (type 'CONFLICT)) t)
- (cvs-or
- (and
- (cvs-match "cvs[.ex]* [a-z]+: ")
- (cvs-or
- (cvs-match "conflicts found in \\(.*\\)$" (path 1) (type 'CONFLICT))
- (cvs-match "could not merge .*$")
- (cvs-match "restoring \\(.*\\) from backup file .*$" (path 1))))
- t)
-
- ;; Is it a succesful merge?
- ;; Figure out result of merging (ie, was there a conflict?)
- (let ((qfile (regexp-quote path)))
- (cvs-or
- ;; Conflict
- (and
- (cvs-match (concat "C \\(.*" qfile "\\)$") (path 1) (type 'CONFLICT))
- ;; C might be followed by a "suprious" U for non-mergeable files
- (cvs-or (cvs-match (concat "U \\(.*" qfile "\\)$")) t))
- ;; Successful merge
- (cvs-match (concat "M \\(.*" qfile "\\)$") (path 1))
- ;; The file already contained the modifications
- (cvs-match (concat "^\\(.*" qfile
- "\\) already contains the differences between .*$")
- (path 1) (type '(UP-TO-DATE . MERGED)))
- t)
- ;; FIXME: PATH might not be set yet. Sometimes the only path
- ;; information is in `RCS file: ...' (yuck!!).
- (cvs-parsed-fileinfo (if dont-change-disc 'NEED-MERGE
- (or type '(MODIFIED . MERGED))) path nil
- :merge (cons base-rev head-rev))))))
-
-(defun cvs-parse-status ()
- (let (nofile path base-rev head-rev type)
- (and
- (cvs-match
- "===================================================================$")
- (cvs-match "File: \\(no file \\)?\\(.*[^ \t]\\)[ \t]+Status: "
- (nofile 1) (path 2))
- (cvs-or
- (cvs-match "Needs \\(Checkout\\|Patch\\)$"
- (type (if nofile 'MISSING 'NEED-UPDATE)))
- (cvs-match "Up-to-date$"
- (type (if nofile '(UP-TO-DATE . REMOVED) 'UP-TO-DATE)))
- (cvs-match "File had conflicts on merge$" (type 'MODIFIED))
- (cvs-match ".*[Cc]onflict.*$" (type 'CONFLICT))
- (cvs-match "Locally Added$" (type 'ADDED))
- (cvs-match "Locally Removed$" (type 'REMOVED))
- (cvs-match "Locally Modified$" (type 'MODIFIED))
- (cvs-match "Needs Merge$" (type 'NEED-MERGE))
- (cvs-match "Entry Invalid" (type '(NEED-MERGE . REMOVED)))
- (cvs-match ".*$" (type 'UNKNOWN)))
- (cvs-match "$")
- (cvs-or
- (cvs-match " *Version:[ \t]*\\([0-9.]+\\).*$" (base-rev 1))
- ;; NOTE: there's no date on the end of the following for server mode...
- (cvs-match " *Working revision:[ \t]*-?\\([0-9.]+\\).*$" (base-rev 1))
- ;; Let's not get all worked up if the format changes a bit
- (cvs-match " *Working revision:.*$"))
- (cvs-or
- (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\)[ \t]*.*$" (head-rev 1))
- (cvs-match " *Repository revision:[ \t]*\\([0-9.]+\\)[ \t]*\\(.*\\)$"
- (head-rev 1))
- (cvs-match " *Repository revision:.*"))
- (cvs-or (cvs-match " *Expansion option:.*") t) ;Optional CVSNT thingie.
- (cvs-or (cvs-match " *Commit Identifier:.*") t) ;Optional CVSNT thingie.
- (cvs-or
- (and ;; Sometimes those fields are missing.
- (cvs-match " *Sticky Tag:[ \t]*\\(.*\\)$") ; FIXME: use it.
- (cvs-match " *Sticky Date:[ \t]*\\(.*\\)$") ; FIXME: use it.
- (cvs-match " *Sticky Options:[ \t]*\\(.*\\)$")) ; FIXME: use it.
- t)
- (cvs-or (cvs-match " *Merge From:.*") t) ;Optional CVSNT thingie.
- (cvs-match "$")
- ;; ignore the tags-listing in the case of `status -v'
- (cvs-or (cvs-match " *Existing Tags:\n\\(\t.*\n\\)*$") t)
- (cvs-parsed-fileinfo type path nil
- :base-rev base-rev
- :head-rev head-rev))))
-
-(defun cvs-parse-commit ()
- (let (path file base-rev subtype)
- (cvs-or
-
- (and
- (cvs-or
- (cvs-match "\\(Checking in\\|Removing\\) \\(.*\\);$" (path 2))
- t)
- (cvs-match ".*,v <-- \\(.*\\)$" (file 1))
- (cvs-or
- ;; deletion
- (cvs-match "new revision: delete; previous revision: \\([0-9.]*\\)$"
- (subtype 'REMOVED) (base-rev 1))
- ;; addition
- (cvs-match "initial revision: \\([0-9.]*\\)$"
- (subtype 'ADDED) (base-rev 1))
- ;; update
- (cvs-match "new revision: \\([0-9.]*\\); previous revision: .*$"
- (subtype 'COMMITTED) (base-rev 1)))
- (cvs-or (cvs-match "done$") t)
- ;; In cvs-1.12.9 commit messages have been changed and became
- ;; ambiguous. More specifically, the `path' above is not given.
- ;; We assume here that in future releases the corresponding info will
- ;; be put into `file'.
- (progn
- ;; Try to remove the temp files used by VC.
- (vc-delete-automatic-version-backups (expand-file-name (or path file)))
- ;; it's important here not to rely on the default directory management
- ;; because `cvs commit' might begin by a series of Examining messages
- ;; so the processing of the actual checkin messages might begin with
- ;; a `current-dir' set to something different from ""
- (cvs-parsed-fileinfo (cons 'UP-TO-DATE subtype)
- (or path file) 'trust
- :base-rev base-rev)))
-
- ;; useless message added before the actual addition: ignored
- (cvs-match "RCS file: .*\ndone$"))))
-
-
-(provide 'pcvs-parse)
-
-;; arch-tag: 35418375-1a23-40a0-957d-96b0262f91d6
-;;; pcvs-parse.el ends here
+++ /dev/null
-;;; pcvs-util.el --- utility functions for PCL-CVS -*- byte-compile-dynamic: t -*-
-
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: pcl-cvs
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-;;;;
-;;;; list processing
-;;;;
-
-(defsubst cvs-car (x) (if (consp x) (car x) x))
-(defalias 'cvs-cdr 'cdr-safe)
-(defsubst cvs-append (&rest xs)
- (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
-
-(defsubst cvs-every (-cvs-every-f -cvs-every-l)
- (while (consp -cvs-every-l)
- (unless (funcall -cvs-every-f (pop -cvs-every-l))
- (setq -cvs-every-l t)))
- (not -cvs-every-l))
-
-(defun cvs-union (xs ys)
- (let ((zs ys))
- (dolist (x xs zs)
- (unless (member x ys) (push x zs)))))
-
-(defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
- (let ((accum ()))
- (while (not (cvs-every 'null -cvs-map-ls))
- (push (apply -cvs-map-f (mapcar 'car -cvs-map-ls)) accum)
- (setq -cvs-map-ls (mapcar 'cdr -cvs-map-ls)))
- (nreverse accum)))
-
-(defun cvs-first (l &optional n)
- (if (null n) (car l)
- (when l
- (let* ((nl (list (pop l)))
- (ret nl))
- (while (and l (> n 1))
- (setcdr nl (list (pop l)))
- (setq nl (cdr nl))
- (decf n))
- ret))))
-
-(defun cvs-partition (p l)
- "Partition a list L into two lists based on predicate P.
-The function returns a `cons' cell where the `car' contains
-elements of L for which P is true while the `cdr' contains
-the other elements. The ordering among elements is maintained."
- (let (car cdr)
- (dolist (x l)
- (if (funcall p x) (push x car) (push x cdr)))
- (cons (nreverse car) (nreverse cdr))))
-
-;;;
-;;; frame, window, buffer handling
-;;;
-
-(defun cvs-pop-to-buffer-same-frame (buf)
- "Pop to BUF like `pop-to-buffer' but staying on the same frame.
-If `pop-to-buffer' would have opened a new frame, this function would
-try to split a new window instead."
- (let ((pop-up-windows (or pop-up-windows pop-up-frames))
- (pop-up-frames nil))
- (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf)))
- (and pop-up-windows
- (ignore-errors (select-window (split-window-vertically)))
- (switch-to-buffer buf))
- (pop-to-buffer (current-buffer)))))
-
-(defun cvs-bury-buffer (buf &optional mainbuf)
- "Hide the buffer BUF that was temporarily popped up.
-BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
- (interactive (list (current-buffer)))
- (save-current-buffer
- (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
- (get-buffer-window buf t))))
- (when win
- (if (window-dedicated-p win)
- (condition-case ()
- (delete-window win)
- (error (iconify-frame (window-frame win))))
-;;; (if (and mainbuf (get-buffer-window mainbuf))
-;;; ;; FIXME: if the buffer popped into a pre-existing window,
-;;; ;; we don't want to delete that window.
-;;; t ;;(delete-window win)
-;;; )
- )))
- (with-current-buffer buf
- (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
- (not (window-dedicated-p (selected-window))))
- buf)))
- (when mainbuf
- (let ((mainwin (or (get-buffer-window mainbuf)
- (get-buffer-window mainbuf 'visible))))
- (when mainwin (select-window mainwin))))))
-
-(defun cvs-get-buffer-create (name &optional noreuse)
- "Create a buffer NAME unless such a buffer already exists.
-If the NAME looks like an absolute file name, the buffer will be created
-with `create-file-buffer' and will probably get another name than NAME.
-In such a case, the search for another buffer with the same name doesn't
-use the buffer name but the buffer's `list-buffers-directory' variable.
-If NOREUSE is non-nil, always return a new buffer."
- (or (and (not (file-name-absolute-p name))
- (if noreuse (generate-new-buffer name)
- (get-buffer-create name)))
- (unless noreuse
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when (equal name list-buffers-directory)
- (return buf)))))
- (with-current-buffer (create-file-buffer name)
- (setq list-buffers-directory name)
- (current-buffer))))
-
-;;;;
-;;;; string processing
-;;;;
-
-(defun cvs-insert-strings (strings)
- "Insert a list of STRINGS into the current buffer.
-Uses columns to keep the listing readable but compact."
- (when (consp strings)
- (let* ((length (apply 'max (mapcar 'length strings)))
- (wwidth (1- (window-width)))
- (columns (min
- ;; At least 2 columns; at least 2 spaces between columns.
- (max 2 (/ wwidth (+ 2 length)))
- ;; Don't allocate more columns than we can fill.
- ;; Windows can't show less than 3 lines anyway.
- (max 1 (/ (length strings) 2))))
- (colwidth (/ wwidth columns)))
- ;; Use tab-width rather than indent-to.
- (setq tab-width colwidth)
- ;; The insertion should be "sensible" no matter what choices were made.
- (dolist (str strings)
- (unless (bolp)
- (insert " \t")
- (when (< wwidth (+ (max colwidth (length str)) (current-column)))
- (delete-char -2) (insert "\n")))
- (insert str)))))
-
-
-(defun cvs-file-to-string (file &optional oneline args)
- "Read the content of FILE and return it as a string.
-If ONELINE is t, only the first line (no \\n) will be returned.
-If ARGS is non-nil, the file will be executed with ARGS as its
-arguments. If ARGS is not a list, no argument will be passed."
- (condition-case nil
- (with-temp-buffer
- (if args
- (apply 'call-process
- file nil t nil (when (listp args) args))
- (insert-file-contents file))
- (goto-char (point-min))
- (buffer-substring (point)
- (if oneline (line-end-position) (point-max))))
- (file-error nil)))
-
-(defun cvs-string-prefix-p (str1 str2)
- "Tell whether STR1 is a prefix of STR2."
- (eq t (compare-strings str2 nil (length str1) str1 nil nil)))
-
-;;;;
-;;;; file names
-;;;;
-
-(defsubst cvs-expand-dir-name (d)
- (file-name-as-directory (expand-file-name d)))
-
-;;;;
-;;;; (interactive <foo>) support function
-;;;;
-
-(defstruct (cvs-qtypedesc
- (:constructor nil) (:copier nil)
- (:constructor cvs-qtypedesc-create
- (str2obj obj2str &optional complete hist-sym require)))
- str2obj
- obj2str
- hist-sym
- complete
- require)
-
-
-(defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
-(defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
-(defconst cvs-qtypedesc-strings
- (cvs-qtypedesc-create 'split-string-and-unquote
- 'combine-and-quote-strings nil))
-
-(defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
- (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
- (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
- (complete (cvs-qtypedesc-complete qtypedesc))
- (completions (and (functionp complete) (funcall complete)))
- (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
- (funcall (cvs-qtypedesc-str2obj qtypedesc)
- (cond
- ((null complete) (read-string prompt initval hist-sym))
- ((functionp complete)
- (completing-read prompt completions
- nil (cvs-qtypedesc-require qtypedesc)
- initval hist-sym))
- (t initval)))))
-
-;;;;
-;;;; Flags handling
-;;;;
-
-(defstruct (cvs-flags
- (:constructor nil)
- (:constructor -cvs-flags-make
- (desc defaults &optional qtypedesc hist-sym)))
- defaults persist desc qtypedesc hist-sym)
-
-(defmacro cvs-flags-define (sym defaults
- &optional desc qtypedesc hist-sym docstring)
- `(defconst ,sym
- (let ((bound (boundp ',sym)))
- (if (and bound (cvs-flags-p ,sym)) ,sym
- (let ((defaults ,defaults))
- (-cvs-flags-make ,desc
- (if bound (cons ,sym (cdr defaults)) defaults)
- ,qtypedesc ,hist-sym))))
- ,docstring))
-
-(defun cvs-flags-query (sym &optional desc arg)
- "Query flags based on SYM.
-Optional argument DESC will be used for the prompt.
-If ARG (or a prefix argument) is nil, just use the 0th default.
-If it is a non-negative integer, use the corresponding default.
-If it is a negative integer query for a new value of the corresponding
- default and return that new value.
-If it is \\[universal-argument], just query and return a value without
- altering the defaults.
-If it is \\[universal-argument] \\[universal-argument], behave just
- as if a negative zero was provided."
- (let* ((flags (symbol-value sym))
- (desc (or desc (cvs-flags-desc flags)))
- (qtypedesc (cvs-flags-qtypedesc flags))
- (hist-sym (cvs-flags-hist-sym flags))
- (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
- (numarg (prefix-numeric-value arg))
- (defaults (cvs-flags-defaults flags))
- (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
- ;; special case for universal-argument
- (when (consp arg)
- (setq permstr (if (> numarg 4) " (permanent)" ""))
- (setq numarg 0))
-
- ;; sanity check
- (unless (< (abs numarg) (length defaults))
- (error "There is no %sth default" (abs numarg)))
-
- (if permstr
- (let* ((prompt (format "%s%s: " desc permstr))
- (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
- prompt qtypedesc hist-sym)))
- (when (not (equal permstr ""))
- (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
- fs)
- (nth numarg defaults))))
-
-(defsubst cvs-flags-set (sym index value)
- "Set SYM's INDEX'th setting to VALUE."
- (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
-
-;;;;
-;;;; Prefix keys
-;;;;
-
-(defconst cvs-prefix-number 10)
-
-(defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
-
-(defmacro cvs-prefix-define (sym docstring desc defaults
- &optional qtypedesc hist-sym)
- (let ((cps (cvs-prefix-sym sym)))
- `(progn
- (defvar ,sym nil ,(concat (or docstring "") "
-See `cvs-prefix-set' for further description of the behavior."))
- (defvar ,cps
- (let ((defaults ,defaults))
- ;; sanity ensurance
- (unless (>= (length defaults) cvs-prefix-number)
- (setq defaults (append defaults
- (make-list (1- cvs-prefix-number)
- (nth 0 defaults)))))
- (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
-
-(defun cvs-prefix-make-local (sym)
- (let ((cps (cvs-prefix-sym sym)))
- (make-local-variable sym)
- (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
-
-(defun cvs-prefix-set (sym arg)
- ;; we could distinguish between numeric and non-numeric prefix args instead of
- ;; relying on that magic `4'.
- "Set the cvs-prefix contained in SYM.
-If ARG is between 0 and 9, it selects the corresponding default.
-If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
- it queries the user and sets the -ARG'th default.
-If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
- the (ARG mod 10)'th prefix is made persistent.
-If ARG is nil toggle the PREFIX's value between its 0th default and nil
- and reset the persistence."
- (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
- (numarg (if (integerp arg) arg 0))
- ;; (defs (cvs-flags-defaults prefix))
- )
-
- ;; set persistence if requested
- (when (> (prefix-numeric-value arg) 9)
- (setf (cvs-flags-persist prefix) t)
- (setq numarg (mod numarg 10)))
-
- ;; set the value
- (set sym
- (cond
- ((null arg)
- (setf (cvs-flags-persist prefix) nil)
- (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
-
- ((or (consp arg) (< numarg 0))
- (setf (nth (- numarg) (cvs-flags-defaults prefix))
- (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
- (format "%s: " (cvs-flags-desc prefix))
- (cvs-flags-qtypedesc prefix)
- (cvs-flags-hist-sym prefix))))
- (t (nth numarg (cvs-flags-defaults prefix)))))
- (force-mode-line-update)))
-
-(defun cvs-prefix-get (sym &optional read-only)
- "Return the current value of the prefix SYM.
-And reset it unless READ-ONLY is non-nil."
- (prog1 (symbol-value sym)
- (unless (or read-only
- (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
- (set sym nil)
- (force-mode-line-update))))
-
-(provide 'pcvs-util)
-
-;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59
-;;; pcvs-util.el ends here
+++ /dev/null
-;;; pcvs.el --- a front-end to CVS
-
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: (The PCL-CVS Trust) pcl-cvs@cyclic.com
-;; (Per Cederqvist) ceder@lysator.liu.se
-;; (Greg A. Woods) woods@weird.com
-;; (Jim Blandy) jimb@cyclic.com
-;; (Karl Fogel) kfogel@floss.red-bean.com
-;; (Jim Kingdon) kingdon@cyclic.com
-;; (Stefan Monnier) monnier@cs.yale.edu
-;; (Greg Klanderman) greg@alphatech.com
-;; (Jari Aalto+mail.emacs) jari.aalto@poboxes.com
-;; Maintainer: (Stefan Monnier) monnier@gnu.org
-;; Keywords: CVS, version control, release management
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; PCL-CVS is a front-end to the CVS version control system. For people
-;; familiar with VC, it is somewhat like VC-dired: it presents the status of
-;; all the files in your working area and allows you to commit/update several
-;; of them at a time. Compared to VC-dired, it is considerably better and
-;; faster (but only for CVS).
-
-;; PCL-CVS was originally written by Per Cederqvist many years ago. This
-;; version derives from the XEmacs-21 version, itself based on the 2.0b2
-;; version (last release from Per). It is a thorough rework.
-
-;; Contrary to what you'd expect, PCL-CVS is not a replacement for VC but only
-;; for VC-dired. As such, I've tried to make PCL-CVS and VC interoperate
-;; seamlessly (I also use VC).
-
-;; To use PCL-CVS just use `M-x cvs-examine RET <dir> RET'.
-;; There is a TeXinfo manual, which can be helpful to get started.
-
-;;; Bugs:
-
-;; - Extracting an old version seems not to recognize encoding correctly.
-;; That's probably because it's done via a process rather than a file.
-
-;;; Todo:
-
-;; ******** FIX THE DOCUMENTATION *********
-;;
-;; - rework the displaying of error messages.
-;; - allow to flush messages only
-;; - allow to protect files like ChangeLog from flushing
-;; - automatically cvs-mode-insert files from find-file-hook
-;; (and don't flush them as long as they are visited)
-;; - query the user for cvs-get-marked (for some cmds or if nothing's selected)
-;; - don't return the first (resp last) FI if the cursor is before
-;; (resp after) it.
-;; - allow cvs-confirm-removals to force always confirmation.
-;; - cvs-checkout should ask for a revision (with completion).
-;; - removal confirmation should allow specifying another file name.
-;;
-;; - hide fileinfos without getting rid of them (will require ewok work).
-;; - add toolbar entries
-;; - marking
-;; marking directories should jump to just after the dir.
-;; allow (un)marking directories at a time with the mouse.
-;; allow cvs-cmd-do to either clear the marks or not.
-;; add a "marks active" notion, like transient-mark-mode does.
-;; - liveness indicator
-;; - indicate in docstring if the cmd understands the `b' prefix(es).
-;; - call smerge-mode when opening CONFLICT files.
-;; - have vc-checkin delegate to cvs-mode-commit when applicable
-;; - higher-level CVS operations
-;; cvs-mode-rename
-;; cvs-mode-branch
-;; - module-level commands
-;; add support for parsing 'modules' file ("cvs co -c")
-;; cvs-mode-rcs2log
-;; cvs-rdiff
-;; cvs-release
-;; cvs-import
-;; C-u M-x cvs-checkout should ask for a cvsroot
-;; cvs-mode-handle-new-vendor-version
-;; - checks out module, or alternately does update join
-;; - does "cvs -n tag LAST_VENDOR" to find old files into *cvs*
-;; cvs-export
-;; (with completion on tag names and hooks to help generate full releases)
-;; - display stickiness information. And current CVS/Tag as well.
-;; - write 'cvs-mode-admin' to do arbitrary 'cvs admin' commands
-;; Most interesting would be version removal and log message replacement.
-;; The last one would be neat when called from log-view-mode.
-;; - cvs-mode-incorporate
-;; It would merge in the status from one *cvs* buffer into another.
-;; This would be used to populate such a buffer that had been created with
-;; a `cvs {update,status,checkout} -l'.
-;; - cvs-mode-(i)diff-other-{file,buffer,cvs-buffer}
-;; - offer the choice to kill the process when the user kills the cvs buffer.
-;; right now, it's killed without further ado.
-;; - make `cvs-mode-ignore' allow manually entering a pattern.
-;; to which dir should it apply ?
-;; - cvs-mode-ignore should try to remove duplicate entries.
-;; - maybe poll/check CVS/Entries files to react to external `cvs' commands ?
-;; - some kind of `cvs annotate' support ?
-;; but vc-annotate can be used instead.
-;; - proper `g' that passes safe args and uses either cvs-status or cvs-examine
-;; maybe also use cvs-update depending on I-don't-know-what.
-;; - add message-levels so that we can hide some levels of messages
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'ewoc) ;Ewoc was once cookie
-(require 'pcvs-defs)
-(require 'pcvs-util)
-(require 'pcvs-parse)
-(require 'pcvs-info)
-
-\f
-;;;;
-;;;; global vars
-;;;;
-
-(defvar cvs-cookies) ;;nil
- ;;"Handle for the cookie structure that is displayed in the *cvs* buffer.")
-;;(make-variable-buffer-local 'cvs-cookies)
-
-;;;;
-;;;; Dynamically scoped variables
-;;;;
-
-(defvar cvs-from-vc nil "Bound to t inside VC advice.")
-
-;;;;
-;;;; flags variables
-;;;;
-
-(defun cvs-defaults (&rest defs)
- (let ((defs (cvs-first defs cvs-shared-start)))
- (append defs
- (make-list (- cvs-shared-start (length defs)) (car defs))
- cvs-shared-flags)))
-
-;; For cvs flags, we need to add "-f" to override the cvsrc settings
-;; we also want to evict the annoying -q and -Q options that hide useful
-;; information from pcl-cvs.
-(cvs-flags-define cvs-cvs-flags '(("-f")))
-
-(cvs-flags-define cvs-checkout-flags (cvs-defaults '("-P")))
-(cvs-flags-define cvs-status-flags (cvs-defaults '("-v") nil))
-(cvs-flags-define cvs-log-flags (cvs-defaults nil))
-(cvs-flags-define cvs-diff-flags (cvs-defaults '("-u" "-N") '("-c" "-N") '("-u" "-b")))
-(cvs-flags-define cvs-tag-flags (cvs-defaults nil))
-(cvs-flags-define cvs-add-flags (cvs-defaults nil))
-(cvs-flags-define cvs-commit-flags (cvs-defaults nil))
-(cvs-flags-define cvs-remove-flags (cvs-defaults nil))
-;;(cvs-flags-define cvs-undo-flags (cvs-defaults nil))
-(cvs-flags-define cvs-update-flags (cvs-defaults '("-d" "-P")))
-
-(defun cvs-reread-cvsrc ()
- "Reset the default arguments to those in the `cvs-cvsrc-file'."
- (interactive)
- (condition-case nil
- (with-temp-buffer
- (insert-file-contents cvs-cvsrc-file)
- ;; fetch the values
- (dolist (cmd '("cvs" "checkout" "status" "log" "diff" "tag"
- "add" "commit" "remove" "update"))
- (goto-char (point-min))
- (when (re-search-forward
- (concat "^" cmd "\\(\\s-+\\(.*\\)\\)?$") nil t)
- (let* ((sym (intern (concat "cvs-" cmd "-flags")))
- (val (split-string-and-unquote (or (match-string 2) ""))))
- (cvs-flags-set sym 0 val))))
- ;; ensure that cvs doesn't have -q or -Q
- (cvs-flags-set 'cvs-cvs-flags 0
- (cons "-f"
- (cdr (cvs-partition
- (lambda (x) (member x '("-q" "-Q" "-f")))
- (cvs-flags-query 'cvs-cvs-flags
- nil 'noquery))))))
- (file-error nil)))
-
-;; initialize to cvsrc's default values
-(cvs-reread-cvsrc)
-
-\f
-;;;;
-;;;; Mouse bindings and mode motion
-;;;;
-
-(defvar cvs-minor-current-files)
-
-(defun cvs-menu (e)
- "Popup the CVS menu."
- (interactive "e")
- (let ((cvs-minor-current-files
- (list (ewoc-data (ewoc-locate
- cvs-cookies (posn-point (event-end e)))))))
- (popup-menu cvs-menu e)))
-
-(defvar cvs-mode-line-process nil
- "Mode-line control for displaying info on cvs process status.")
-
-
-;;;;
-;;;; Query-Type-Descriptor for Tags
-;;;;
-
-(autoload 'cvs-status-get-tags "cvs-status")
-(defun cvs-tags-list ()
- "Return a list of acceptable tags, ready for completions."
- (assert (cvs-buffer-p))
- (let ((marked (cvs-get-marked)))
- (list* '("BASE") '("HEAD")
- (when marked
- (with-temp-buffer
- (process-file cvs-program
- nil ;no input
- t ;output to current-buffer
- nil ;don't update display while running
- "status"
- "-v"
- (cvs-fileinfo->full-name (car marked)))
- (goto-char (point-min))
- (let ((tags (cvs-status-get-tags)))
- (when (listp tags) tags)))))))
-
-(defvar cvs-tag-history nil)
-(defconst cvs-qtypedesc-tag
- (cvs-qtypedesc-create 'identity 'identity 'cvs-tags-list 'cvs-tag-history))
-
-;;;;
-
-(defun cvs-mode! (&optional -cvs-mode!-fun)
- "Switch to the *cvs* buffer.
-If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer
- and with its window selected. Else, the *cvs* buffer is simply selected.
--CVS-MODE!-FUN is called interactively if applicable and else with no argument."
- (let* ((-cvs-mode!-buf (current-buffer))
- (cvsbuf (cond ((cvs-buffer-p) (current-buffer))
- ((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer)
- (t (error "can't find the *cvs* buffer"))))
- (-cvs-mode!-wrapper cvs-minor-wrap-function)
- (-cvs-mode!-cont (lambda ()
- (save-current-buffer
- (if (commandp -cvs-mode!-fun)
- (call-interactively -cvs-mode!-fun)
- (funcall -cvs-mode!-fun))))))
- (if (not -cvs-mode!-fun) (set-buffer cvsbuf)
- (let ((cvs-mode!-buf (current-buffer))
- (cvs-mode!-owin (selected-window))
- (cvs-mode!-nwin (get-buffer-window cvsbuf 'visible)))
- (unwind-protect
- (progn
- (set-buffer cvsbuf)
- (when cvs-mode!-nwin (select-window cvs-mode!-nwin))
- (if -cvs-mode!-wrapper
- (funcall -cvs-mode!-wrapper -cvs-mode!-buf -cvs-mode!-cont)
- (funcall -cvs-mode!-cont)))
- (set-buffer cvs-mode!-buf)
- (when (and cvs-mode!-nwin (eq cvs-mode!-nwin (selected-window)))
- ;; the selected window has not been changed by FUN
- (select-window cvs-mode!-owin)))))))
-
-;;;;
-;;;; Prefixes
-;;;;
-
-(defvar cvs-branches (list cvs-vendor-branch "HEAD" "HEAD"))
-(cvs-prefix-define cvs-branch-prefix
- "Current selected branch."
- "version"
- (cons cvs-vendor-branch cvs-branches)
- cvs-qtypedesc-tag)
-
-(defun cvs-set-branch-prefix (arg)
- "Set the branch prefix to take action at the next command.
-See `cvs-prefix-set' for a further the description of the behavior.
-\\[universal-argument] 1 selects the vendor branch
-and \\[universal-argument] 2 selects the HEAD."
- (interactive "P")
- (cvs-mode!)
- (cvs-prefix-set 'cvs-branch-prefix arg))
-
-(defun cvs-add-branch-prefix (flags &optional arg)
- "Add branch selection argument if the branch prefix was set.
-The argument is added (or not) to the list of FLAGS and is constructed
-by appending the branch to ARG which defaults to \"-r\"."
- (let ((branch (cvs-prefix-get 'cvs-branch-prefix)))
- ;; deactivate the secondary prefix, even if not used.
- (cvs-prefix-get 'cvs-secondary-branch-prefix)
- (if branch (cons (concat (or arg "-r") branch) flags) flags)))
-
-(cvs-prefix-define cvs-secondary-branch-prefix
- "Current secondary selected branch."
- "version"
- (cons cvs-vendor-branch cvs-branches)
- cvs-qtypedesc-tag)
-
-(defun cvs-set-secondary-branch-prefix (arg)
- "Set the branch prefix to take action at the next command.
-See `cvs-prefix-set' for a further the description of the behavior.
-\\[universal-argument] 1 selects the vendor branch
-and \\[universal-argument] 2 selects the HEAD."
- (interactive "P")
- (cvs-mode!)
- (cvs-prefix-set 'cvs-secondary-branch-prefix arg))
-
-(defun cvs-add-secondary-branch-prefix (flags &optional arg)
- "Add branch selection argument if the secondary branch prefix was set.
-The argument is added (or not) to the list of FLAGS and is constructed
-by appending the branch to ARG which defaults to \"-r\".
-Since the `cvs-secondary-branch-prefix' is only active if the primary
-prefix is active, it is important to read the secondary prefix before
-the primay since reading the primary can deactivate it."
- (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix 'read-only)
- (cvs-prefix-get 'cvs-secondary-branch-prefix))))
- (if branch (cons (concat (or arg "-r") branch) flags) flags)))
-
-;;;;
-
-(define-minor-mode cvs-minor-mode
- "This mode is used for buffers related to a main *cvs* buffer.
-All the `cvs-mode' buffer operations are simply rebound under
-the \\[cvs-mode-map] prefix."
- nil " CVS"
- :group 'pcl-cvs)
-(put 'cvs-minor-mode 'permanent-local t)
-
-
-(defvar cvs-temp-buffers nil)
-(defun cvs-temp-buffer (&optional cmd normal nosetup)
- "Create a temporary buffer to run CMD in.
-If CMD is a string, use it to lookup `cvs-buffer-name-alist' to find
-the buffer name to be used and its `major-mode'.
-
-The selected window will not be changed. The new buffer will not maintain undo
-information and will be read-only unless NORMAL is non-nil. It will be emptied
-\(unless NOSETUP is non-nil\) and its `default-directory' will be inherited
-from the current buffer."
- (let* ((cvs-buf (current-buffer))
- (info (cdr (assoc cmd cvs-buffer-name-alist)))
- (name (eval (nth 0 info)))
- (mode (nth 1 info))
- (dir default-directory)
- (buf (cond
- (name (cvs-get-buffer-create name))
- ((and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer))
- cvs-temp-buffer)
- (t
- (set (make-local-variable 'cvs-temp-buffer)
- (cvs-get-buffer-create
- (eval cvs-temp-buffer-name) 'noreuse))))))
-
- ;; handle the potential pre-existing process
- (let ((proc (get-buffer-process buf)))
- (when (and (not normal) (processp proc)
- (memq (process-status proc) '(run stop)))
- (if cmd
- ;; When CMD is specified, the buffer is normally shown to the
- ;; user, so interrupting the process is not harmful.
- ;; Use `delete-process' rather than `kill-process' otherwise
- ;; the pending output of the process will still get inserted
- ;; after we erase the buffer.
- (delete-process proc)
- (error "Can not run two cvs processes simultaneously"))))
-
- (if (not name) (kill-local-variable 'other-window-scroll-buffer)
- ;; Strangely, if no window is created, `display-buffer' ends up
- ;; doing a `switch-to-buffer' which does a `set-buffer', hence
- ;; the need for `save-excursion'.
- (unless nosetup (save-excursion (display-buffer buf)))
- ;; FIXME: this doesn't do the right thing if the user later on
- ;; does a `find-file-other-window' and `scroll-other-window'
- (set (make-local-variable 'other-window-scroll-buffer) buf))
-
- (add-to-list 'cvs-temp-buffers buf)
-
- (with-current-buffer buf
- (setq buffer-read-only nil)
- (setq default-directory dir)
- (unless nosetup
- ;; Disable undo before calling erase-buffer since it may generate
- ;; a very large and unwanted undo record.
- (buffer-disable-undo)
- (erase-buffer))
- (set (make-local-variable 'cvs-buffer) cvs-buf)
- ;;(cvs-minor-mode 1)
- (let ((lbd list-buffers-directory))
- (if (fboundp mode) (funcall mode) (fundamental-mode))
- (when lbd (setq list-buffers-directory lbd)))
- (cvs-minor-mode 1)
- ;;(set (make-local-variable 'cvs-buffer) cvs-buf)
- (if normal
- (buffer-enable-undo)
- (setq buffer-read-only t)
- (buffer-disable-undo))
- buf)))
-
-(defun cvs-mode-kill-buffers ()
- "Kill all the \"temporary\" buffers created by the *cvs* buffer."
- (interactive)
- (dolist (buf cvs-temp-buffers) (ignore-errors (kill-buffer buf))))
-
-(defun cvs-make-cvs-buffer (dir &optional new)
- "Create the *cvs* buffer for directory DIR.
-If non-nil, NEW means to create a new buffer no matter what."
- ;; the real cvs-buffer creation
- (setq dir (cvs-expand-dir-name dir))
- (let* ((buffer-name (eval cvs-buffer-name))
- (buffer
- (or (and (not new)
- (eq cvs-reuse-cvs-buffer 'current)
- (cvs-buffer-p) ;reuse the current buffer if possible
- (current-buffer))
- ;; look for another cvs buffer visiting the same directory
- (save-excursion
- (unless new
- (dolist (buffer (cons (current-buffer) (buffer-list)))
- (set-buffer buffer)
- (and (cvs-buffer-p)
- (case cvs-reuse-cvs-buffer
- (always t)
- (subdir
- (or (cvs-string-prefix-p default-directory dir)
- (cvs-string-prefix-p dir default-directory)))
- (samedir (string= default-directory dir)))
- (return buffer)))))
- ;; we really have to create a new buffer:
- ;; we temporarily bind cwd to "" to prevent
- ;; create-file-buffer from using directory info
- ;; unless it is explicitly in the cvs-buffer-name.
- (cvs-get-buffer-create buffer-name new))))
- (with-current-buffer buffer
- (or
- (and (string= dir default-directory) (cvs-buffer-p)
- ;; just a refresh
- (ignore-errors
- (cvs-cleanup-collection cvs-cookies nil nil t)
- (current-buffer)))
- ;; setup from scratch
- (progn
- (setq default-directory dir)
- (setq buffer-read-only nil)
- (erase-buffer)
- (insert "Repository : " (directory-file-name (cvs-get-cvsroot))
- "\nModule : " (cvs-get-module)
- "\nWorking dir: " (abbreviate-file-name dir)
- (if (not (file-readable-p "CVS/Tag")) "\n"
- (let ((tag (cvs-file-to-string "CVS/Tag")))
- (cond
- ((string-match "\\`T" tag)
- (concat "\nTag : " (substring tag 1)))
- ((string-match "\\`D" tag)
- (concat "\nDate : " (substring tag 1)))
- ("\n"))))
- "\n")
- (setq buffer-read-only t)
- (cvs-mode)
- (set (make-local-variable 'list-buffers-directory) buffer-name)
- ;;(set (make-local-variable 'cvs-temp-buffer) (cvs-temp-buffer))
- (let ((cookies (ewoc-create 'cvs-fileinfo-pp "\n\n" "\n" t)))
- (set (make-local-variable 'cvs-cookies) cookies)
- (add-hook 'kill-buffer-hook
- (lambda ()
- (ignore-errors (kill-buffer cvs-temp-buffer)))
- nil t)
- ;;(set-buffer buf)
- buffer))))))
-
-(defun* cvs-cmd-do (cmd dir flags fis new
- &key cvsargs noexist dont-change-disc noshow)
- (let* ((dir (file-name-as-directory
- (abbreviate-file-name (expand-file-name dir))))
- (cvsbuf (cvs-make-cvs-buffer dir new)))
- ;; Check that dir is under CVS control.
- (unless (file-directory-p dir)
- (error "%s is not a directory" dir))
- (unless (or noexist (file-directory-p (expand-file-name "CVS" dir))
- (file-expand-wildcards (expand-file-name "*/CVS" dir)))
- (error "%s does not contain CVS controlled files" dir))
-
- (set-buffer cvsbuf)
- (cvs-mode-run cmd flags fis
- :cvsargs cvsargs :dont-change-disc dont-change-disc)
-
- (if noshow cvsbuf
- (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf)))))
-;; (funcall (if (and (boundp 'pop-up-frames) pop-up-frames)
-;; 'pop-to-buffer 'switch-to-buffer)
-;; cvsbuf))))
-
-(defun cvs-run-process (args fis postprocess &optional single-dir)
- (assert (cvs-buffer-p cvs-buffer))
- (save-current-buffer
- (let ((procbuf (current-buffer))
- (cvsbuf cvs-buffer)
- (single-dir (or single-dir (eq cvs-execute-single-dir t))))
-
- (set-buffer procbuf)
- (goto-char (point-max))
- (unless (bolp) (let ((inhibit-read-only t)) (insert "\n")))
- ;; find the set of files we'll process in this round
- (let* ((dir+files+rest
- (if (or (null fis) (not single-dir))
- ;; not single-dir mode: just process the whole thing
- (list "" (mapcar 'cvs-fileinfo->full-name fis) nil)
- ;; single-dir mode: extract the same-dir-elements
- (let ((dir (cvs-fileinfo->dir (car fis))))
- ;; output the concerned dir so the parser can translate paths
- (let ((inhibit-read-only t))
- (insert "pcl-cvs: descending directory " dir "\n"))
- ;; loop to find the same-dir-elems
- (do* ((files () (cons (cvs-fileinfo->file fi) files))
- (fis fis (cdr fis))
- (fi (car fis) (car fis)))
- ((not (and fis (string= dir (cvs-fileinfo->dir fi))))
- (list dir files fis))))))
- (dir (nth 0 dir+files+rest))
- (files (nth 1 dir+files+rest))
- (rest (nth 2 dir+files+rest)))
-
- (add-hook 'kill-buffer-hook
- (lambda ()
- (let ((proc (get-buffer-process (current-buffer))))
- (when (processp proc)
- (set-process-filter proc nil)
- ;; Abort postprocessing but leave the sentinel so it
- ;; will update the list of running procs.
- (process-put proc 'cvs-postprocess nil)
- (interrupt-process proc))))
- nil t)
-
- ;; create the new process and setup the procbuffer correspondingly
- (let* ((msg (cvs-header-msg args fis))
- (args (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery)
- (if cvs-cvsroot (list "-d" cvs-cvsroot))
- args
- files))
- ;; If process-connection-type is nil and the repository
- ;; is accessed via SSH, a bad interaction between libc,
- ;; CVS and SSH can lead to garbled output.
- ;; It might be a glibc-specific problem (but it can also happens
- ;; under Mac OS X, it seems).
- ;; It seems that using a pty can help circumvent the problem,
- ;; but at the cost of screwing up when the process thinks it
- ;; can ask for user input (such as password or host-key
- ;; confirmation). A better workaround is to set CVS_RSH to
- ;; an appropriate script, or to use a later version of CVS.
- (process-connection-type nil) ; Use a pipe, not a pty.
- (process
- ;; the process will be run in the selected dir
- (let ((default-directory (cvs-expand-dir-name dir)))
- (apply 'start-file-process "cvs" procbuf cvs-program args))))
- ;; setup the process.
- (process-put process 'cvs-buffer cvs-buffer)
- (with-current-buffer cvs-buffer (cvs-update-header msg 'add))
- (process-put process 'cvs-header msg)
- (process-put
- process 'cvs-postprocess
- (if (null rest)
- ;; this is the last invocation
- postprocess
- ;; else, we have to register ourselves to be rerun on the rest
- `(cvs-run-process ',args ',rest ',postprocess ',single-dir)))
- (set-process-sentinel process 'cvs-sentinel)
- (set-process-filter process 'cvs-update-filter)
- (set-marker (process-mark process) (point-max))
- (ignore-errors (process-send-eof process)) ;close its stdin to avoid hangs
-
- ;; now finish setting up the cvs-buffer
- (set-buffer cvsbuf)
- (setq cvs-mode-line-process (symbol-name (process-status process)))
- (force-mode-line-update)))))
-
- ;; The following line is said to improve display updates on some
- ;; emacsen. It shouldn't be needed, but it does no harm.
- (sit-for 0))
-
-(defun cvs-header-msg (args fis)
- (let* ((lastarg nil)
- (args (mapcar (lambda (arg)
- (cond
- ;; filter out the largish commit message
- ((and (eq lastarg nil) (string= arg "commit"))
- (setq lastarg 'commit) arg)
- ((and (eq lastarg 'commit) (string= arg "-m"))
- (setq lastarg '-m) arg)
- ((eq lastarg '-m)
- (setq lastarg 'done) "<log message>")
- ;; filter out the largish `admin -mrev:msg' message
- ((and (eq lastarg nil) (string= arg "admin"))
- (setq lastarg 'admin) arg)
- ((and (eq lastarg 'admin)
- (string-match "\\`-m[^:]*:" arg))
- (setq lastarg 'done)
- (concat (match-string 0 arg) "<log message>"))
- ;; Keep the rest as is.
- (t arg)))
- args)))
- (concat cvs-program " "
- (combine-and-quote-strings
- (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery)
- (if cvs-cvsroot (list "-d" cvs-cvsroot))
- args
- (mapcar 'cvs-fileinfo->full-name fis))))))
-
-(defun cvs-update-header (cmd add)
- (let* ((hf (ewoc-get-hf cvs-cookies))
- (str (car hf))
- (done "")
- (tin (ewoc-nth cvs-cookies 0)))
- ;; look for the first *real* fileinfo (to determine emptyness)
- (while
- (and tin
- (memq (cvs-fileinfo->type (ewoc-data tin))
- '(MESSAGE DIRCHANGE)))
- (setq tin (ewoc-next cvs-cookies tin)))
- (if add
- (progn
- ;; Remove the default empty line, if applicable.
- (if (not (string-match "." str)) (setq str "\n"))
- (setq str (concat "-- Running " cmd " ...\n" str)))
- (if (not (string-match
- ;; FIXME: If `cmd' is large, this will bump into the
- ;; compiled-regexp size limit. We could drop the "^" anchor
- ;; and use search-forward to circumvent the problem.
- (concat "^-- Running " (regexp-quote cmd) " \\.\\.\\.\n") str))
- (error "Internal PCL-CVS error while removing message")
- (setq str (replace-match "" t t str))
- ;; Re-add the default empty line, if applicable.
- (if (not (string-match "." str)) (setq str "\n\n"))
- (setq done (concat "-- last cmd: " cmd " --\n"))))
- ;; set the new header and footer
- (ewoc-set-hf cvs-cookies
- str (concat "\n--------------------- "
- (if tin "End" "Empty")
- " ---------------------\n"
- done))))
-
-
-(defun cvs-sentinel (proc msg)
- "Sentinel for the cvs update process.
-This is responsible for parsing the output from the cvs update when
-it is finished."
- (when (memq (process-status proc) '(signal exit))
- (let ((cvs-postproc (process-get proc 'cvs-postprocess))
- (cvs-buf (process-get proc 'cvs-buffer))
- (procbuf (process-buffer proc)))
- (unless (buffer-live-p cvs-buf) (setq cvs-buf nil))
- (unless (buffer-live-p procbuf) (setq procbuf nil))
- ;; Since the buffer and mode line will show that the
- ;; process is dead, we can delete it now. Otherwise it
- ;; will stay around until M-x list-processes.
- (process-put proc 'postprocess nil)
- (delete-process proc)
- ;; Don't do anything if the main buffer doesn't exist any more.
- (when cvs-buf
- (with-current-buffer cvs-buf
- (cvs-update-header (process-get proc 'cvs-header) nil)
- (setq cvs-mode-line-process (symbol-name (process-status proc)))
- (force-mode-line-update)
- (when cvs-postproc
- (if (null procbuf)
- ;;(set-process-buffer proc nil)
- (error "cvs' process buffer was killed")
- (with-current-buffer procbuf
- ;; Do the postprocessing like parsing and such.
- (save-excursion (eval cvs-postproc)))))))
- ;; Check whether something is left.
- (when (and procbuf (not (get-buffer-process procbuf)))
- (with-current-buffer procbuf
- ;; IIRC, we enable undo again once the process is finished
- ;; for cases where the output was inserted in *vc-diff* or
- ;; in a file-like buffer. --Stef
- (buffer-enable-undo)
- (with-current-buffer (or cvs-buf (current-buffer))
- (message "CVS process has completed in %s"
- (buffer-name))))))))
-
-(defun cvs-parse-process (dcd &optional subdir old-fis)
- "Parse the output of a cvs process.
-DCD is the `dont-change-disc' flag to use when parsing that output.
-SUBDIR is the subdirectory (if any) where this command was run.
-OLD-FIS is the list of fileinfos on which the cvs command was applied and
- which should be considered up-to-date if they are missing from the output."
- (when (eq system-type 'darwin)
- ;; Fixup the ^D^H^H inserted at beginning of buffer sometimes on MacOSX
- ;; because of the call to `process-send-eof'.
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward "^\\^D\b+" nil t)
- (let ((inhibit-read-only t))
- (delete-region (match-beginning 0) (match-end 0))))))
- (let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir))
- last)
- (with-current-buffer cvs-buffer
- ;; Expand OLD-FIS to actual files.
- (let ((fis nil))
- (dolist (fi old-fis)
- (setq fis (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
- (nconc (ewoc-collect cvs-cookies 'cvs-dir-member-p
- (cvs-fileinfo->dir fi))
- fis)
- (cons fi fis))))
- (setq old-fis fis))
- ;; Drop OLD-FIS which were already up-to-date.
- (let ((fis nil))
- (dolist (fi old-fis)
- (unless (eq (cvs-fileinfo->type fi) 'UP-TO-DATE) (push fi fis)))
- (setq old-fis fis))
- ;; Add the new fileinfos to the ewoc.
- (dolist (fi fileinfos)
- (setq last (cvs-addto-collection cvs-cookies fi last))
- ;; This FI was in the output, so remove it from OLD-FIS.
- (setq old-fis (delq (ewoc-data last) old-fis)))
- ;; Process the "silent output" (i.e. absence means up-to-date).
- (dolist (fi old-fis)
- (setf (cvs-fileinfo->type fi) 'UP-TO-DATE)
- (setq last (cvs-addto-collection cvs-cookies fi last)))
- (setq fileinfos (nconc old-fis fileinfos))
- ;; Clean up the ewoc as requested by the user.
- (cvs-cleanup-collection cvs-cookies
- (eq cvs-auto-remove-handled t)
- cvs-auto-remove-directories
- nil)
- ;; Revert buffers if necessary.
- (when (and cvs-auto-revert (not dcd) (not cvs-from-vc))
- (cvs-revert-if-needed fileinfos)))))
-
-(defmacro defun-cvs-mode (fun args docstring interact &rest body)
- "Define a function to be used in a *cvs* buffer.
-This will look for a *cvs* buffer and execute BODY in it.
-Since the interactive arguments might need to be queried after
-switching to the *cvs* buffer, the generic code is rather ugly,
-but luckily we can often use simpler alternatives.
-
-FUN can be either a symbol (i.e. STYLE is nil) or a cons (FUN . STYLE).
-ARGS and DOCSTRING are the normal argument list.
-INTERACT is the interactive specification or nil for non-commands.
-
-STYLE can be either SIMPLE, NOARGS or DOUBLE. It's an error for it
-to have any other value, unless other details of the function make it
-clear what alternative to use.
-- SIMPLE will get all the interactive arguments from the original buffer.
-- NOARGS will get all the arguments from the *cvs* buffer and will
- always behave as if called interactively.
-- DOUBLE is the generic case."
- (declare (debug (&define sexp lambda-list stringp ("interactive" interactive) def-body))
- (doc-string 3))
- (let ((style (cvs-cdr fun))
- (fun (cvs-car fun)))
- (cond
- ;; a trivial interaction, no need to move it
- ((or (eq style 'SIMPLE)
- (null (nth 1 interact))
- (stringp (nth 1 interact)))
- `(defun ,fun ,args ,docstring ,interact
- (cvs-mode! (lambda () ,@body))))
-
- ;; fun is only called interactively: move all the args to the inner fun
- ((eq style 'NOARGS)
- `(defun ,fun () ,docstring (interactive)
- (cvs-mode! (lambda ,args ,interact ,@body))))
-
- ;; bad case
- ((eq style 'DOUBLE)
- (string-match ".*" docstring)
- (let ((line1 (match-string 0 docstring))
- (fun-1 (intern (concat (symbol-name fun) "-1"))))
- `(progn
- (defun ,fun-1 ,args
- ,(concat docstring "\nThis function only works within a *cvs* buffer.
-For interactive use, use `" (symbol-name fun) "' instead.")
- ,interact
- ,@body)
- (put ',fun-1 'definition-name ',fun)
- (defun ,fun ()
- ,(concat line1 "\nWrapper function that switches to a *cvs* buffer
-before calling the real function `" (symbol-name fun-1) "'.\n")
- (interactive)
- (cvs-mode! ',fun-1)))))
-
- (t (error "Unknown style %s in `defun-cvs-mode'" style)))))
-
-(defun-cvs-mode cvs-mode-kill-process ()
- "Kill the temporary buffer and associated process."
- (interactive)
- (when (and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer))
- (let ((proc (get-buffer-process cvs-temp-buffer)))
- (when proc (delete-process proc)))))
-
-;;
-;; Maintaining the collection in the face of updates
-;;
-
-(defun cvs-addto-collection (c fi &optional tin)
- "Add FI to C and return FI's corresponding tin.
-FI is inserted in its proper place or maybe even merged with a preexisting
- fileinfo if applicable.
-TIN specifies an optional starting point."
- (unless tin (setq tin (ewoc-nth c 0)))
- (while (and tin (cvs-fileinfo< fi (ewoc-data tin)))
- (setq tin (ewoc-prev c tin)))
- (if (null tin) (ewoc-enter-first c fi) ;empty collection
- (assert (not (cvs-fileinfo< fi (ewoc-data tin))))
- (let ((next-tin (ewoc-next c tin)))
- (while (not (or (null next-tin)
- (cvs-fileinfo< fi (ewoc-data next-tin))))
- (setq tin next-tin next-tin (ewoc-next c next-tin)))
- (if (or (cvs-fileinfo< (ewoc-data tin) fi)
- (eq (cvs-fileinfo->type fi) 'MESSAGE))
- ;; tin < fi < next-tin
- (ewoc-enter-after c tin fi)
- ;; fi == tin
- (cvs-fileinfo-update (ewoc-data tin) fi)
- (ewoc-invalidate c tin)
- ;; Move cursor back to where it belongs.
- (when (bolp) (cvs-move-to-goal-column))
- tin))))
-
-(defcustom cvs-cleanup-functions nil
- "Functions to tweak the cleanup process.
-The functions are called with a single argument (a FILEINFO) and should
-return a non-nil value if that fileinfo should be removed."
- :group 'pcl-cvs
- :type '(hook :options (cvs-cleanup-removed)))
-
-(defun cvs-cleanup-removed (fi)
- "Non-nil if FI has been cvs-removed but still exists.
-This is intended for use on `cvs-cleanup-functions' when you have cvs-removed
-automatically generated files (which should hence not be under CVS control)
-but can't commit the removal because the repository's owner doesn't understand
-the problem."
- (and (or (eq (cvs-fileinfo->type fi) 'REMOVED)
- (and (eq (cvs-fileinfo->type fi) 'CONFLICT)
- (eq (cvs-fileinfo->subtype fi) 'REMOVED)))
- (file-exists-p (cvs-fileinfo->full-name fi))))
-
-;; called at the following times:
-;; - postparse ((eq cvs-auto-remove-handled t) cvs-auto-remove-directories nil)
-;; - pre-run ((eq cvs-auto-remove-handled 'delayed) nil t)
-;; - remove-handled (t (or cvs-auto-remove-directories 'handled) t)
-;; - cvs-cmd-do (nil nil t)
-;; - post-ignore (nil nil nil)
-;; - acknowledge (nil nil nil)
-;; - remove (nil nil nil)
-(defun cvs-cleanup-collection (c rm-handled rm-dirs rm-msgs)
- "Remove undesired entries.
-C is the collection
-RM-HANDLED if non-nil means remove handled entries.
-RM-DIRS behaves like `cvs-auto-remove-directories'.
-RM-MSGS if non-nil means remove messages."
- (let (last-fi first-dir (rerun t))
- (while rerun
- (setq rerun nil)
- (setq first-dir t)
- (setq last-fi (cvs-create-fileinfo 'DEAD "../" "" "")) ;place-holder
- (ewoc-filter
- c (lambda (fi)
- (let* ((type (cvs-fileinfo->type fi))
- (subtype (cvs-fileinfo->subtype fi))
- (keep
- (case type
- ;; remove temp messages and keep the others
- (MESSAGE (not (or rm-msgs (eq subtype 'TEMP))))
- ;; remove entries
- (DEAD nil)
- ;; handled also?
- (UP-TO-DATE (not rm-handled))
- ;; keep the rest
- (t (not (run-hook-with-args-until-success
- 'cvs-cleanup-functions fi))))))
-
- ;; mark dirs for removal
- (when (and keep rm-dirs
- (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE)
- (not (when first-dir (setq first-dir nil) t))
- (or (eq rm-dirs 'all)
- (not (cvs-string-prefix-p
- (cvs-fileinfo->dir last-fi)
- (cvs-fileinfo->dir fi)))
- (and (eq type 'DIRCHANGE) (eq rm-dirs 'empty))
- (eq subtype 'FOOTER)))
- (setf (cvs-fileinfo->type last-fi) 'DEAD)
- (setq rerun t))
- (when keep (setq last-fi fi)))))
- ;; remove empty last dir
- (when (and rm-dirs
- (not first-dir)
- (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE))
- (setf (cvs-fileinfo->type last-fi) 'DEAD)
- (setq rerun t)))))
-
-(defun cvs-get-cvsroot ()
- "Gets the CVSROOT for DIR."
- (let ((cvs-cvsroot-file (expand-file-name "Root" "CVS")))
- (or (cvs-file-to-string cvs-cvsroot-file t)
- cvs-cvsroot
- (getenv "CVSROOT")
- "?????")))
-
-(defun cvs-get-module ()
- "Return the current CVS module.
-This usually doesn't really work but is a handy initval in a prompt."
- (let* ((repfile (expand-file-name "Repository" "CVS"))
- (rep (cvs-file-to-string repfile t)))
- (cond
- ((null rep) "")
- ((not (file-name-absolute-p rep)) rep)
- (t
- (let* ((root (cvs-get-cvsroot))
- (str (concat (file-name-as-directory (or root "/")) " || " rep)))
- (if (and root (string-match "\\(.*\\) || \\1\\(.*\\)\\'" str))
- (match-string 2 str)
- (file-name-nondirectory rep)))))))
-
-
-\f
-;;;;
-;;;; running a "cvs checkout".
-;;;;
-
-;;;###autoload
-(defun cvs-checkout (modules dir flags &optional root)
- "Run a 'cvs checkout MODULES' in DIR.
-Feed the output to a *cvs* buffer, display it in the current window,
-and run `cvs-mode' on it.
-
-With a prefix argument, prompt for cvs FLAGS to use."
- (interactive
- (let ((root (cvs-get-cvsroot)))
- (if (or (null root) current-prefix-arg)
- (setq root (read-string "CVS Root: ")))
- (list (split-string-and-unquote
- (read-string "Module(s): " (cvs-get-module)))
- (read-directory-name "CVS Checkout Directory: "
- nil default-directory nil)
- (cvs-add-branch-prefix
- (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags"))
- root)))
- (when (eq flags t)
- (setf flags (cvs-flags-query 'cvs-checkout-flags nil 'noquery)))
- (let ((cvs-cvsroot root))
- (cvs-cmd-do "checkout" (or dir default-directory)
- (append flags modules) nil 'new
- :noexist t)))
-
-(defun-cvs-mode (cvs-mode-checkout . NOARGS) (dir)
- "Run cvs checkout against the current branch.
-The files are stored to DIR."
- (interactive
- (let* ((branch (cvs-prefix-get 'cvs-branch-prefix))
- (prompt (format "CVS Checkout Directory for `%s%s': "
- (cvs-get-module)
- (if branch (format " (branch: %s)" branch)
- ""))))
- (list (read-directory-name prompt nil default-directory nil))))
- (let ((modules (split-string-and-unquote (cvs-get-module)))
- (flags (cvs-add-branch-prefix
- (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")))
- (cvs-cvsroot (cvs-get-cvsroot)))
- (cvs-checkout modules dir flags)))
-\f
-;;;;
-;;;; The code for running a "cvs update" and friends in various ways.
-;;;;
-
-(defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE)
- (&optional ignore-auto noconfirm)
- "Rerun `cvs-examine' on the current directory with the default flags."
- (interactive)
- (cvs-examine default-directory t))
-
-(defun cvs-query-directory (prompt)
- "Read directory name, prompting with PROMPT.
-If in a *cvs* buffer, don't prompt unless a prefix argument is given."
- (if (and (cvs-buffer-p)
- (not current-prefix-arg))
- default-directory
- (read-directory-name prompt nil default-directory nil)))
-
-;;;###autoload
-(defun cvs-quickdir (dir &optional flags noshow)
- "Open a *cvs* buffer on DIR without running cvs.
-With a prefix argument, prompt for a directory to use.
-A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
- prevents reuse of an existing *cvs* buffer.
-Optional argument NOSHOW if non-nil means not to display the buffer.
-FLAGS is ignored."
- (interactive (list (cvs-query-directory "CVS quickdir (directory): ")))
- ;; FIXME: code duplication with cvs-cmd-do and cvs-parse-process
- (let* ((dir (file-name-as-directory
- (abbreviate-file-name (expand-file-name dir))))
- (new (> (prefix-numeric-value current-prefix-arg) 8))
- (cvsbuf (cvs-make-cvs-buffer dir new))
- last)
- ;; Check that dir is under CVS control.
- (unless (file-directory-p dir)
- (error "%s is not a directory" dir))
- (unless (file-directory-p (expand-file-name "CVS" dir))
- (error "%s does not contain CVS controlled files" dir))
- (set-buffer cvsbuf)
- (dolist (fi (cvs-fileinfo-from-entries ""))
- (setq last (cvs-addto-collection cvs-cookies fi last)))
- (cvs-cleanup-collection cvs-cookies
- (eq cvs-auto-remove-handled t)
- cvs-auto-remove-directories
- nil)
- (if noshow cvsbuf
- (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf)))))
-
-;;;###autoload
-(defun cvs-examine (directory flags &optional noshow)
- "Run a `cvs -n update' in the specified DIRECTORY.
-That is, check what needs to be done, but don't change the disc.
-Feed the output to a *cvs* buffer and run `cvs-mode' on it.
-With a prefix argument, prompt for a directory and cvs FLAGS to use.
-A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
- prevents reuse of an existing *cvs* buffer.
-Optional argument NOSHOW if non-nil means not to display the buffer."
- (interactive (list (cvs-query-directory "CVS Examine (directory): ")
- (cvs-flags-query 'cvs-update-flags "cvs -n update flags")))
- (when (eq flags t)
- (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery)))
- (when find-file-visit-truename (setq directory (file-truename directory)))
- (cvs-cmd-do "update" directory flags nil
- (> (prefix-numeric-value current-prefix-arg) 8)
- :cvsargs '("-n")
- :noshow noshow
- :dont-change-disc t))
-
-
-;;;###autoload
-(defun cvs-update (directory flags)
- "Run a `cvs update' in the current working DIRECTORY.
-Feed the output to a *cvs* buffer and run `cvs-mode' on it.
-With a \\[universal-argument] prefix argument, prompt for a directory to use.
-A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
- prevents reuse of an existing *cvs* buffer.
-The prefix is also passed to `cvs-flags-query' to select the FLAGS
- passed to cvs."
- (interactive (list (cvs-query-directory "CVS Update (directory): ")
- (cvs-flags-query 'cvs-update-flags "cvs update flags")))
- (when (eq flags t)
- (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery)))
- (cvs-cmd-do "update" directory flags nil
- (> (prefix-numeric-value current-prefix-arg) 8)))
-
-
-;;;###autoload
-(defun cvs-status (directory flags &optional noshow)
- "Run a `cvs status' in the current working DIRECTORY.
-Feed the output to a *cvs* buffer and run `cvs-mode' on it.
-With a prefix argument, prompt for a directory and cvs FLAGS to use.
-A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
- prevents reuse of an existing *cvs* buffer.
-Optional argument NOSHOW if non-nil means not to display the buffer."
- (interactive (list (cvs-query-directory "CVS Status (directory): ")
- (cvs-flags-query 'cvs-status-flags "cvs status flags")))
- (when (eq flags t)
- (setf flags (cvs-flags-query 'cvs-status-flags nil 'noquery)))
- (cvs-cmd-do "status" directory flags nil
- (> (prefix-numeric-value current-prefix-arg) 8)
- :noshow noshow :dont-change-disc t))
-
-(defun cvs-update-filter (proc string)
- "Filter function for pcl-cvs.
-This function gets the output that CVS sends to stdout. It inserts
-the STRING into (process-buffer PROC) but it also checks if CVS is waiting
-for a lock file. If so, it inserts a message cookie in the *cvs* buffer."
- (save-match-data
- (with-current-buffer (process-buffer proc)
- (let ((inhibit-read-only t))
- (save-excursion
- ;; Insert the text, moving the process-marker.
- (goto-char (process-mark proc))
- (insert string)
- (set-marker (process-mark proc) (point))
- ;; FIXME: Delete any old lock message
- ;;(if (tin-nth cookies 1)
- ;; (tin-delete cookies
- ;; (tin-nth cookies 1)))
- ;; Check if CVS is waiting for a lock.
- (beginning-of-line 0) ;Move to beginning of last complete line.
- (when (looking-at "^[ a-z]+: \\(.*waiting for .*lock in \\(.*\\)\\)$")
- (let ((msg (match-string 1))
- (lock (match-string 2)))
- (with-current-buffer cvs-buffer
- (set (make-local-variable 'cvs-lock-file) lock)
- ;; display the lock situation in the *cvs* buffer:
- (ewoc-enter-last
- cvs-cookies
- (cvs-create-fileinfo
- 'MESSAGE "" " "
- (concat msg
- (when (file-exists-p lock)
- (substitute-command-keys
- "\n\t(type \\[cvs-mode-delete-lock] to delete it)")))
- :subtype 'TEMP))
- (pop-to-buffer (current-buffer))
- (goto-char (point-max))
- (beep)))))))))
-
-\f
-;;;;
-;;;; The cvs-mode and its associated commands.
-;;;;
-
-(cvs-prefix-define cvs-force-command "" "" '("/F") cvs-qtypedesc-string1)
-(defun-cvs-mode cvs-mode-force-command (arg)
- "Force the next cvs command to operate on all the selected files.
-By default, cvs commands only operate on files on which the command
-\"makes sense\". This overrides the safety feature on the next cvs command.
-It actually behaves as a toggle. If prefixed by \\[universal-argument] \\[universal-argument],
-the override will persist until the next toggle."
- (interactive "P")
- (cvs-prefix-set 'cvs-force-command arg))
-
-(put 'cvs-mode 'mode-class 'special)
-(define-derived-mode cvs-mode nil "CVS"
- "Mode used for PCL-CVS, a frontend to CVS.
-Full documentation is in the Texinfo file."
- (setq mode-line-process
- '("" cvs-force-command cvs-ignore-marks-modif
- ":" (cvs-branch-prefix
- ("" cvs-branch-prefix (cvs-secondary-branch-prefix
- ("->" cvs-secondary-branch-prefix))))
- " " cvs-mode-line-process))
- (if buffer-file-name
- (error "Use M-x cvs-quickdir to get a *cvs* buffer"))
- (buffer-disable-undo)
- ;;(set (make-local-variable 'goal-column) cvs-cursor-column)
- (set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer)
- (setq truncate-lines t)
- (cvs-prefix-make-local 'cvs-branch-prefix)
- (cvs-prefix-make-local 'cvs-secondary-branch-prefix)
- (cvs-prefix-make-local 'cvs-force-command)
- (cvs-prefix-make-local 'cvs-ignore-marks-modif)
- (make-local-variable 'cvs-mode-line-process)
- (make-local-variable 'cvs-temp-buffers))
-
-
-(defun cvs-buffer-p (&optional buffer)
- "Return whether the (by default current) BUFFER is a `cvs-mode' buffer."
- (save-excursion
- (if buffer (set-buffer buffer))
- (and (eq major-mode 'cvs-mode))))
-
-(defun cvs-buffer-check ()
- "Check that the current buffer follows cvs-buffer's conventions."
- (let ((buf (current-buffer))
- (check 'none))
- (or (and (setq check 'collection)
- (eq (ewoc-buffer cvs-cookies) buf)
- (setq check 'cvs-temp-buffer)
- (or (null cvs-temp-buffer)
- (null (buffer-live-p cvs-temp-buffer))
- (and (eq (with-current-buffer cvs-temp-buffer cvs-buffer) buf)
- (equal (with-current-buffer cvs-temp-buffer
- default-directory)
- default-directory)))
- t)
- (error "Inconsistent %s in buffer %s" check (buffer-name buf)))))
-
-
-(defun cvs-mode-quit ()
- "Quit PCL-CVS, killing the *cvs* buffer."
- (interactive)
- (and (y-or-n-p "Quit pcl-cvs? ") (kill-buffer (current-buffer))))
-
-;; Give help....
-
-(defun cvs-help ()
- "Display help for various PCL-CVS commands."
- (interactive)
- (if (eq last-command 'cvs-help)
- (describe-function 'cvs-mode) ; would need minor-mode for log-edit-mode
- (message "%s"
- (substitute-command-keys
- "`\\[cvs-help]':help `\\[cvs-mode-add]':add `\\[cvs-mode-commit]':commit \
-`\\[cvs-mode-diff-map]':diff* `\\[cvs-mode-log]':log \
-`\\[cvs-mode-remove]':remove `\\[cvs-mode-status]':status \
-`\\[cvs-mode-undo]':undo"))))
-
-;; Move around in the buffer
-
-(defun cvs-move-to-goal-column ()
- (let* ((eol (line-end-position))
- (fpos (next-single-property-change (point) 'cvs-goal-column nil eol)))
- (when (< fpos eol)
- (goto-char fpos))))
-
-(defun-cvs-mode cvs-mode-previous-line (arg)
- "Go to the previous line.
-If a prefix argument is given, move by that many lines."
- (interactive "p")
- (ewoc-goto-prev cvs-cookies arg)
- (cvs-move-to-goal-column))
-
-(defun-cvs-mode cvs-mode-next-line (arg)
- "Go to the next line.
-If a prefix argument is given, move by that many lines."
- (interactive "p")
- (ewoc-goto-next cvs-cookies arg)
- (cvs-move-to-goal-column))
-
-;;;;
-;;;; Mark handling
-;;;;
-
-(defun-cvs-mode cvs-mode-mark (&optional arg)
- "Mark the fileinfo on the current line.
-If the fileinfo is a directory, all the contents of that directory are
-marked instead. A directory can never be marked."
- (interactive)
- (let* ((tin (ewoc-locate cvs-cookies))
- (fi (ewoc-data tin)))
- (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
- ;; it's a directory: let's mark all files inside
- (ewoc-map
- (lambda (f dir)
- (when (cvs-dir-member-p f dir)
- (setf (cvs-fileinfo->marked f)
- (not (if (eq arg 'toggle) (cvs-fileinfo->marked f) arg)))
- t)) ;Tell cookie to redisplay this cookie.
- cvs-cookies
- (cvs-fileinfo->dir fi))
- ;; not a directory: just do the obvious
- (setf (cvs-fileinfo->marked fi)
- (not (if (eq arg 'toggle) (cvs-fileinfo->marked fi) arg)))
- (ewoc-invalidate cvs-cookies tin)
- (cvs-mode-next-line 1))))
-
-(defalias 'cvs-mouse-toggle-mark 'cvs-mode-toggle-mark)
-(defun cvs-mode-toggle-mark (e)
- "Toggle the mark of the entry at point."
- (interactive (list last-input-event))
- (save-excursion
- (posn-set-point (event-end e))
- (cvs-mode-mark 'toggle)))
-
-(defun-cvs-mode cvs-mode-unmark ()
- "Unmark the fileinfo on the current line."
- (interactive)
- (cvs-mode-mark t))
-
-(defun-cvs-mode cvs-mode-mark-all-files ()
- "Mark all files."
- (interactive)
- (ewoc-map (lambda (cookie)
- (unless (eq (cvs-fileinfo->type cookie) 'DIRCHANGE)
- (setf (cvs-fileinfo->marked cookie) t)))
- cvs-cookies))
-
-(defun-cvs-mode (cvs-mode-mark-on-state . SIMPLE) (state)
- "Mark all files in state STATE."
- (interactive
- (list
- (let ((default
- (condition-case nil
- (downcase
- (symbol-name
- (cvs-fileinfo->type
- (cvs-mode-marked nil nil :read-only t :one t :noquery t))))
- (error nil))))
- (intern
- (upcase
- (completing-read
- (concat
- "Mark files in state" (if default (concat " [" default "]")) ": ")
- (mapcar (lambda (x)
- (list (downcase (symbol-name (car x)))))
- cvs-states)
- nil t nil nil default))))))
- (ewoc-map (lambda (fi)
- (when (eq (cvs-fileinfo->type fi) state)
- (setf (cvs-fileinfo->marked fi) t)))
- cvs-cookies))
-
-(defun-cvs-mode cvs-mode-mark-matching-files (regex)
- "Mark all files matching REGEX."
- (interactive "sMark files matching: ")
- (ewoc-map (lambda (cookie)
- (when (and (not (eq (cvs-fileinfo->type cookie) 'DIRCHANGE))
- (string-match regex (cvs-fileinfo->file cookie)))
- (setf (cvs-fileinfo->marked cookie) t)))
- cvs-cookies))
-
-(defun-cvs-mode cvs-mode-unmark-all-files ()
- "Unmark all files.
-Directories are also unmarked, but that doesn't matter, since
-they should always be unmarked."
- (interactive)
- (ewoc-map (lambda (cookie)
- (setf (cvs-fileinfo->marked cookie) nil)
- t)
- cvs-cookies))
-
-(defun-cvs-mode cvs-mode-unmark-up ()
- "Unmark the file on the previous line."
- (interactive)
- (let ((tin (ewoc-goto-prev cvs-cookies 1)))
- (when tin
- (setf (cvs-fileinfo->marked (ewoc-data tin)) nil)
- (ewoc-invalidate cvs-cookies tin)))
- (cvs-move-to-goal-column))
-
-(defconst cvs-ignore-marks-alternatives
- '(("toggle-marks" . "/TM")
- ("force-marks" . "/FM")
- ("ignore-marks" . "/IM")))
-
-(cvs-prefix-define cvs-ignore-marks-modif
- "Prefix to decide whether to ignore marks or not."
- "active"
- (mapcar 'cdr cvs-ignore-marks-alternatives)
- (cvs-qtypedesc-create
- (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives)))
- (lambda (obj) (car (rassoc obj cvs-ignore-marks-alternatives)))
- (lambda () cvs-ignore-marks-alternatives)
- nil t))
-
-(defun-cvs-mode cvs-mode-toggle-marks (arg)
- "Toggle whether the next CVS command uses marks.
-See `cvs-prefix-set' for further description of the behavior.
-\\[universal-argument] 1 selects `force-marks',
-\\[universal-argument] 2 selects `ignore-marks',
-\\[universal-argument] 3 selects `toggle-marks'."
- (interactive "P")
- (cvs-prefix-set 'cvs-ignore-marks-modif arg))
-
-(defun cvs-ignore-marks-p (cmd &optional read-only)
- (let ((default (if (member cmd cvs-invert-ignore-marks)
- (not cvs-default-ignore-marks)
- cvs-default-ignore-marks))
- (modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only)))
- (cond
- ((equal modif "/IM") t)
- ((equal modif "/TM") (not default))
- ((equal modif "/FM") nil)
- (t default))))
-
-(defun cvs-mode-mark-get-modif (cmd)
- (if (cvs-ignore-marks-p cmd 'read-only) "/IM" "/FM"))
-
-(defun cvs-get-marked (&optional ignore-marks ignore-contents)
- "Return a list of all selected fileinfos.
-If there are any marked tins, and IGNORE-MARKS is nil, return them.
-Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is
-nil, return all files in it, else return just the directory.
-Otherwise return (a list containing) the file the cursor points to, or
-an empty list if it doesn't point to a file at all."
- (let ((fis nil))
- (dolist (fi (if (and (boundp 'cvs-minor-current-files)
- (consp cvs-minor-current-files))
- (mapcar
- (lambda (f)
- (if (cvs-fileinfo-p f) f
- (let ((f (file-relative-name f)))
- (if (file-directory-p f)
- (cvs-create-fileinfo
- 'DIRCHANGE (file-name-as-directory f) "." "")
- (let ((dir (file-name-directory f))
- (file (file-name-nondirectory f)))
- (cvs-create-fileinfo
- 'UNKNOWN (or dir "") file ""))))))
- cvs-minor-current-files)
- (or (and (not ignore-marks)
- (ewoc-collect cvs-cookies 'cvs-fileinfo->marked))
- (list (ewoc-data (ewoc-locate cvs-cookies))))))
-
- (if (or ignore-contents (not (eq (cvs-fileinfo->type fi) 'DIRCHANGE)))
- (push fi fis)
- ;; If a directory is selected, return members, if any.
- (setq fis
- (append (ewoc-collect
- cvs-cookies 'cvs-dir-member-p (cvs-fileinfo->dir fi))
- fis))))
- (nreverse fis)))
-
-(defun* cvs-mode-marked (filter &optional cmd
- &key read-only one file noquery)
- "Get the list of marked FIS.
-CMD is used to determine whether to use the marks or not.
-Only files for which FILTER is applicable are returned.
-If READ-ONLY is non-nil, the current toggling is left intact.
-If ONE is non-nil, marks are ignored and a single FI is returned.
-If FILE is non-nil, directory entries won't be selected."
- (unless cmd (setq cmd (symbol-name filter)))
- (let* ((fis (cvs-get-marked (or one (cvs-ignore-marks-p cmd read-only))
- (and (not file)
- (cvs-applicable-p 'DIRCHANGE filter))))
- (force (cvs-prefix-get 'cvs-force-command))
- (fis (car (cvs-partition
- (lambda (fi) (cvs-applicable-p fi (and (not force) filter)))
- fis))))
- (when (and (or (null fis) (and one (cdr fis))) (not noquery))
- (message (if (null fis)
- "`%s' is not applicable to any of the selected files."
- "`%s' is only applicable to a single file.") cmd)
- (sit-for 1)
- (setq fis (list (cvs-insert-file
- (read-file-name (format "File to %s: " cmd))))))
- (if one (car fis) fis)))
-
-(defun cvs-enabledp (filter)
- "Determine whether FILTER applies to at least one of the selected files."
- (ignore-errors (cvs-mode-marked filter nil :read-only t :noquery t)))
-
-(defun cvs-mode-files (&rest -cvs-mode-files-args)
- (cvs-mode!
- (lambda ()
- (mapcar 'cvs-fileinfo->full-name
- (apply 'cvs-mode-marked -cvs-mode-files-args)))))
-
-;;
-;; Interface between Log-Edit and PCL-CVS
-;;
-
-(defun cvs-mode-commit-setup ()
- "Run `cvs-mode-commit' with setup."
- (interactive)
- (cvs-mode-commit 'force))
-
-(defcustom cvs-mode-commit-hook nil
- "Hook run after setting up the commit buffer."
- :type 'hook
- :options '(cvs-mode-diff)
- :group 'pcl-cvs)
-
-(defun cvs-mode-commit (setup)
- "Check in all marked files, or the current file.
-The user will be asked for a log message in a buffer.
-The buffer's mode and name is determined by the \"message\" setting
- of `cvs-buffer-name-alist'.
-The POSTPROC specified there (typically `log-edit') is then called,
- passing it the SETUP argument."
- (interactive "P")
- ;; It seems that the save-excursion that happens if I use the better
- ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which
- ;; end up being rather annoying (like log-edit-mode's message being
- ;; displayed in the wrong minibuffer).
- (cvs-mode!)
- (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup))
- (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist)))
- 'log-edit)))
- (funcall setupfun 'cvs-do-commit setup
- '((log-edit-listfun . cvs-commit-filelist)
- (log-edit-diff-function . cvs-mode-diff)) buf)
- (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap)
- (run-hooks 'cvs-mode-commit-hook)))
-
-(defun cvs-commit-minor-wrap (buf f)
- (let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit")))
- (funcall f)))
-
-(defun cvs-commit-filelist ()
- (cvs-mode-files 'commit nil :read-only t :file t :noquery t))
-
-(defun cvs-do-commit (flags)
- "Do the actual commit, using the current buffer as the log message."
- (interactive (list (cvs-flags-query 'cvs-commit-flags "cvs commit flags")))
- (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
- (cvs-mode!)
- ;;(pop-to-buffer cvs-buffer)
- (cvs-mode-do "commit" (list* "-m" msg flags) 'commit)))
-
-
-;;;; Editing existing commit log messages.
-
-(defun cvs-edit-log-text-at-point ()
- (save-excursion
- (end-of-line)
- (when (re-search-backward "^revision " nil t)
- (forward-line 1)
- (if (looking-at "date:") (forward-line 1))
- (if (looking-at "branches:") (forward-line 1))
- (buffer-substring
- (point)
- (if (re-search-forward
- "^\\(-\\{28\\}\\|=\\{77\\}\\|revision [.0-9]+\\)$"
- nil t)
- (match-beginning 0)
- (point))))))
-
-(defvar cvs-edit-log-revision)
-(defvar cvs-edit-log-files) (put 'cvs-edit-log-files 'permanent-local t)
-(defun cvs-mode-edit-log (file rev &optional text)
- "Edit the log message at point.
-This is best called from a `log-view-mode' buffer."
- (interactive
- (list
- (or (cvs-mode! (lambda ()
- (car (cvs-mode-files nil nil
- :read-only t :file t :noquery t))))
- (read-string "File name: "))
- (or (cvs-mode! (lambda () (cvs-prefix-get 'cvs-branch-prefix)))
- (read-string "Revision to edit: "))
- (cvs-edit-log-text-at-point)))
- ;; It seems that the save-excursion that happens if I use the better
- ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which
- ;; end up being rather annoying (like log-edit-mode's message being
- ;; displayed in the wrong minibuffer).
- (cvs-mode!)
- (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup))
- (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist)))
- 'log-edit)))
- (with-current-buffer buf
- ;; Set the filename before, so log-edit can correctly setup its
- ;; log-edit-initial-files variable.
- (set (make-local-variable 'cvs-edit-log-files) (list file)))
- (funcall setupfun 'cvs-do-edit-log nil
- '((log-edit-listfun . cvs-edit-log-filelist)
- (log-edit-diff-function . cvs-mode-diff))
- buf)
- (when text (erase-buffer) (insert text))
- (set (make-local-variable 'cvs-edit-log-revision) rev)
- (set (make-local-variable 'cvs-minor-wrap-function)
- 'cvs-edit-log-minor-wrap)
- ;; (run-hooks 'cvs-mode-commit-hook)
- ))
-
-(defun cvs-edit-log-minor-wrap (buf f)
- (let ((cvs-branch-prefix (with-current-buffer buf cvs-edit-log-revision))
- (cvs-minor-current-files
- (with-current-buffer buf cvs-edit-log-files))
- ;; FIXME: I need to force because the fileinfos are UNKNOWN
- (cvs-force-command "/F"))
- (funcall f)))
-
-(defun cvs-edit-log-filelist ()
- (if cvs-minor-wrap-function
- (cvs-mode-files nil nil :read-only t :file t :noquery t)
- cvs-edit-log-files))
-
-(defun cvs-do-edit-log (rev)
- "Do the actual commit, using the current buffer as the log message."
- (interactive (list cvs-edit-log-revision))
- (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
- (cvs-mode!
- (lambda ()
- (cvs-mode-do "admin" (list (concat "-m" rev ":" msg)) nil)))))
-
-
-;;;;
-;;;; CVS Mode commands
-;;;;
-
-(defun-cvs-mode (cvs-mode-insert . NOARGS) (file)
- "Insert an entry for a specific file into the current listing.
-This is typically used if the file is up-to-date (or has been added
-outside of PCL-CVS) and one wants to do some operation on it."
- (interactive
- (list (read-file-name
- "File to insert: "
- ;; Can't use ignore-errors here because interactive
- ;; specs aren't byte-compiled.
- (condition-case nil
- (file-name-as-directory
- (expand-file-name
- (cvs-fileinfo->dir
- (cvs-mode-marked nil nil :read-only t :one t :noquery t))))
- (error nil)))))
- (cvs-insert-file file))
-
-(defun cvs-insert-file (file)
- "Insert FILE (and its contents if it's a dir) and return its FI."
- (let ((file (file-relative-name (directory-file-name file))) last)
- (dolist (fi (cvs-fileinfo-from-entries file))
- (setq last (cvs-addto-collection cvs-cookies fi last)))
- ;; There should have been at least one entry.
- (goto-char (ewoc-location last))
- (ewoc-data last)))
-
-(defun cvs-mark-fis-dead (fis)
- ;; Helper function, introduced because of the need for macro-expansion.
- (dolist (fi fis)
- (setf (cvs-fileinfo->type fi) 'DEAD)))
-
-(defun-cvs-mode (cvs-mode-add . SIMPLE) (flags)
- "Add marked files to the cvs repository.
-With prefix argument, prompt for cvs flags."
- (interactive (list (cvs-flags-query 'cvs-add-flags "cvs add flags")))
- (let ((fis (cvs-mode-marked 'add))
- (needdesc nil) (dirs nil))
- ;; find directories and look for fis needing a description
- (dolist (fi fis)
- (cond
- ((file-directory-p (cvs-fileinfo->full-name fi)) (push fi dirs))
- ((eq (cvs-fileinfo->type fi) 'UNKNOWN) (setq needdesc t))))
- ;; prompt for description if necessary
- (let* ((msg (if (and needdesc
- (or current-prefix-arg (not cvs-add-default-message)))
- (read-from-minibuffer "Enter description: ")
- (or cvs-add-default-message "")))
- (flags (list* "-m" msg flags))
- (postproc
- ;; setup postprocessing for the directory entries
- (when dirs
- `((cvs-run-process (list "-n" "update")
- ',dirs
- '(cvs-parse-process t))
- (cvs-mark-fis-dead ',dirs)))))
- (cvs-mode-run "add" flags fis :postproc postproc))))
-
-(defun-cvs-mode (cvs-mode-diff . DOUBLE) (flags)
- "Diff the selected files against the repository.
-This command compares the files in your working area against the
-revision which they are based upon."
- (interactive
- (list (cvs-add-branch-prefix
- (cvs-add-secondary-branch-prefix
- (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))))
- (cvs-mode-do "diff" flags 'diff
- :show t)) ;; :ignore-exit t
-
-(defun-cvs-mode (cvs-mode-diff-head . SIMPLE) (flags)
- "Diff the selected files against the head of the current branch.
-See ``cvs-mode-diff'' for more info."
- (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
- (cvs-mode-diff-1 (cons "-rHEAD" flags)))
-
-(defun-cvs-mode (cvs-mode-diff-repository . SIMPLE) (flags)
- "Diff the files for changes in the repository since last co/update/commit.
-See ``cvs-mode-diff'' for more info."
- (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
- (cvs-mode-diff-1 (cons "-rBASE" (cons "-rHEAD" flags))))
-
-(defun-cvs-mode (cvs-mode-diff-yesterday . SIMPLE) (flags)
- "Diff the selected files against yesterday's head of the current branch.
-See ``cvs-mode-diff'' for more info."
- (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
- (cvs-mode-diff-1 (cons "-Dyesterday" flags)))
-
-(defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE) (flags)
- "Diff the selected files against the head of the vendor branch.
-See ``cvs-mode-diff'' for more info."
- (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
- (cvs-mode-diff-1 (cons (concat "-r" cvs-vendor-branch) flags)))
-
-;; sadly, this is not provided by cvs, so we have to roll our own
-(defun-cvs-mode (cvs-mode-diff-backup . SIMPLE) (flags)
- "Diff the files against the backup file.
-This command can be used on files that are marked with \"Merged\"
-or \"Conflict\" in the *cvs* buffer."
- (interactive (list (cvs-flags-query 'cvs-diff-flags "diff flags")))
- (unless (listp flags) (error "flags should be a list of strings"))
- (save-some-buffers)
- (let* ((marked (cvs-get-marked (cvs-ignore-marks-p "diff")))
- (fis (car (cvs-partition 'cvs-fileinfo->backup-file marked))))
- (unless (consp fis)
- (error "No files with a backup file selected!"))
- ;; let's extract some info into the environment for `buffer-name'
- (let* ((dir (cvs-fileinfo->dir (car fis)))
- (file (cvs-fileinfo->file (car fis))))
- (set-buffer (cvs-temp-buffer "diff")))
- (message "cvs diff backup...")
- (cvs-execute-single-file-list fis 'cvs-diff-backup-extractor
- cvs-diff-program flags))
- (message "cvs diff backup... Done."))
-
-(defun cvs-diff-backup-extractor (fileinfo)
- "Return the filename and the name of the backup file as a list.
-Signal an error if there is no backup file."
- (let ((backup-file (cvs-fileinfo->backup-file fileinfo)))
- (unless backup-file
- (error "%s has no backup file" (cvs-fileinfo->full-name fileinfo)))
- (list backup-file (cvs-fileinfo->full-name fileinfo))))
-
-;;
-;; Emerge support
-;;
-(defun cvs-emerge-diff (b1 b2) (emerge-buffers b1 b2 b1))
-(defun cvs-emerge-merge (b1 b2 base out)
- (emerge-buffers-with-ancestor b1 b2 base (find-file-noselect out)))
-
-;;
-;; Ediff support
-;;
-
-(defvar ediff-after-quit-destination-buffer)
-(defvar ediff-after-quit-hook-internal)
-(defvar cvs-transient-buffers)
-(defun cvs-ediff-startup-hook ()
- (add-hook 'ediff-after-quit-hook-internal
- `(lambda ()
- (cvs-ediff-exit-hook
- ',ediff-after-quit-destination-buffer ',cvs-transient-buffers))
- nil 'local))
-
-(defun cvs-ediff-exit-hook (cvs-buf tmp-bufs)
- ;; kill the temp buffers (and their associated windows)
- (dolist (tb tmp-bufs)
- (when (and tb (buffer-live-p tb) (not (buffer-modified-p tb)))
- (let ((win (get-buffer-window tb t)))
- (kill-buffer tb)
- (when (window-live-p win) (ignore-errors (delete-window win))))))
- ;; switch back to the *cvs* buffer
- (when (and cvs-buf (buffer-live-p cvs-buf)
- (not (get-buffer-window cvs-buf t)))
- (ignore-errors (switch-to-buffer cvs-buf))))
-
-(defun cvs-ediff-diff (b1 b2)
- (let ((ediff-after-quit-destination-buffer (current-buffer))
- (startup-hook '(cvs-ediff-startup-hook)))
- (ediff-buffers b1 b2 startup-hook 'ediff-revision)))
-
-(defun cvs-ediff-merge (b1 b2 base out)
- (let ((ediff-after-quit-destination-buffer (current-buffer))
- (startup-hook '(cvs-ediff-startup-hook)))
- (ediff-merge-buffers-with-ancestor
- b1 b2 base startup-hook
- 'ediff-merge-revisions-with-ancestor
- out)))
-
-;;
-;; Interactive merge/diff support.
-;;
-
-(defun cvs-retrieve-revision (fileinfo rev)
- "Retrieve the given REVision of the file in FILEINFO into a new buffer."
- (let* ((file (cvs-fileinfo->full-name fileinfo))
- (buffile (concat file "." rev)))
- (or (find-buffer-visiting buffile)
- (with-current-buffer (create-file-buffer buffile)
- (message "Retrieving revision %s..." rev)
- ;; Discard stderr output to work around the CVS+SSH+libc
- ;; problem when stdout and stderr are the same.
- (let ((res
- (let ((coding-system-for-read 'binary))
- (apply 'process-file cvs-program nil '(t nil) nil
- "-q" "update" "-p"
- ;; If `rev' is HEAD, don't pass it at all:
- ;; the default behavior is to get the head
- ;; of the current branch whereas "-r HEAD"
- ;; stupidly gives you the head of the trunk.
- (append (unless (equal rev "HEAD") (list "-r" rev))
- (list file))))))
- (when (and res (not (and (equal 0 res))))
- (error "Something went wrong retrieving revision %s: %s" rev res))
- ;; Figure out the encoding used and decode the byte-sequence
- ;; into a sequence of chars.
- (decode-coding-inserted-region
- (point-min) (point-max) file t nil nil t)
- ;; Set buffer-file-coding-system.
- (after-insert-file-set-coding (buffer-size) t)
- (set-buffer-modified-p nil)
- (let ((buffer-file-name (expand-file-name file)))
- (after-find-file))
- (toggle-read-only 1)
- (message "Retrieving revision %s... Done" rev)
- (current-buffer))))))
-
-;; FIXME: The user should be able to specify ancestor/head/backup and we should
-;; provide sensible defaults when merge info is unavailable (rather than rely
-;; on smerge-ediff). Also provide sane defaults for need-merge files.
-(defun-cvs-mode cvs-mode-imerge ()
- "Merge interactively appropriate revisions of the selected file."
- (interactive)
- (let ((fi (cvs-mode-marked 'merge nil :one t :file t)))
- (let ((merge (cvs-fileinfo->merge fi))
- (file (cvs-fileinfo->full-name fi))
- (backup-file (cvs-fileinfo->backup-file fi)))
- (if (not (and merge backup-file))
- (let ((buf (find-file-noselect file)))
- (message "Missing merge info or backup file, using VC.")
- (with-current-buffer buf
- (smerge-ediff)))
- (let* ((ancestor-buf (cvs-retrieve-revision fi (car merge)))
- (head-buf (cvs-retrieve-revision fi (cdr merge)))
- (backup-buf (let ((auto-mode-alist nil))
- (find-file-noselect backup-file)))
- ;; this binding is used by cvs-ediff-startup-hook
- (cvs-transient-buffers (list ancestor-buf backup-buf head-buf)))
- (with-current-buffer backup-buf
- (let ((buffer-file-name (expand-file-name file)))
- (after-find-file)))
- (funcall (cdr cvs-idiff-imerge-handlers)
- backup-buf head-buf ancestor-buf file))))))
-
-(cvs-flags-define cvs-idiff-version
- (list "BASE" cvs-vendor-branch cvs-vendor-branch "BASE" "BASE")
- "version: " cvs-qtypedesc-tag)
-
-(defun-cvs-mode (cvs-mode-idiff . NOARGS) (&optional rev1 rev2)
- "Diff interactively current file to revisions."
- (interactive
- (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix))
- (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix))))
- (list (or rev1 (cvs-flags-query 'cvs-idiff-version))
- rev2)))
- (let ((fi (cvs-mode-marked 'diff "idiff" :one t :file t)))
- (let* ((file (cvs-fileinfo->full-name fi))
- (rev1-buf (cvs-retrieve-revision fi (or rev1 "BASE")))
- (rev2-buf (if rev2 (cvs-retrieve-revision fi rev2)))
- ;; this binding is used by cvs-ediff-startup-hook
- (cvs-transient-buffers (list rev1-buf rev2-buf)))
- (funcall (car cvs-idiff-imerge-handlers)
- rev1-buf (or rev2-buf (find-file-noselect file))))))
-
-(defun-cvs-mode (cvs-mode-idiff-other . NOARGS) ()
- "Diff interactively current file to revisions."
- (interactive)
- (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix))
- (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix)))
- (fis (cvs-mode-marked 'diff "idiff" :file t)))
- (when (> (length fis) 2)
- (error "idiff-other cannot be applied to more than 2 files at a time"))
- (let* ((fi1 (car fis))
- (rev1-buf (if rev1 (cvs-retrieve-revision fi1 rev1)
- (find-file-noselect (cvs-fileinfo->full-name fi1))))
- rev2-buf)
- (if (cdr fis)
- (let ((fi2 (nth 1 fis)))
- (setq rev2-buf
- (if rev2 (cvs-retrieve-revision fi2 rev2)
- (find-file-noselect (cvs-fileinfo->full-name fi2)))))
- (error "idiff-other doesn't know what other file/buffer to use"))
- (let* (;; this binding is used by cvs-ediff-startup-hook
- (cvs-transient-buffers (list rev1-buf rev2-buf)))
- (funcall (car cvs-idiff-imerge-handlers)
- rev1-buf rev2-buf)))))
-
-
-(defun cvs-is-within-p (fis dir)
- "Non-nil if buffer is inside one of FIS (in DIR)."
- (when (stringp buffer-file-name)
- (setq buffer-file-name (expand-file-name buffer-file-name))
- (let (ret)
- (dolist (fi (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." ""))))
- (when (cvs-string-prefix-p
- (expand-file-name (cvs-fileinfo->full-name fi) dir)
- buffer-file-name)
- (setq ret t)))
- ret)))
-
-(defun* cvs-mode-run (cmd flags fis
- &key (buf (cvs-temp-buffer))
- dont-change-disc cvsargs postproc)
- "Generic cvs-mode-<foo> function.
-Executes `cvs CVSARGS CMD FLAGS FIS'.
-BUF is the buffer to be used for cvs' output.
-DONT-CHANGE-DISC non-nil indicates that the command will not change the
- contents of files. This is only used by the parser.
-POSTPROC is a list of expressions to be evaluated at the very end (after
- parsing if applicable). It will be prepended with `progn' if necessary."
- (let ((def-dir default-directory))
- ;; Save the relevant buffers
- (save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir))))
- (unless (listp flags) (error "flags should be a list of strings"))
- ;; Some w32 versions of CVS don't like an explicit . too much.
- (when (and (car fis) (null (cdr fis))
- (eq (cvs-fileinfo->type (car fis)) 'DIRCHANGE)
- ;; (equal (cvs-fileinfo->file (car fis)) ".")
- (equal (cvs-fileinfo->dir (car fis)) ""))
- (setq fis nil))
- (let* ((single-dir (or (not (listp cvs-execute-single-dir))
- (member cmd cvs-execute-single-dir)))
- (parse (member cmd cvs-parse-known-commands))
- (args (append cvsargs (list cmd) flags))
- (after-mode (nth 2 (cdr (assoc cmd cvs-buffer-name-alist)))))
- (cvs-cleanup-collection cvs-cookies ;cleanup remaining messages
- (eq cvs-auto-remove-handled 'delayed) nil t)
- (when (fboundp after-mode)
- (setq postproc (append postproc `((,after-mode)))))
- (when parse
- (let ((old-fis
- (when (member cmd '("status" "update")) ;FIXME: Yuck!!
- ;; absence of `cvs update' output has a specific meaning.
- (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." ""))))))
- (push `(cvs-parse-process ',dont-change-disc nil ',old-fis) postproc)))
- (setq postproc (if (cdr postproc) (cons 'progn postproc) (car postproc)))
- (with-current-buffer buf
- (let ((inhibit-read-only t)) (erase-buffer))
- (message "Running cvs %s ..." cmd)
- (cvs-run-process args fis postproc single-dir))))
-
-
-(defun* cvs-mode-do (cmd flags filter
- &key show dont-change-disc cvsargs postproc)
- "Generic cvs-mode-<foo> function.
-Executes `cvs CVSARGS CMD FLAGS' on the selected files.
-FILTER is passed to `cvs-applicable-p' to only apply the command to
- files for which it makes sense.
-SHOW indicates that CMD should be not be run in the default temp buffer and
- should be shown to the user. The buffer and mode to be used is determined
- by `cvs-buffer-name-alist'.
-DONT-CHANGE-DISC non-nil indicates that the command will not change the
- contents of files. This is only used by the parser."
- (cvs-mode-run cmd flags (cvs-mode-marked filter cmd)
- :buf (cvs-temp-buffer (when show cmd))
- :dont-change-disc dont-change-disc
- :cvsargs cvsargs
- :postproc postproc))
-
-(defun-cvs-mode (cvs-mode-status . SIMPLE) (flags)
- "Show cvs status for all marked files.
-With prefix argument, prompt for cvs flags."
- (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags")))
- (cvs-mode-do "status" flags nil :dont-change-disc t :show t
- :postproc (when (eq cvs-auto-remove-handled 'status)
- `((with-current-buffer ,(current-buffer)
- (cvs-mode-remove-handled))))))
-
-(defun-cvs-mode (cvs-mode-tree . SIMPLE) (flags)
- "Call cvstree using the file under the point as a keyfile."
- (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags")))
- (cvs-mode-run "status" (cons "-v" flags) (cvs-mode-marked nil "status")
- :buf (cvs-temp-buffer "tree")
- :dont-change-disc t
- :postproc '((cvs-status-cvstrees))))
-
-;; cvs log
-
-(defun-cvs-mode (cvs-mode-log . NOARGS) (flags)
- "Display the cvs log of all selected files.
-With prefix argument, prompt for cvs flags."
- (interactive (list (cvs-add-branch-prefix
- (cvs-flags-query 'cvs-log-flags "cvs log flags"))))
- (cvs-mode-do "log" flags nil :show t))
-
-
-(defun-cvs-mode (cvs-mode-update . NOARGS) (flags)
- "Update all marked files.
-With a prefix argument, prompt for cvs flags."
- (interactive
- (list (cvs-add-branch-prefix
- (cvs-add-secondary-branch-prefix
- (cvs-flags-query 'cvs-update-flags "cvs update flags")
- "-j") "-j")))
- (cvs-mode-do "update" flags 'update))
-
-
-(defun-cvs-mode (cvs-mode-examine . NOARGS) (flags)
- "Re-examine all marked files.
-With a prefix argument, prompt for cvs flags."
- (interactive
- (list (cvs-add-branch-prefix
- (cvs-add-secondary-branch-prefix
- (cvs-flags-query 'cvs-update-flags "cvs -n update flags")
- "-j") "-j")))
- (cvs-mode-do "update" flags nil :cvsargs '("-n") :dont-change-disc t))
-
-
-(defun-cvs-mode cvs-mode-ignore (&optional pattern)
- "Arrange so that CVS ignores the selected files.
-This command ignores files that are not flagged as `Unknown'."
- (interactive)
- (dolist (fi (cvs-mode-marked 'ignore))
- (cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi)
- (eq (cvs-fileinfo->subtype fi) 'NEW-DIR))
- (setf (cvs-fileinfo->type fi) 'DEAD))
- (cvs-cleanup-collection cvs-cookies nil nil nil))
-
-(declare-function vc-editable-p "vc" (file))
-(declare-function vc-checkout "vc" (file &optional writable rev))
-
-(defun cvs-append-to-ignore (dir str &optional old-dir)
- "Add STR to the .cvsignore file in DIR.
-If OLD-DIR is non-nil, then this is a directory that we don't want
-to hear about anymore."
- (with-current-buffer
- (find-file-noselect (expand-file-name ".cvsignore" dir))
- (when (ignore-errors
- (and buffer-read-only
- (eq 'CVS (vc-backend buffer-file-name))
- (not (vc-editable-p buffer-file-name))))
- ;; CVSREAD=on special case
- (vc-checkout buffer-file-name t))
- (goto-char (point-max))
- (unless (bolp) (insert "\n"))
- (insert str (if old-dir "/\n" "\n"))
- (if cvs-sort-ignore-file (sort-lines nil (point-min) (point-max)))
- (save-buffer)))
-
-
-(defun cvs-mode-find-file-other-window (e)
- "Select a buffer containing the file in another window."
- (interactive (list last-input-event))
- (cvs-mode-find-file e t))
-
-
-(defun cvs-mode-display-file (e)
- "Show a buffer containing the file in another window."
- (interactive (list last-input-event))
- (cvs-mode-find-file e 'dont-select))
-
-
-(defun cvs-mode-view-file (e)
- "View the file."
- (interactive (list last-input-event))
- (cvs-mode-find-file e nil t))
-
-
-(defun cvs-mode-view-file-other-window (e)
- "View the file."
- (interactive (list last-input-event))
- (cvs-mode-find-file e t t))
-
-
-(defun cvs-find-modif (fi)
- (with-temp-buffer
- (process-file cvs-program nil (current-buffer) nil
- "-f" "diff" (cvs-fileinfo->file fi))
- (goto-char (point-min))
- (if (re-search-forward "^\\([0-9]+\\)" nil t)
- (string-to-number (match-string 1))
- 1)))
-
-
-(defun cvs-mode-find-file (e &optional other view)
- "Select a buffer containing the file.
-With a prefix, opens the buffer in an OTHER window."
- (interactive (list last-input-event current-prefix-arg))
- ;; If the event moves point, check that it moves it to a valid location.
- (when (and (/= (point) (progn (posn-set-point (event-end e)) (point)))
- (not (memq (get-text-property (1- (line-end-position))
- 'font-lock-face)
- '(cvs-header cvs-filename))))
- (error "Not a file name"))
- (cvs-mode!
- (lambda (&optional rev)
- (interactive (list (cvs-prefix-get 'cvs-branch-prefix)))
- (let* ((cvs-buf (current-buffer))
- (fi (cvs-mode-marked nil nil :one t)))
- (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
- (let ((odir default-directory))
- (setq default-directory
- (cvs-expand-dir-name (cvs-fileinfo->dir fi)))
- (cond ((eq other 'dont-select)
- (display-buffer (find-file-noselect default-directory)))
- (other (dired-other-window default-directory))
- (t (dired default-directory)))
- (set-buffer cvs-buf)
- (setq default-directory odir))
- (let ((buf (if rev (cvs-retrieve-revision fi rev)
- (find-file-noselect (cvs-fileinfo->full-name fi)))))
- (funcall (cond ((eq other 'dont-select) 'display-buffer)
- (other
- (if view 'view-buffer-other-window
- 'switch-to-buffer-other-window))
- (t (if view 'view-buffer 'switch-to-buffer)))
- buf)
- (when (and cvs-find-file-and-jump (cvs-applicable-p fi 'diff-base))
- (save-restriction
- (widen)
- (goto-char (point-min))
- (forward-line (1- (cvs-find-modif fi)))))
- buf))))))
-
-
-(defun-cvs-mode (cvs-mode-undo . SIMPLE) (flags)
- "Undo local changes to all marked files.
-The file is removed and `cvs update FILE' is run."
- ;;"With prefix argument, prompt for cvs FLAGS."
- (interactive (list nil));; (cvs-flags-query 'cvs-undo-flags "undo flags")
- (if current-prefix-arg (call-interactively 'cvs-mode-revert-to-rev)
- (let* ((fis (cvs-do-removal 'undo "update" 'all))
- (removedp (lambda (fi)
- (or (eq (cvs-fileinfo->type fi) 'REMOVED)
- (and (eq (cvs-fileinfo->type fi) 'CONFLICT)
- (eq (cvs-fileinfo->subtype fi) 'REMOVED)))))
- (fis-split (cvs-partition removedp fis))
- (fis-removed (car fis-split))
- (fis-other (cdr fis-split)))
- (if (null fis-other)
- (when fis-removed (cvs-mode-run "add" nil fis-removed))
- (cvs-mode-run "update" flags fis-other
- :postproc
- (when fis-removed
- `((with-current-buffer ,(current-buffer)
- (cvs-mode-run "add" nil ',fis-removed)))))))))
-
-
-(defun-cvs-mode (cvs-mode-revert-to-rev . NOARGS) (rev)
- "Revert the selected files to an old revision."
- (interactive
- (list (or (cvs-prefix-get 'cvs-branch-prefix)
- (let ((current-prefix-arg '(4)))
- (cvs-flags-query 'cvs-idiff-version)))))
- (let* ((fis (cvs-mode-marked 'revert "revert" :file t))
- (tag (concat "tmp_pcl_tag_" (make-temp-name "")))
- (untag `((with-current-buffer ,(current-buffer)
- (cvs-mode-run "tag" (list "-d" ',tag) ',fis))))
- (update `((with-current-buffer ,(current-buffer)
- (cvs-mode-run "update" (list "-j" ',tag "-j" ',rev) ',fis
- :postproc ',untag)))))
- (cvs-mode-run "tag" (list tag) fis :postproc update)))
-
-
-(defun-cvs-mode cvs-mode-delete-lock ()
- "Delete the lock file that CVS is waiting for.
-Note that this can be dangerous. You should only do this
-if you are convinced that the process that created the lock is dead."
- (interactive)
- (let* ((default-directory (cvs-expand-dir-name cvs-lock-file))
- (locks (directory-files default-directory nil cvs-lock-file-regexp)))
- (cond
- ((not locks) (error "No lock files found"))
- ((yes-or-no-p (concat "Really delete locks in " cvs-lock-file "? "))
- (dolist (lock locks)
- (cond ((file-directory-p lock) (delete-directory lock))
- ((file-exists-p lock) (delete-file lock))))))))
-
-
-(defun-cvs-mode cvs-mode-remove-handled ()
- "Remove all lines that are handled.
-Empty directories are removed."
- (interactive)
- (cvs-cleanup-collection cvs-cookies
- t (or cvs-auto-remove-directories 'handled) t))
-
-
-(defun-cvs-mode cvs-mode-acknowledge ()
- "Remove all marked files from the buffer."
- (interactive)
- (dolist (fi (cvs-get-marked (cvs-ignore-marks-p "acknowledge") t))
- (setf (cvs-fileinfo->type fi) 'DEAD))
- (cvs-cleanup-collection cvs-cookies nil nil nil))
-
-(defun cvs-do-removal (filter &optional cmd all)
- "Remove files.
-Returns a list of FIS that should be `cvs remove'd."
- (let* ((files (cvs-mode-marked filter cmd :file t :read-only t))
- (fis (cdr (cvs-partition (lambda (fi)
- (eq (cvs-fileinfo->type fi) 'UNKNOWN))
- (cvs-mode-marked filter cmd))))
- (silent (or (not cvs-confirm-removals)
- (cvs-every (lambda (fi)
- (or (not (file-exists-p
- (cvs-fileinfo->full-name fi)))
- (cvs-applicable-p fi 'safe-rm)))
- files)))
- (tmpbuf (cvs-temp-buffer)))
- (when (and (not silent) (equal cvs-confirm-removals 'list))
- (with-current-buffer tmpbuf
- (let ((inhibit-read-only t))
- (cvs-insert-strings (mapcar 'cvs-fileinfo->full-name fis))
- (cvs-pop-to-buffer-same-frame (current-buffer))
- (shrink-window-if-larger-than-buffer))))
- (if (not (or silent
- (unwind-protect
- (yes-or-no-p
- (let ((nfiles (length files))
- (verb (if (eq filter 'undo) "Undo" "Delete")))
- (if (= 1 nfiles)
- (format "%s file: \"%s\" ? "
- verb
- (cvs-fileinfo->file (car files)))
- (format "%s %d files? "
- verb
- nfiles))))
- (cvs-bury-buffer tmpbuf cvs-buffer))))
- (progn (message "Aborting") nil)
- (dolist (fi files)
- (let* ((type (cvs-fileinfo->type fi))
- (file (cvs-fileinfo->full-name fi)))
- (when (or all (eq type 'UNKNOWN))
- (when (file-exists-p file) (delete-file file))
- (unless all (setf (cvs-fileinfo->type fi) 'DEAD) t))))
- fis)))
-
-(defun-cvs-mode (cvs-mode-remove . SIMPLE) (flags)
- "Remove all marked files.
-With prefix argument, prompt for cvs flags."
- (interactive (list (cvs-flags-query 'cvs-remove-flags "cvs remove flags")))
- (let ((fis (cvs-do-removal 'remove)))
- (if fis (cvs-mode-run "remove" (cons "-f" flags) fis)
- (cvs-cleanup-collection cvs-cookies nil nil nil))))
-
-
-(defvar cvs-tag-name "")
-(defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags)
- "Run `cvs tag TAG' on all selected files.
-With prefix argument, prompt for cvs flags.
-By default this can only be used on directories.
-Use \\[cvs-mode-force-command] or change `cvs-force-dir-tag' if you need
-to use it on individual files."
- (interactive
- (list (setq cvs-tag-name
- (cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag))
- (cvs-flags-query 'cvs-tag-flags "tag flags")))
- (cvs-mode-do "tag" (append flags (list tag))
- (when cvs-force-dir-tag 'tag)))
-
-(defun-cvs-mode (cvs-mode-untag . SIMPLE) (tag &optional flags)
- "Run `cvs tag -d TAG' on all selected files.
-With prefix argument, prompt for cvs flags."
- (interactive
- (list (setq cvs-tag-name
- (cvs-query-read cvs-tag-name "Tag to delete: " cvs-qtypedesc-tag))
- (cvs-flags-query 'cvs-tag-flags "tag flags")))
- (cvs-mode-do "tag" (append '("-d") flags (list tag))
- (when cvs-force-dir-tag 'tag)))
-
-
-;; Byte compile files.
-
-(defun-cvs-mode cvs-mode-byte-compile-files ()
- "Run byte-compile-file on all selected files that end in '.el'."
- (interactive)
- (let ((marked (cvs-get-marked (cvs-ignore-marks-p "byte-compile"))))
- (dolist (fi marked)
- (let ((filename (cvs-fileinfo->full-name fi)))
- (when (string-match "\\.el\\'" filename)
- (byte-compile-file filename))))))
-
-;; ChangeLog support.
-
-(defun-cvs-mode cvs-mode-add-change-log-entry-other-window ()
- "Add a ChangeLog entry in the ChangeLog of the current directory."
- (interactive)
- ;; Require `add-log' explicitly, because if it gets autoloaded when we call
- ;; add-change-log-entry-other-window below, the
- ;; add-log-buffer-file-name-function ends up unbound when we leave the `let'.
- (require 'add-log)
- (dolist (fi (cvs-mode-marked nil nil))
- (let* ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi)))
- (add-log-buffer-file-name-function
- (lambda ()
- (let ((file (expand-file-name (cvs-fileinfo->file fi))))
- (if (file-directory-p file)
- ;; Be careful to use a directory name, otherwise add-log
- ;; starts looking for a ChangeLog file in the
- ;; parent dir.
- (file-name-as-directory file)
- file)))))
- (kill-local-variable 'change-log-default-name)
- (save-excursion (add-change-log-entry-other-window)))))
-
-;; interactive commands to set optional flags
-
-(defun cvs-mode-set-flags (flag)
- "Ask for new setting of cvs-FLAG-flags."
- (interactive
- (list (completing-read
- "Which flag: "
- '("cvs" "diff" "update" "status" "log" "tag" ;"rtag"
- "commit" "remove" "undo" "checkout")
- nil t)))
- (let* ((sym (intern (concat "cvs-" flag "-flags"))))
- (let ((current-prefix-arg '(16)))
- (cvs-flags-query sym (concat flag " flags")))))
-
-\f
-;;;;
-;;;; Utilities for the *cvs* buffer
-;;;;
-
-(defun cvs-dir-member-p (fileinfo dir)
- "Return true if FILEINFO represents a file in directory DIR."
- (and (not (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE))
- (cvs-string-prefix-p dir (cvs-fileinfo->dir fileinfo))))
-
-(defun cvs-execute-single-file (fi extractor program constant-args)
- "Internal function for `cvs-execute-single-file-list'."
- (let* ((arg-list (funcall extractor fi))
- (inhibit-read-only t))
-
- ;; Execute the command unless extractor returned t.
- (when (listp arg-list)
- (let* ((args (append constant-args arg-list)))
-
- (insert (format "=== %s %s\n\n"
- program (split-string-and-unquote args)))
-
- ;; FIXME: return the exit status?
- (apply 'process-file program nil t t args)
- (goto-char (point-max))))))
-
-;; FIXME: make this run in the background ala cvs-run-process...
-(defun cvs-execute-single-file-list (fis extractor program constant-args)
- "Run PROGRAM on all elements on FIS.
-CONSTANT-ARGS is a list of strings to pass as arguments to PROGRAM.
-The arguments given to the program will be CONSTANT-ARGS followed by
-the list that EXTRACTOR returns.
-
-EXTRACTOR will be called once for each file on FIS. It is given
-one argument, the cvs-fileinfo. It can return t, which means ignore
-this file, or a list of arguments to send to the program."
- (dolist (fi fis)
- (cvs-execute-single-file fi extractor program constant-args)))
-
-\f
-(defun cvs-revert-if-needed (fis)
- (dolist (fileinfo fis)
- (let* ((file (cvs-fileinfo->full-name fileinfo))
- (buffer (find-buffer-visiting file)))
- ;; For a revert to happen the user must be editing the file...
- (unless (or (null buffer)
- (memq (cvs-fileinfo->type fileinfo) '(MESSAGE UNKNOWN))
- ;; FIXME: check whether revert is really needed.
- ;; `(verify-visited-file-modtime buffer)' doesn't cut it
- ;; because it only looks at the time stamp (it ignores
- ;; read-write changes) which is not changed by `commit'.
- (buffer-modified-p buffer))
- (with-current-buffer buffer
- (ignore-errors
- (revert-buffer 'ignore-auto 'dont-ask 'preserve-modes)
- ;; `preserve-modes' avoids changing the (minor) modes. But we
- ;; do want to reset the mode for VC, so we do it explicitly.
- (vc-find-file-hook)
- (when (eq (cvs-fileinfo->type fileinfo) 'CONFLICT)
- (smerge-start-session))))))))
-
-\f
-(defun cvs-change-cvsroot (newroot)
- "Change the cvsroot."
- (interactive "DNew repository: ")
- (if (or (file-directory-p (expand-file-name "CVSROOT" newroot))
- (y-or-n-p (concat "Warning: no CVSROOT found inside repository."
- " Change cvs-cvsroot anyhow? ")))
- (setq cvs-cvsroot newroot)))
-
-;;;;
-;;;; useful global settings
-;;;;
-
-;;
-;; Hook to allow calling PCL-CVS by visiting the /CVS subdirectory
-;;
-
-;;;###autoload
-(defcustom cvs-dired-action 'cvs-quickdir
- "The action to be performed when opening a CVS directory.
-Sensible values are `cvs-examine', `cvs-status' and `cvs-quickdir'."
- :group 'pcl-cvs
- :type '(choice (const cvs-examine) (const cvs-status) (const cvs-quickdir)))
-
-;;;###autoload
-(defcustom cvs-dired-use-hook '(4)
- "Whether or not opening a CVS directory should run PCL-CVS.
-A value of nil means never do it.
-ALWAYS means to always do it unless a prefix argument is given to the
- command that prompted the opening of the directory.
-Anything else means to do it only if the prefix arg is equal to this value."
- :group 'pcl-cvs
- :type '(choice (const :tag "Never" nil)
- (const :tag "Always" always)
- (const :tag "Prefix" (4))))
-
-;;;###autoload
-(progn (defun cvs-dired-noselect (dir)
- "Run `cvs-examine' if DIR is a CVS administrative directory.
-The exact behavior is determined also by `cvs-dired-use-hook'."
- (when (stringp dir)
- (setq dir (directory-file-name dir))
- (when (and (string= "CVS" (file-name-nondirectory dir))
- (file-readable-p (expand-file-name "Entries" dir))
- cvs-dired-use-hook
- (if (eq cvs-dired-use-hook 'always)
- (not current-prefix-arg)
- (equal current-prefix-arg cvs-dired-use-hook)))
- (save-excursion
- (funcall cvs-dired-action (file-name-directory dir) t t))))))
-
-;;
-;; hook into VC
-;;
-
-(add-hook 'vc-post-command-functions 'cvs-vc-command-advice)
-
-(defun cvs-vc-command-advice (command files flags)
- (when (and (equal command "cvs")
- (progn
- (while (and (stringp (car flags))
- (string-match "\\`-" (car flags)))
- (pop flags))
- ;; don't parse output we don't understand.
- (member (car flags) cvs-parse-known-commands))
- ;; Don't parse "update -p" output.
- (not (and (member (car flags) '("update" "checkout"))
- (let ((found-p nil))
- (dolist (flag flags found-p)
- (if (equal flag "-p") (setq found-p t)))))))
- (save-current-buffer
- (let ((buffer (current-buffer))
- (dir default-directory)
- (cvs-from-vc t))
- (dolist (cvs-buf (buffer-list))
- (set-buffer cvs-buf)
- ;; look for a corresponding pcl-cvs buffer
- (when (and (eq major-mode 'cvs-mode)
- (cvs-string-prefix-p default-directory dir))
- (let ((subdir (substring dir (length default-directory))))
- (set-buffer buffer)
- (set (make-local-variable 'cvs-buffer) cvs-buf)
- ;; `cvs -q add file' produces no useful output :-(
- (when (and (equal (car flags) "add")
- (goto-char (point-min))
- (looking-at ".*to add this file permanently\n\\'"))
- (dolist (file (if (listp files) files (list files)))
- (insert "cvs add: scheduling file `"
- (file-name-nondirectory file)
- "' for addition\n")))
- ;; VC never (?) does `cvs -n update' so dcd=nil
- ;; should probably always be the right choice.
- (cvs-parse-process nil subdir))))))))
-
-;;
-;; Hook into write-buffer
-;;
-
-(defun cvs-mark-buffer-changed ()
- (let* ((file (expand-file-name buffer-file-name))
- (version (and (fboundp 'vc-backend)
- (eq (vc-backend file) 'CVS)
- (vc-working-revision file))))
- (when version
- (save-excursion
- (dolist (cvs-buf (buffer-list))
- (set-buffer cvs-buf)
- ;; look for a corresponding pcl-cvs buffer
- (when (and (eq major-mode 'cvs-mode)
- (cvs-string-prefix-p default-directory file))
- (let* ((file (substring file (length default-directory)))
- (fi (cvs-create-fileinfo
- (if (string= "0" version)
- 'ADDED 'MODIFIED)
- (or (file-name-directory file) "")
- (file-name-nondirectory file)
- "cvs-mark-buffer-changed")))
- (cvs-addto-collection cvs-cookies fi))))))))
-
-(add-hook 'after-save-hook 'cvs-mark-buffer-changed)
-
-\f
-(provide 'pcvs)
-
-;; arch-tag: 8e3a7494-0453-4389-9ab3-a557ce9fab61
-;;; pcvs.el ends here
+++ /dev/null
-;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts
-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: tools revision-control merge diff3 cvs conflict
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Provides a lightweight alternative to emerge/ediff.
-;; To use it, simply add to your .emacs the following lines:
-;;
-;; (autoload 'smerge-mode "smerge-mode" nil t)
-;;
-;; you can even have it turned on automatically with the following
-;; piece of code in your .emacs:
-;;
-;; (defun sm-try-smerge ()
-;; (save-excursion
-;; (goto-char (point-min))
-;; (when (re-search-forward "^<<<<<<< " nil t)
-;; (smerge-mode 1))))
-;; (add-hook 'find-file-hook 'sm-try-smerge t)
-
-;;; Todo:
-
-;; - if requested, ask the user whether he wants to call ediff right away
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'diff-mode) ;For diff-auto-refine-mode.
-
-
-;;; The real definition comes later.
-(defvar smerge-mode)
-
-(defgroup smerge ()
- "Minor mode to highlight and resolve diff3 conflicts."
- :group 'tools
- :prefix "smerge-")
-
-(defcustom smerge-diff-buffer-name "*vc-diff*"
- "Buffer name to use for displaying diffs."
- :group 'smerge
- :type '(choice
- (const "*vc-diff*")
- (const "*cvs-diff*")
- (const "*smerge-diff*")
- string))
-
-(defcustom smerge-diff-switches
- (append '("-d" "-b")
- (if (listp diff-switches) diff-switches (list diff-switches)))
- "A list of strings specifying switches to be passed to diff.
-Used in `smerge-diff-base-mine' and related functions."
- :group 'smerge
- :type '(repeat string))
-
-(defcustom smerge-auto-leave t
- "Non-nil means to leave `smerge-mode' when the last conflict is resolved."
- :group 'smerge
- :type 'boolean)
-
-(defface smerge-mine
- '((((min-colors 88) (background light))
- (:foreground "blue1"))
- (((background light))
- (:foreground "blue"))
- (((min-colors 88) (background dark))
- (:foreground "cyan1"))
- (((background dark))
- (:foreground "cyan")))
- "Face for your code."
- :group 'smerge)
-(define-obsolete-face-alias 'smerge-mine-face 'smerge-mine "22.1")
-(defvar smerge-mine-face 'smerge-mine)
-
-(defface smerge-other
- '((((background light))
- (:foreground "darkgreen"))
- (((background dark))
- (:foreground "lightgreen")))
- "Face for the other code."
- :group 'smerge)
-(define-obsolete-face-alias 'smerge-other-face 'smerge-other "22.1")
-(defvar smerge-other-face 'smerge-other)
-
-(defface smerge-base
- '((((min-colors 88) (background light))
- (:foreground "red1"))
- (((background light))
- (:foreground "red"))
- (((background dark))
- (:foreground "orange")))
- "Face for the base code."
- :group 'smerge)
-(define-obsolete-face-alias 'smerge-base-face 'smerge-base "22.1")
-(defvar smerge-base-face 'smerge-base)
-
-(defface smerge-markers
- '((((background light))
- (:background "grey85"))
- (((background dark))
- (:background "grey30")))
- "Face for the conflict markers."
- :group 'smerge)
-(define-obsolete-face-alias 'smerge-markers-face 'smerge-markers "22.1")
-(defvar smerge-markers-face 'smerge-markers)
-
-(defface smerge-refined-change
- '((t :background "yellow"))
- "Face used for char-based changes shown by `smerge-refine'."
- :group 'smerge)
-
-(easy-mmode-defmap smerge-basic-map
- `(("n" . smerge-next)
- ("p" . smerge-prev)
- ("r" . smerge-resolve)
- ("a" . smerge-keep-all)
- ("b" . smerge-keep-base)
- ("o" . smerge-keep-other)
- ("m" . smerge-keep-mine)
- ("E" . smerge-ediff)
- ("C" . smerge-combine-with-next)
- ("R" . smerge-refine)
- ("\C-m" . smerge-keep-current)
- ("=" . ,(make-sparse-keymap "Diff"))
- ("=<" "base-mine" . smerge-diff-base-mine)
- ("=>" "base-other" . smerge-diff-base-other)
- ("==" "mine-other" . smerge-diff-mine-other))
- "The base keymap for `smerge-mode'.")
-
-(defcustom smerge-command-prefix "\C-c^"
- "Prefix for `smerge-mode' commands."
- :group 'smerge
- :type '(choice (const :tag "ESC" "\e")
- (const :tag "C-c ^" "\C-c^" )
- (const :tag "none" "")
- string))
-
-(easy-mmode-defmap smerge-mode-map
- `((,smerge-command-prefix . ,smerge-basic-map))
- "Keymap for `smerge-mode'.")
-
-(defvar smerge-check-cache nil)
-(make-variable-buffer-local 'smerge-check-cache)
-(defun smerge-check (n)
- (condition-case nil
- (let ((state (cons (point) (buffer-modified-tick))))
- (unless (equal (cdr smerge-check-cache) state)
- (smerge-match-conflict)
- (setq smerge-check-cache (cons (match-data) state)))
- (nth (* 2 n) (car smerge-check-cache)))
- (error nil)))
-
-(easy-menu-define smerge-mode-menu smerge-mode-map
- "Menu for `smerge-mode'."
- '("SMerge"
- ["Next" smerge-next :help "Go to next conflict"]
- ["Previous" smerge-prev :help "Go to previous conflict"]
- "--"
- ["Keep All" smerge-keep-all :help "Keep all three versions"
- :active (smerge-check 1)]
- ["Keep Current" smerge-keep-current :help "Use current (at point) version"
- :active (and (smerge-check 1) (> (smerge-get-current) 0))]
- "--"
- ["Revert to Base" smerge-keep-base :help "Revert to base version"
- :active (smerge-check 2)]
- ["Keep Other" smerge-keep-other :help "Keep `other' version"
- :active (smerge-check 3)]
- ["Keep Yours" smerge-keep-mine :help "Keep your version"
- :active (smerge-check 1)]
- "--"
- ["Diff Base/Mine" smerge-diff-base-mine
- :help "Diff `base' and `mine' for current conflict"
- :active (smerge-check 2)]
- ["Diff Base/Other" smerge-diff-base-other
- :help "Diff `base' and `other' for current conflict"
- :active (smerge-check 2)]
- ["Diff Mine/Other" smerge-diff-mine-other
- :help "Diff `mine' and `other' for current conflict"
- :active (smerge-check 1)]
- "--"
- ["Invoke Ediff" smerge-ediff
- :help "Use Ediff to resolve the conflicts"
- :active (smerge-check 1)]
- ["Auto Resolve" smerge-resolve
- :help "Try auto-resolution heuristics"
- :active (smerge-check 1)]
- ["Combine" smerge-combine-with-next
- :help "Combine current conflict with next"
- :active (smerge-check 1)]
- ))
-
-(easy-menu-define smerge-context-menu nil
- "Context menu for mine area in `smerge-mode'."
- '(nil
- ["Keep Current" smerge-keep-current :help "Use current (at point) version"]
- ["Kill Current" smerge-kill-current :help "Remove current (at point) version"]
- ["Keep All" smerge-keep-all :help "Keep all three versions"]
- "---"
- ["More..." (popup-menu smerge-mode-menu) :help "Show full SMerge mode menu"]
- ))
-
-(defconst smerge-font-lock-keywords
- '((smerge-find-conflict
- (1 smerge-mine-face prepend t)
- (2 smerge-base-face prepend t)
- (3 smerge-other-face prepend t)
- ;; FIXME: `keep' doesn't work right with syntactic fontification.
- (0 smerge-markers-face keep)
- (4 nil t t)
- (5 nil t t)))
- "Font lock patterns for `smerge-mode'.")
-
-(defconst smerge-begin-re "^<<<<<<< \\(.*\\)\n")
-(defconst smerge-end-re "^>>>>>>> .*\n")
-(defconst smerge-base-re "^||||||| .*\n")
-(defconst smerge-other-re "^=======\n")
-
-(defvar smerge-conflict-style nil
- "Keep track of which style of conflict is in use.
-Can be nil if the style is undecided, or else:
-- `diff3-E'
-- `diff3-A'")
-
-;; Compiler pacifiers
-(defvar font-lock-mode)
-(defvar font-lock-keywords)
-
-;;;;
-;;;; Actual code
-;;;;
-
-;; Define smerge-next and smerge-prev
-(easy-mmode-define-navigation smerge smerge-begin-re "conflict" nil nil
- (if diff-auto-refine-mode
- (condition-case nil (smerge-refine) (error nil))))
-
-(defconst smerge-match-names ["conflict" "mine" "base" "other"])
-
-(defun smerge-ensure-match (n)
- (unless (match-end n)
- (error "No `%s'" (aref smerge-match-names n))))
-
-(defun smerge-auto-leave ()
- (when (and smerge-auto-leave
- (save-excursion (goto-char (point-min))
- (not (re-search-forward smerge-begin-re nil t))))
- (when (and (listp buffer-undo-list) smerge-mode)
- (push (list 'apply 'smerge-mode 1) buffer-undo-list))
- (smerge-mode -1)))
-
-
-(defun smerge-keep-all ()
- "Concatenate all versions."
- (interactive)
- (smerge-match-conflict)
- (let ((mb2 (or (match-beginning 2) (point-max)))
- (me2 (or (match-end 2) (point-min))))
- (delete-region (match-end 3) (match-end 0))
- (delete-region (max me2 (match-end 1)) (match-beginning 3))
- (if (and (match-end 2) (/= (match-end 1) (match-end 3)))
- (delete-region (match-end 1) (match-beginning 2)))
- (delete-region (match-beginning 0) (min (match-beginning 1) mb2))
- (smerge-auto-leave)))
-
-(defun smerge-keep-n (n)
- (smerge-remove-props (match-beginning 0) (match-end 0))
- ;; We used to use replace-match, but that did not preserve markers so well.
- (delete-region (match-end n) (match-end 0))
- (delete-region (match-beginning 0) (match-beginning n)))
-
-(defun smerge-combine-with-next ()
- "Combine the current conflict with the next one."
- ;; `smerge-auto-combine' relies on the finish position (at the beginning
- ;; of the closing marker).
- (interactive)
- (smerge-match-conflict)
- (let ((ends nil))
- (dolist (i '(3 2 1 0))
- (push (if (match-end i) (copy-marker (match-end i) t)) ends))
- (setq ends (apply 'vector ends))
- (goto-char (aref ends 0))
- (if (not (re-search-forward smerge-begin-re nil t))
- (error "No next conflict")
- (smerge-match-conflict)
- (let ((match-data (mapcar (lambda (m) (if m (copy-marker m)))
- (match-data))))
- ;; First copy the in-between text in each alternative.
- (dolist (i '(1 2 3))
- (when (aref ends i)
- (goto-char (aref ends i))
- (insert-buffer-substring (current-buffer)
- (aref ends 0) (car match-data))))
- (delete-region (aref ends 0) (car match-data))
- ;; Then move the second conflict's alternatives into the first.
- (dolist (i '(1 2 3))
- (set-match-data match-data)
- (when (and (aref ends i) (match-end i))
- (goto-char (aref ends i))
- (insert-buffer-substring (current-buffer)
- (match-beginning i) (match-end i))))
- (delete-region (car match-data) (cadr match-data))
- ;; Free the markers.
- (dolist (m match-data) (if m (move-marker m nil)))
- (mapc (lambda (m) (if m (move-marker m nil))) ends)))))
-
-(defvar smerge-auto-combine-max-separation 2
- "Max number of lines between conflicts that should be combined.")
-
-(defun smerge-auto-combine ()
- "Automatically combine conflicts that are near each other."
- (interactive)
- (save-excursion
- (goto-char (point-min))
- (while (smerge-find-conflict)
- ;; 2 is 1 (default) + 1 (the begin markers).
- (while (save-excursion
- (smerge-find-conflict
- (line-beginning-position
- (+ 2 smerge-auto-combine-max-separation))))
- (forward-line -1) ;Go back inside the conflict.
- (smerge-combine-with-next)
- (forward-line 1) ;Move past the end of the conflict.
- ))))
-
-(defvar smerge-resolve-function
- (lambda () (error "Don't know how to resolve"))
- "Mode-specific merge function.
-The function is called with zero or one argument (non-nil if the resolution
-function should only apply safe heuristics) and with the match data set
-according to `smerge-match-conflict'.")
-(add-to-list 'debug-ignored-errors "Don't know how to resolve")
-
-(defvar smerge-text-properties
- `(help-echo "merge conflict: mouse-3 shows a menu"
- ;; mouse-face highlight
- keymap (keymap (down-mouse-3 . smerge-popup-context-menu))))
-
-(defun smerge-remove-props (beg end)
- (remove-overlays beg end 'smerge 'refine)
- (remove-overlays beg end 'smerge 'conflict)
- ;; Now that we use overlays rather than text-properties, this function
- ;; does not cause refontification any more. It can be seen very clearly
- ;; in buffers where jit-lock-contextually is not t, in which case deleting
- ;; the "<<<<<<< foobar" leading line leaves the rest of the conflict
- ;; highlighted as if it were still a valid conflict. Note that in many
- ;; important cases (such as the previous example) we're actually called
- ;; during font-locking so inhibit-modification-hooks is non-nil, so we
- ;; can't just modify the buffer and expect font-lock to be triggered as in:
- ;; (put-text-property beg end 'smerge-force-highlighting nil)
- (with-silent-modifications
- (remove-text-properties beg end '(fontified nil))))
-
-(defun smerge-popup-context-menu (event)
- "Pop up the Smerge mode context menu under mouse."
- (interactive "e")
- (if (and smerge-mode
- (save-excursion (posn-set-point (event-end event)) (smerge-check 1)))
- (progn
- (posn-set-point (event-end event))
- (smerge-match-conflict)
- (let ((i (smerge-get-current))
- o)
- (if (<= i 0)
- ;; Out of range
- (popup-menu smerge-mode-menu)
- ;; Install overlay.
- (setq o (make-overlay (match-beginning i) (match-end i)))
- (unwind-protect
- (progn
- (overlay-put o 'face 'highlight)
- (sit-for 0) ;Display the new highlighting.
- (popup-menu smerge-context-menu))
- ;; Delete overlay.
- (delete-overlay o)))))
- ;; There's no conflict at point, the text-props are just obsolete.
- (save-excursion
- (let ((beg (re-search-backward smerge-end-re nil t))
- (end (re-search-forward smerge-begin-re nil t)))
- (smerge-remove-props (or beg (point-min)) (or end (point-max)))
- (push event unread-command-events)))))
-
-(defun smerge-apply-resolution-patch (buf m0b m0e m3b m3e &optional m2b)
- "Replace the conflict with a bunch of subconflicts.
-BUF contains a plain diff between match-1 and match-3."
- (let ((line 1)
- (textbuf (current-buffer))
- (name1 (progn (goto-char m0b)
- (buffer-substring (+ (point) 8) (line-end-position))))
- (name2 (when m2b (goto-char m2b) (forward-line -1)
- (buffer-substring (+ (point) 8) (line-end-position))))
- (name3 (progn (goto-char m0e) (forward-line -1)
- (buffer-substring (+ (point) 8) (line-end-position)))))
- (smerge-remove-props m0b m0e)
- (delete-region m3e m0e)
- (delete-region m0b m3b)
- (setq m3b m0b)
- (setq m3e (- m3e (- m3b m0b)))
- (goto-char m3b)
- (with-current-buffer buf
- (goto-char (point-min))
- (while (not (eobp))
- (if (not (looking-at "\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?\\([acd]\\)\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?$"))
- (error "Unexpected patch hunk header: %s"
- (buffer-substring (point) (line-end-position)))
- (let* ((op (char-after (match-beginning 3)))
- (startline (+ (string-to-number (match-string 1))
- ;; No clue why this is the way it is, but line
- ;; numbers seem to be off-by-one for `a' ops.
- (if (eq op ?a) 1 0)))
- (endline (if (eq op ?a) startline
- (1+ (if (match-end 2)
- (string-to-number (match-string 2))
- startline))))
- (lines (- endline startline))
- (otherlines (cond
- ((eq op ?d) nil)
- ((null (match-end 5)) 1)
- (t (- (string-to-number (match-string 5))
- (string-to-number (match-string 4)) -1))))
- othertext)
- (forward-line 1) ;Skip header.
- (forward-line lines) ;Skip deleted text.
- (if (eq op ?c) (forward-line 1)) ;Skip separator.
- (setq othertext
- (if (null otherlines) ""
- (let ((pos (point)))
- (dotimes (i otherlines) (delete-char 2) (forward-line 1))
- (buffer-substring pos (point)))))
- (with-current-buffer textbuf
- (forward-line (- startline line))
- (insert "<<<<<<< " name1 "\n" othertext
- (if name2 (concat "||||||| " name2 "\n") "")
- "=======\n")
- (forward-line lines)
- (insert ">>>>>>> " name3 "\n")
- (setq line endline))))))))
-
-(defun smerge-resolve (&optional safe)
- "Resolve the conflict at point intelligently.
-This relies on mode-specific knowledge and thus only works in some
-major modes. Uses `smerge-resolve-function' to do the actual work."
- (interactive)
- (smerge-match-conflict)
- (smerge-remove-props (match-beginning 0) (match-end 0))
- (let ((md (match-data))
- (m0b (match-beginning 0))
- (m1b (match-beginning 1))
- (m2b (match-beginning 2))
- (m3b (match-beginning 3))
- (m0e (match-end 0))
- (m1e (match-end 1))
- (m2e (match-end 2))
- (m3e (match-end 3))
- (buf (generate-new-buffer " *smerge*"))
- m b o)
- (unwind-protect
- (progn
- (cond
- ;; Trivial diff3 -A non-conflicts.
- ((and (eq (match-end 1) (match-end 3))
- (eq (match-beginning 1) (match-beginning 3)))
- (smerge-keep-n 3))
- ;; Mode-specific conflict resolution.
- ((condition-case nil
- (atomic-change-group
- (if safe
- (funcall smerge-resolve-function safe)
- (funcall smerge-resolve-function))
- t)
- (error nil))
- ;; Nothing to do: the resolution function has done it already.
- nil)
- ;; Non-conflict.
- ((and (eq m1e m3e) (eq m1b m3b))
- (set-match-data md) (smerge-keep-n 3))
- ;; Refine a 2-way conflict using "diff -b".
- ;; In case of a 3-way conflict with an empty base
- ;; (i.e. 2 conflicting additions), we do the same, presuming
- ;; that the 2 additions should be somehow merged rather
- ;; than concatenated.
- ((let ((lines (count-lines m3b m3e)))
- (setq m (make-temp-file "smm"))
- (write-region m1b m1e m nil 'silent)
- (setq o (make-temp-file "smo"))
- (write-region m3b m3e o nil 'silent)
- (not (or (eq m1b m1e) (eq m3b m3e)
- (and (not (zerop (call-process diff-command
- nil buf nil "-b" o m)))
- ;; TODO: We don't know how to do the refinement
- ;; if there's a non-empty ancestor and m1 and m3
- ;; aren't just plain equal.
- m2b (not (eq m2b m2e)))
- (with-current-buffer buf
- (goto-char (point-min))
- ;; Make sure there's some refinement.
- (looking-at
- (concat "1," (number-to-string lines) "c"))))))
- (smerge-apply-resolution-patch buf m0b m0e m3b m3e m2b))
- ;; "Mere whitespace changes" conflicts.
- ((when m2e
- (setq b (make-temp-file "smb"))
- (write-region m2b m2e b nil 'silent)
- (with-current-buffer buf (erase-buffer))
- ;; Only minor whitespace changes made locally.
- ;; BEWARE: pass "-c" 'cause the output is reused in the next test.
- (zerop (call-process diff-command nil buf nil "-bc" b m)))
- (set-match-data md)
- (smerge-keep-n 3))
- ;; Try "diff -b BASE MINE | patch OTHER".
- ((when (and (not safe) m2e b
- ;; If the BASE is empty, this would just concatenate
- ;; the two, which is rarely right.
- (not (eq m2b m2e)))
- ;; BEWARE: we're using here the patch of the previous test.
- (with-current-buffer buf
- (zerop (call-process-region
- (point-min) (point-max) "patch" t nil nil
- "-r" "/dev/null" "--no-backup-if-mismatch"
- "-fl" o))))
- (save-restriction
- (narrow-to-region m0b m0e)
- (smerge-remove-props m0b m0e)
- (insert-file-contents o nil nil nil t)))
- ;; Try "diff -b BASE OTHER | patch MINE".
- ((when (and (not safe) m2e b
- ;; If the BASE is empty, this would just concatenate
- ;; the two, which is rarely right.
- (not (eq m2b m2e)))
- (write-region m3b m3e o nil 'silent)
- (call-process diff-command nil buf nil "-bc" b o)
- (with-current-buffer buf
- (zerop (call-process-region
- (point-min) (point-max) "patch" t nil nil
- "-r" "/dev/null" "--no-backup-if-mismatch"
- "-fl" m))))
- (save-restriction
- (narrow-to-region m0b m0e)
- (smerge-remove-props m0b m0e)
- (insert-file-contents m nil nil nil t)))
- (t
- (error "Don't know how to resolve"))))
- (if (buffer-name buf) (kill-buffer buf))
- (if m (delete-file m))
- (if b (delete-file b))
- (if o (delete-file o))))
- (smerge-auto-leave))
-
-(defun smerge-resolve-all ()
- "Perform automatic resolution on all conflicts."
- (interactive)
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward smerge-begin-re nil t)
- (condition-case nil
- (progn
- (smerge-match-conflict)
- (smerge-resolve 'safe))
- (error nil)))))
-
-(defun smerge-batch-resolve ()
- ;; command-line-args-left is what is left of the command line.
- (if (not noninteractive)
- (error "`smerge-batch-resolve' is to be used only with -batch"))
- (while command-line-args-left
- (let ((file (pop command-line-args-left)))
- (if (string-match "\\.rej\\'" file)
- ;; .rej files should never contain diff3 markers, on the other hand,
- ;; in Arch, .rej files are sometimes used to indicate that the
- ;; main file has diff3 markers. So you can pass **/*.rej and
- ;; it will DTRT.
- (setq file (substring file 0 (match-beginning 0))))
- (message "Resolving conflicts in %s..." file)
- (when (file-readable-p file)
- (with-current-buffer (find-file-noselect file)
- (smerge-resolve-all)
- (save-buffer)
- (kill-buffer (current-buffer)))))))
-
-(defun smerge-keep-base ()
- "Revert to the base version."
- (interactive)
- (smerge-match-conflict)
- (smerge-ensure-match 2)
- (smerge-keep-n 2)
- (smerge-auto-leave))
-
-(defun smerge-keep-other ()
- "Use \"other\" version."
- (interactive)
- (smerge-match-conflict)
- ;;(smerge-ensure-match 3)
- (smerge-keep-n 3)
- (smerge-auto-leave))
-
-(defun smerge-keep-mine ()
- "Keep your version."
- (interactive)
- (smerge-match-conflict)
- ;;(smerge-ensure-match 1)
- (smerge-keep-n 1)
- (smerge-auto-leave))
-
-(defun smerge-get-current ()
- (let ((i 3))
- (while (or (not (match-end i))
- (< (point) (match-beginning i))
- (>= (point) (match-end i)))
- (decf i))
- i))
-
-(defun smerge-keep-current ()
- "Use the current (under the cursor) version."
- (interactive)
- (smerge-match-conflict)
- (let ((i (smerge-get-current)))
- (if (<= i 0) (error "Not inside a version")
- (smerge-keep-n i)
- (smerge-auto-leave))))
-
-(defun smerge-kill-current ()
- "Remove the current (under the cursor) version."
- (interactive)
- (smerge-match-conflict)
- (let ((i (smerge-get-current)))
- (if (<= i 0) (error "Not inside a version")
- (let ((left nil))
- (dolist (n '(3 2 1))
- (if (and (match-end n) (/= (match-end n) (match-end i)))
- (push n left)))
- (if (and (cdr left)
- (/= (match-end (car left)) (match-end (cadr left))))
- (ding) ;We don't know how to do that.
- (smerge-keep-n (car left))
- (smerge-auto-leave))))))
-
-(defun smerge-diff-base-mine ()
- "Diff 'base' and 'mine' version in current conflict region."
- (interactive)
- (smerge-diff 2 1))
-
-(defun smerge-diff-base-other ()
- "Diff 'base' and 'other' version in current conflict region."
- (interactive)
- (smerge-diff 2 3))
-
-(defun smerge-diff-mine-other ()
- "Diff 'mine' and 'other' version in current conflict region."
- (interactive)
- (smerge-diff 1 3))
-
-(defun smerge-match-conflict ()
- "Get info about the conflict. Puts the info in the `match-data'.
-The submatches contain:
- 0: the whole conflict.
- 1: your code.
- 2: the base code.
- 3: other code.
-An error is raised if not inside a conflict."
- (save-excursion
- (condition-case nil
- (let* ((orig-point (point))
-
- (_ (forward-line 1))
- (_ (re-search-backward smerge-begin-re))
-
- (start (match-beginning 0))
- (mine-start (match-end 0))
- (filename (or (match-string 1) ""))
-
- (_ (re-search-forward smerge-end-re))
- (_ (assert (< orig-point (match-end 0))))
-
- (other-end (match-beginning 0))
- (end (match-end 0))
-
- (_ (re-search-backward smerge-other-re start))
-
- (mine-end (match-beginning 0))
- (other-start (match-end 0))
-
- base-start base-end)
-
- ;; handle the various conflict styles
- (cond
- ((save-excursion
- (goto-char mine-start)
- (re-search-forward smerge-begin-re end t))
- ;; There's a nested conflict and we're after the beginning
- ;; of the outer one but before the beginning of the inner one.
- ;; Of course, maybe this is not a nested conflict but in that
- ;; case it can only be something nastier that we don't know how
- ;; to handle, so may as well arbitrarily decide to treat it as
- ;; a nested conflict. --Stef
- (error "There is a nested conflict"))
-
- ((re-search-backward smerge-base-re start t)
- ;; a 3-parts conflict
- (set (make-local-variable 'smerge-conflict-style) 'diff3-A)
- (setq base-end mine-end)
- (setq mine-end (match-beginning 0))
- (setq base-start (match-end 0)))
-
- ((string= filename (file-name-nondirectory
- (or buffer-file-name "")))
- ;; a 2-parts conflict
- (set (make-local-variable 'smerge-conflict-style) 'diff3-E))
-
- ((and (not base-start)
- (or (eq smerge-conflict-style 'diff3-A)
- (equal filename "ANCESTOR")
- (string-match "\\`[.0-9]+\\'" filename)))
- ;; a same-diff conflict
- (setq base-start mine-start)
- (setq base-end mine-end)
- (setq mine-start other-start)
- (setq mine-end other-end)))
-
- (store-match-data (list start end
- mine-start mine-end
- base-start base-end
- other-start other-end
- (when base-start (1- base-start)) base-start
- (1- other-start) other-start))
- t)
- (search-failed (error "Point not in conflict region")))))
-
-(add-to-list 'debug-ignored-errors "Point not in conflict region")
-
-(defun smerge-conflict-overlay (pos)
- "Return the conflict overlay at POS if any."
- (let ((ols (overlays-at pos))
- conflict)
- (dolist (ol ols)
- (if (and (eq (overlay-get ol 'smerge) 'conflict)
- (> (overlay-end ol) pos))
- (setq conflict ol)))
- conflict))
-
-(defun smerge-find-conflict (&optional limit)
- "Find and match a conflict region. Intended as a font-lock MATCHER.
-The submatches are the same as in `smerge-match-conflict'.
-Returns non-nil if a match is found between point and LIMIT.
-Point is moved to the end of the conflict."
- (let ((found nil)
- (pos (point))
- conflict)
- ;; First check to see if point is already inside a conflict, using
- ;; the conflict overlays.
- (while (and (not found) (setq conflict (smerge-conflict-overlay pos)))
- ;; Check the overlay's validity and kill it if it's out of date.
- (condition-case nil
- (progn
- (goto-char (overlay-start conflict))
- (smerge-match-conflict)
- (goto-char (match-end 0))
- (if (<= (point) pos)
- (error "Matching backward!")
- (setq found t)))
- (error (smerge-remove-props
- (overlay-start conflict) (overlay-end conflict))
- (goto-char pos))))
- ;; If we're not already inside a conflict, look for the next conflict
- ;; and add/update its overlay.
- (while (and (not found) (re-search-forward smerge-begin-re limit t))
- (condition-case nil
- (progn
- (smerge-match-conflict)
- (goto-char (match-end 0))
- (let ((conflict (smerge-conflict-overlay (1- (point)))))
- (if conflict
- ;; Update its location, just in case it got messed up.
- (move-overlay conflict (match-beginning 0) (match-end 0))
- (setq conflict (make-overlay (match-beginning 0) (match-end 0)
- nil 'front-advance nil))
- (overlay-put conflict 'evaporate t)
- (overlay-put conflict 'smerge 'conflict)
- (let ((props smerge-text-properties))
- (while props
- (overlay-put conflict (pop props) (pop props))))))
- (setq found t))
- (error nil)))
- found))
-
-;;; Refined change highlighting
-
-(defvar smerge-refine-forward-function 'smerge-refine-forward
- "Function used to determine an \"atomic\" element.
-You can set it to `forward-char' to get char-level granularity.
-Its behavior has mainly two restrictions:
-- if this function encounters a newline, it's important that it stops right
- after the newline.
- This only matters if `smerge-refine-ignore-whitespace' is nil.
-- it needs to be unaffected by changes performed by the `preproc' argument
- to `smerge-refine-subst'.
- This only matters if `smerge-refine-weight-hack' is nil.")
-
-(defvar smerge-refine-ignore-whitespace t
- "If non-nil, indicate that `smerge-refine' should try to ignore change in whitespace.")
-
-(defvar smerge-refine-weight-hack t
- "If non-nil, pass to diff as many lines as there are chars in the region.
-I.e. each atomic element (e.g. word) will be copied as many times (on different
-lines) as it has chars. This has two advantages:
-- if `diff' tries to minimize the number *lines* (rather than chars)
- added/removed, this adjust the weights so that adding/removing long
- symbols is considered correspondingly more costly.
-- `smerge-refine-forward-function' only needs to be called when chopping up
- the regions, and `forward-char' can be used afterwards.
-It has the following disadvantages:
-- cannot use `diff -w' because the weighting causes added spaces in a line
- to be represented as added copies of some line, so `diff -w' can't do the
- right thing any more.
-- may in degenerate cases take a 1KB input region and turn it into a 1MB
- file to pass to diff.")
-
-(defun smerge-refine-forward (n)
- (let ((case-fold-search nil)
- (re "[[:upper:]]?[[:lower:]]+\\|[[:upper:]]+\\|[[:digit:]]+\\|.\\|\n"))
- (when (and smerge-refine-ignore-whitespace
- ;; smerge-refine-weight-hack causes additional spaces to
- ;; appear as additional lines as well, so even if diff ignore
- ;; whitespace changes, it'll report added/removed lines :-(
- (not smerge-refine-weight-hack))
- (setq re (concat "[ \t]*\\(?:" re "\\)")))
- (dotimes (i n)
- (unless (looking-at re) (error "Smerge refine internal error"))
- (goto-char (match-end 0)))))
-
-(defun smerge-refine-chopup-region (beg end file &optional preproc)
- "Chopup the region into small elements, one per line.
-Save the result into FILE.
-If non-nil, PREPROC is called with no argument in a buffer that contains
-a copy of the text, just before chopping it up. It can be used to replace
-chars to try and eliminate some spurious differences."
- ;; We used to chop up char-by-char rather than word-by-word like ediff
- ;; does. It had the benefit of simplicity and very fine results, but it
- ;; often suffered from problem that diff would find correlations where
- ;; there aren't any, so the resulting "change" didn't make much sense.
- ;; You can still get this behavior by setting
- ;; `smerge-refine-forward-function' to `forward-char'.
- (let ((buf (current-buffer)))
- (with-temp-buffer
- (insert-buffer-substring buf beg end)
- (when preproc (goto-char (point-min)) (funcall preproc))
- (when smerge-refine-ignore-whitespace
- ;; It doesn't make much of a difference for diff-fine-highlight
- ;; because we still have the _/+/</>/! prefix anyway. Can still be
- ;; useful in other circumstances.
- (subst-char-in-region (point-min) (point-max) ?\n ?\s))
- (goto-char (point-min))
- (while (not (eobp))
- (funcall smerge-refine-forward-function 1)
- (let ((s (if (prog2 (forward-char -1) (bolp) (forward-char 1))
- nil
- (buffer-substring (line-beginning-position) (point)))))
- ;; We add \n after each char except after \n, so we get
- ;; one line per text char, where each line contains
- ;; just one char, except for \n chars which are
- ;; represented by the empty line.
- (unless (eq (char-before) ?\n) (insert ?\n))
- ;; HACK ALERT!!
- (if smerge-refine-weight-hack
- (dotimes (i (1- (length s))) (insert s "\n")))))
- (unless (bolp) (error "Smerge refine internal error"))
- (let ((coding-system-for-write 'emacs-mule))
- (write-region (point-min) (point-max) file nil 'nomessage)))))
-
-(defun smerge-refine-highlight-change (buf beg match-num1 match-num2 props)
- (with-current-buffer buf
- (goto-char beg)
- (let* ((startline (- (string-to-number match-num1) 1))
- (beg (progn (funcall (if smerge-refine-weight-hack
- 'forward-char
- smerge-refine-forward-function)
- startline)
- (point)))
- (end (progn (funcall (if smerge-refine-weight-hack
- 'forward-char
- smerge-refine-forward-function)
- (if match-num2
- (- (string-to-number match-num2)
- startline)
- 1))
- (point))))
- (when smerge-refine-ignore-whitespace
- (skip-chars-backward " \t\n" beg) (setq end (point))
- (goto-char beg)
- (skip-chars-forward " \t\n" end) (setq beg (point)))
- (when (> end beg)
- (let ((ol (make-overlay
- beg end nil
- ;; Make them tend to shrink rather than spread when editing.
- 'front-advance nil)))
- (overlay-put ol 'evaporate t)
- (dolist (x props) (overlay-put ol (car x) (cdr x)))
- ol)))))
-
-(defun smerge-refine-subst (beg1 end1 beg2 end2 props &optional preproc)
- "Show fine differences in the two regions BEG1..END1 and BEG2..END2.
-PROPS is an alist of properties to put (via overlays) on the changes.
-If non-nil, PREPROC is called with no argument in a buffer that contains
-a copy of a region, just before preparing it to for `diff'. It can be
-used to replace chars to try and eliminate some spurious differences."
- (let* ((buf (current-buffer))
- (pos (point))
- (file1 (make-temp-file "diff1"))
- (file2 (make-temp-file "diff2")))
- ;; Chop up regions into smaller elements and save into files.
- (smerge-refine-chopup-region beg1 end1 file1 preproc)
- (smerge-refine-chopup-region beg2 end2 file2 preproc)
-
- ;; Call diff on those files.
- (unwind-protect
- (with-temp-buffer
- (let ((coding-system-for-read 'emacs-mule))
- (call-process diff-command nil t nil
- (if (and smerge-refine-ignore-whitespace
- (not smerge-refine-weight-hack))
- ;; Pass -a so diff treats it as a text file even
- ;; if it contains \0 and such.
- ;; Pass -d so as to get the smallest change, but
- ;; also and more importantly because otherwise it
- ;; may happen that diff doesn't behave like
- ;; smerge-refine-weight-hack expects it to.
- ;; See http://thread.gmane.org/gmane.emacs.devel/82685.
- "-awd" "-ad")
- file1 file2))
- ;; Process diff's output.
- (goto-char (point-min))
- (let ((last1 nil)
- (last2 nil))
- (while (not (eobp))
- (if (not (looking-at "\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?\\([acd]\\)\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?$"))
- (error "Unexpected patch hunk header: %s"
- (buffer-substring (point) (line-end-position))))
- (let ((op (char-after (match-beginning 3)))
- (m1 (match-string 1))
- (m2 (match-string 2))
- (m4 (match-string 4))
- (m5 (match-string 5)))
- (when (memq op '(?d ?c))
- (setq last1
- (smerge-refine-highlight-change buf beg1 m1 m2 props)))
- (when (memq op '(?a ?c))
- (setq last2
- (smerge-refine-highlight-change buf beg2 m4 m5 props))))
- (forward-line 1) ;Skip hunk header.
- (and (re-search-forward "^[0-9]" nil 'move) ;Skip hunk body.
- (goto-char (match-beginning 0))))
- ;; (assert (or (null last1) (< (overlay-start last1) end1)))
- ;; (assert (or (null last2) (< (overlay-start last2) end2)))
- (if smerge-refine-weight-hack
- (progn
- ;; (assert (or (null last1) (<= (overlay-end last1) end1)))
- ;; (assert (or (null last2) (<= (overlay-end last2) end2)))
- )
- ;; smerge-refine-forward-function when calling in chopup may
- ;; have stopped because it bumped into EOB whereas in
- ;; smerge-refine-weight-hack it may go a bit further.
- (if (and last1 (> (overlay-end last1) end1))
- (move-overlay last1 (overlay-start last1) end1))
- (if (and last2 (> (overlay-end last2) end2))
- (move-overlay last2 (overlay-start last2) end2))
- )))
- (goto-char pos)
- (delete-file file1)
- (delete-file file2))))
-
-(defun smerge-refine (&optional part)
- "Highlight the words of the conflict that are different.
-For 3-way conflicts, highlights only two of the three parts.
-A numeric argument PART can be used to specify which two parts;
-repeating the command will highlight other two parts."
- (interactive
- (if (integerp current-prefix-arg) (list current-prefix-arg)
- (smerge-match-conflict)
- (let* ((prop (get-text-property (match-beginning 0) 'smerge-refine-part))
- (part (if (and (consp prop)
- (eq (buffer-chars-modified-tick) (car prop)))
- (cdr prop))))
- ;; If already highlighted, cycle.
- (list (if (integerp part) (1+ (mod part 3)))))))
-
- (if (and (integerp part) (or (< part 1) (> part 3)))
- (error "No conflict part nb %s" part))
- (smerge-match-conflict)
- (remove-overlays (match-beginning 0) (match-end 0) 'smerge 'refine)
- ;; Ignore `part' if not applicable, and default it if not provided.
- (setq part (cond ((null (match-end 2)) 2)
- ((eq (match-end 1) (match-end 3)) 1)
- ((integerp part) part)
- (t 2)))
- (let ((n1 (if (eq part 1) 2 1))
- (n2 (if (eq part 3) 2 3)))
- (smerge-ensure-match n1)
- (smerge-ensure-match n2)
- (with-silent-modifications
- (put-text-property (match-beginning 0) (1+ (match-beginning 0))
- 'smerge-refine-part
- (cons (buffer-chars-modified-tick) part)))
- (smerge-refine-subst (match-beginning n1) (match-end n1)
- (match-beginning n2) (match-end n2)
- '((smerge . refine)
- (face . smerge-refined-change)))))
-
-(defun smerge-diff (n1 n2)
- (smerge-match-conflict)
- (smerge-ensure-match n1)
- (smerge-ensure-match n2)
- (let ((name1 (aref smerge-match-names n1))
- (name2 (aref smerge-match-names n2))
- ;; Read them before the match-data gets clobbered.
- (beg1 (match-beginning n1))
- (end1 (match-end n1))
- (beg2 (match-beginning n2))
- (end2 (match-end n2))
- (file1 (make-temp-file "smerge1"))
- (file2 (make-temp-file "smerge2"))
- (dir default-directory)
- (file (if buffer-file-name (file-relative-name buffer-file-name)))
- ;; We would want to use `emacs-mule-unix' for read&write, but we
- ;; bump into problems with the coding-system used by diff to write
- ;; the file names and the time stamps in the header.
- ;; `buffer-file-coding-system' is not always correct either, but if
- ;; the OS/user uses only one coding-system, then it works.
- (coding-system-for-read buffer-file-coding-system))
- (write-region beg1 end1 file1 nil 'nomessage)
- (write-region beg2 end2 file2 nil 'nomessage)
- (unwind-protect
- (with-current-buffer (get-buffer-create smerge-diff-buffer-name)
- (setq default-directory dir)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (let ((status
- (apply 'call-process diff-command nil t nil
- (append smerge-diff-switches
- (list "-L" (concat name1 "/" file)
- "-L" (concat name2 "/" file)
- file1 file2)))))
- (if (eq status 0) (insert "No differences found.\n"))))
- (goto-char (point-min))
- (diff-mode)
- (display-buffer (current-buffer) t))
- (delete-file file1)
- (delete-file file2))))
-
-;; compiler pacifiers
-(defvar smerge-ediff-windows)
-(defvar smerge-ediff-buf)
-(defvar ediff-buffer-A)
-(defvar ediff-buffer-B)
-(defvar ediff-buffer-C)
-(defvar ediff-ancestor-buffer)
-(defvar ediff-quit-hook)
-(declare-function ediff-cleanup-mess "ediff-util" nil)
-
-;;;###autoload
-(defun smerge-ediff (&optional name-mine name-other name-base)
- "Invoke ediff to resolve the conflicts.
-NAME-MINE, NAME-OTHER, and NAME-BASE, if non-nil, are used for the
-buffer names."
- (interactive)
- (let* ((buf (current-buffer))
- (mode major-mode)
- ;;(ediff-default-variant 'default-B)
- (config (current-window-configuration))
- (filename (file-name-nondirectory buffer-file-name))
- (mine (generate-new-buffer
- (or name-mine (concat "*" filename " MINE*"))))
- (other (generate-new-buffer
- (or name-other (concat "*" filename " OTHER*"))))
- base)
- (with-current-buffer mine
- (buffer-disable-undo)
- (insert-buffer-substring buf)
- (goto-char (point-min))
- (while (smerge-find-conflict)
- (when (match-beginning 2) (setq base t))
- (smerge-keep-n 1))
- (buffer-enable-undo)
- (set-buffer-modified-p nil)
- (funcall mode))
-
- (with-current-buffer other
- (buffer-disable-undo)
- (insert-buffer-substring buf)
- (goto-char (point-min))
- (while (smerge-find-conflict)
- (smerge-keep-n 3))
- (buffer-enable-undo)
- (set-buffer-modified-p nil)
- (funcall mode))
-
- (when base
- (setq base (generate-new-buffer
- (or name-base (concat "*" filename " BASE*"))))
- (with-current-buffer base
- (buffer-disable-undo)
- (insert-buffer-substring buf)
- (goto-char (point-min))
- (while (smerge-find-conflict)
- (if (match-end 2)
- (smerge-keep-n 2)
- (delete-region (match-beginning 0) (match-end 0))))
- (buffer-enable-undo)
- (set-buffer-modified-p nil)
- (funcall mode)))
-
- ;; the rest of the code is inspired from vc.el
- ;; Fire up ediff.
- (set-buffer
- (if base
- (ediff-merge-buffers-with-ancestor mine other base)
- ;; nil 'ediff-merge-revisions-with-ancestor buffer-file-name)
- (ediff-merge-buffers mine other)))
- ;; nil 'ediff-merge-revisions buffer-file-name)))
-
- ;; Ediff is now set up, and we are in the control buffer.
- ;; Do a few further adjustments and take precautions for exit.
- (set (make-local-variable 'smerge-ediff-windows) config)
- (set (make-local-variable 'smerge-ediff-buf) buf)
- (set (make-local-variable 'ediff-quit-hook)
- (lambda ()
- (let ((buffer-A ediff-buffer-A)
- (buffer-B ediff-buffer-B)
- (buffer-C ediff-buffer-C)
- (buffer-Ancestor ediff-ancestor-buffer)
- (buf smerge-ediff-buf)
- (windows smerge-ediff-windows))
- (ediff-cleanup-mess)
- (with-current-buffer buf
- (erase-buffer)
- (insert-buffer-substring buffer-C)
- (kill-buffer buffer-A)
- (kill-buffer buffer-B)
- (kill-buffer buffer-C)
- (when (bufferp buffer-Ancestor) (kill-buffer buffer-Ancestor))
- (set-window-configuration windows)
- (message "Conflict resolution finished; you may save the buffer")))))
- (message "Please resolve conflicts now; exit ediff when done")))
-
-(defun smerge-makeup-conflict (pt1 pt2 pt3 &optional pt4)
- "Insert diff3 markers to make a new conflict.
-Uses point and mark for two of the relevant positions and previous marks
-for the other ones.
-By default, makes up a 2-way conflict,
-with a \\[universal-argument] prefix, makes up a 3-way conflict."
- (interactive
- (list (point)
- (mark)
- (progn (pop-mark) (mark))
- (when current-prefix-arg (pop-mark) (mark))))
- ;; Start from the end so as to avoid problems with pos-changes.
- (destructuring-bind (pt1 pt2 pt3 &optional pt4)
- (sort (list* pt1 pt2 pt3 (if pt4 (list pt4))) '>=)
- (goto-char pt1) (beginning-of-line)
- (insert ">>>>>>> OTHER\n")
- (goto-char pt2) (beginning-of-line)
- (insert "=======\n")
- (goto-char pt3) (beginning-of-line)
- (when pt4
- (insert "||||||| BASE\n")
- (goto-char pt4) (beginning-of-line))
- (insert "<<<<<<< MINE\n"))
- (if smerge-mode nil (smerge-mode 1))
- (smerge-refine))
-
-
-(defconst smerge-parsep-re
- (concat smerge-begin-re "\\|" smerge-end-re "\\|"
- smerge-base-re "\\|" smerge-other-re "\\|"))
-
-;;;###autoload
-(define-minor-mode smerge-mode
- "Minor mode to simplify editing output from the diff3 program.
-\\{smerge-mode-map}"
- :group 'smerge :lighter " SMerge"
- (when (and (boundp 'font-lock-mode) font-lock-mode)
- (save-excursion
- (if smerge-mode
- (font-lock-add-keywords nil smerge-font-lock-keywords 'append)
- (font-lock-remove-keywords nil smerge-font-lock-keywords))
- (goto-char (point-min))
- (while (smerge-find-conflict)
- (save-excursion
- (font-lock-fontify-region (match-beginning 0) (match-end 0) nil)))))
- (if (string-match (regexp-quote smerge-parsep-re) paragraph-separate)
- (unless smerge-mode
- (set (make-local-variable 'paragraph-separate)
- (replace-match "" t t paragraph-separate)))
- (when smerge-mode
- (set (make-local-variable 'paragraph-separate)
- (concat smerge-parsep-re paragraph-separate))))
- (unless smerge-mode
- (smerge-remove-props (point-min) (point-max))))
-
-;;;###autoload
-(defun smerge-start-session ()
- "Turn on `smerge-mode' and move point to first conflict marker.
-If no conflict maker is found, turn off `smerge-mode'."
- (interactive)
- (smerge-mode 1)
- (condition-case nil
- (unless (looking-at smerge-begin-re)
- (smerge-next))
- (error (smerge-auto-leave))))
-
-(provide 'smerge-mode)
-
-;; arch-tag: 605c8d1e-e43d-4943-a6f3-1bcc4333e690
-;;; smerge-mode.el ends here
+++ /dev/null
-;;; vc-annotate.el --- VC Annotate Support
-
-;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Martin Lorentzson <emwson@emw.ericsson.se>
-;; Maintainer: FSF
-;; Keywords: tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-
-(require 'vc-hooks)
-(require 'vc)
-
-;;; Code:
-(eval-when-compile
- (require 'cl))
-
-(defcustom vc-annotate-display-mode 'fullscale
- "Which mode to color the output of \\[vc-annotate] with by default."
- :type '(choice (const :tag "By Color Map Range" nil)
- (const :tag "Scale to Oldest" scale)
- (const :tag "Scale Oldest->Newest" fullscale)
- (number :tag "Specify Fractional Number of Days"
- :value "20.5"))
- :group 'vc)
-
-(defcustom vc-annotate-color-map
- (if (and (tty-display-color-p) (<= (display-color-cells) 8))
- ;; A custom sorted TTY colormap
- (let* ((colors
- (sort
- (delq nil
- (mapcar (lambda (x)
- (if (not (or
- (string-equal (car x) "white")
- (string-equal (car x) "black") ))
- (car x)))
- (tty-color-alist)))
- (lambda (a b)
- (cond
- ((or (string-equal a "red") (string-equal b "blue")) t)
- ((or (string-equal b "red") (string-equal a "blue")) nil)
- ((string-equal a "yellow") t)
- ((string-equal b "yellow") nil)
- ((string-equal a "cyan") t)
- ((string-equal b "cyan") nil)
- ((string-equal a "green") t)
- ((string-equal b "green") nil)
- ((string-equal a "magenta") t)
- ((string-equal b "magenta") nil)
- (t (string< a b))))))
- (date 20.)
- (delta (/ (- 360. date) (1- (length colors)))))
- (mapcar (lambda (x)
- (prog1
- (cons date x)
- (setq date (+ date delta)))) colors))
- ;; Normal colormap: hue stepped from 0-240deg, value=1., saturation=0.75
- '(( 20. . "#FF3F3F")
- ( 40. . "#FF6C3F")
- ( 60. . "#FF993F")
- ( 80. . "#FFC63F")
- (100. . "#FFF33F")
- (120. . "#DDFF3F")
- (140. . "#B0FF3F")
- (160. . "#83FF3F")
- (180. . "#56FF3F")
- (200. . "#3FFF56")
- (220. . "#3FFF83")
- (240. . "#3FFFB0")
- (260. . "#3FFFDD")
- (280. . "#3FF3FF")
- (300. . "#3FC6FF")
- (320. . "#3F99FF")
- (340. . "#3F6CFF")
- (360. . "#3F3FFF")))
- "Association list of age versus color, for \\[vc-annotate].
-Ages are given in units of fractional days. Default is eighteen
-steps using a twenty day increment, from red to blue. For TTY
-displays with 8 or fewer colors, the default is red to blue with
-all other colors between (excluding black and white)."
- :type 'alist
- :group 'vc)
-
-(defcustom vc-annotate-very-old-color "#3F3FFF"
- "Color for lines older than the current color range in \\[vc-annotate]."
- :type 'string
- :group 'vc)
-
-(defcustom vc-annotate-background "black"
- "Background color for \\[vc-annotate].
-Default color is used if nil."
- :type '(choice (const :tag "Default background" nil) (color))
- :group 'vc)
-
-(defcustom vc-annotate-menu-elements '(2 0.5 0.1 0.01)
- "Menu elements for the mode-specific menu of VC-Annotate mode.
-List of factors, used to expand/compress the time scale. See `vc-annotate'."
- :type '(repeat number)
- :group 'vc)
-
-(defvar vc-annotate-mode-map
- (let ((m (make-sparse-keymap)))
- (define-key m "a" 'vc-annotate-revision-previous-to-line)
- (define-key m "d" 'vc-annotate-show-diff-revision-at-line)
- (define-key m "D" 'vc-annotate-show-changeset-diff-revision-at-line)
- (define-key m "f" 'vc-annotate-find-revision-at-line)
- (define-key m "j" 'vc-annotate-revision-at-line)
- (define-key m "l" 'vc-annotate-show-log-revision-at-line)
- (define-key m "n" 'vc-annotate-next-revision)
- (define-key m "p" 'vc-annotate-prev-revision)
- (define-key m "w" 'vc-annotate-working-revision)
- (define-key m "v" 'vc-annotate-toggle-annotation-visibility)
- m)
- "Local keymap used for VC-Annotate mode.")
-
-;;; Annotate functionality
-
-;; Declare globally instead of additional parameter to
-;; temp-buffer-show-function (not possible to pass more than one
-;; parameter). The use of annotate-ratio is deprecated in favor of
-;; annotate-mode, which replaces it with the more sensible "span-to
-;; days", along with autoscaling support.
-(defvar vc-annotate-ratio nil "Global variable.")
-
-;; internal buffer-local variables
-(defvar vc-annotate-backend nil)
-(defvar vc-annotate-parent-file nil)
-(defvar vc-annotate-parent-rev nil)
-(defvar vc-annotate-parent-display-mode nil)
-
-(defconst vc-annotate-font-lock-keywords
- ;; The fontification is done by vc-annotate-lines instead of font-lock.
- '((vc-annotate-lines)))
-
-(define-derived-mode vc-annotate-mode special-mode "Annotate"
- "Major mode for output buffers of the `vc-annotate' command.
-
-You can use the mode-specific menu to alter the time-span of the used
-colors. See variable `vc-annotate-menu-elements' for customizing the
-menu items."
- ;; Frob buffer-invisibility-spec so that if it is originally a naked t,
- ;; it will become a list, to avoid initial annotations being invisible.
- (add-to-invisibility-spec 'foo)
- (remove-from-invisibility-spec 'foo)
- (set (make-local-variable 'truncate-lines) t)
- (set (make-local-variable 'font-lock-defaults)
- '(vc-annotate-font-lock-keywords t))
- (hack-dir-local-variables-non-file-buffer))
-
-(defun vc-annotate-toggle-annotation-visibility ()
- "Toggle whether or not the annotation is visible."
- (interactive)
- (funcall (if (memq 'vc-annotate-annotation buffer-invisibility-spec)
- 'remove-from-invisibility-spec
- 'add-to-invisibility-spec)
- 'vc-annotate-annotation)
- (force-window-update (current-buffer)))
-
-(defun vc-annotate-display-default (ratio)
- "Display the output of \\[vc-annotate] using the default color range.
-The color range is given by `vc-annotate-color-map', scaled by RATIO.
-The current time is used as the offset."
- (interactive (progn (kill-local-variable 'vc-annotate-color-map) '(1.0)))
- (message "Redisplaying annotation...")
- (vc-annotate-display ratio)
- (message "Redisplaying annotation...done"))
-
-(defun vc-annotate-oldest-in-map (color-map)
- "Return the oldest time in the COLOR-MAP."
- ;; Since entries should be sorted, we can just use the last one.
- (caar (last color-map)))
-
-(defun vc-annotate-get-time-set-line-props ()
- (let ((bol (point))
- (date (vc-call-backend vc-annotate-backend 'annotate-time))
- (inhibit-read-only t))
- (assert (>= (point) bol))
- (put-text-property bol (point) 'invisible 'vc-annotate-annotation)
- date))
-
-(defun vc-annotate-display-autoscale (&optional full)
- "Highlight the output of \\[vc-annotate] using an autoscaled color map.
-Autoscaling means that the map is scaled from the current time to the
-oldest annotation in the buffer, or, with prefix argument FULL, to
-cover the range from the oldest annotation to the newest."
- (interactive "P")
- (let ((newest 0.0)
- (oldest 999999.) ;Any CVS users at the founding of Rome?
- (current (vc-annotate-convert-time (current-time)))
- date)
- (message "Redisplaying annotation...")
- ;; Run through this file and find the oldest and newest dates annotated.
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (when (setq date (vc-annotate-get-time-set-line-props))
- (when (> date newest)
- (setq newest date))
- (when (< date oldest)
- (setq oldest date)))
- (forward-line 1)))
- (vc-annotate-display
- (/ (- (if full newest current) oldest)
- (vc-annotate-oldest-in-map vc-annotate-color-map))
- (if full newest))
- (message "Redisplaying annotation...done \(%s\)"
- (if full
- (format "Spanned from %.1f to %.1f days old"
- (- current oldest)
- (- current newest))
- (format "Spanned to %.1f days old" (- current oldest))))))
-
-;; Menu -- Using easymenu.el
-(easy-menu-define vc-annotate-mode-menu vc-annotate-mode-map
- "VC Annotate Display Menu"
- `("VC-Annotate"
- ["By Color Map Range" (unless (null vc-annotate-display-mode)
- (setq vc-annotate-display-mode nil)
- (vc-annotate-display-select))
- :style toggle :selected (null vc-annotate-display-mode)]
- ,@(let ((oldest-in-map (vc-annotate-oldest-in-map vc-annotate-color-map)))
- (mapcar (lambda (element)
- (let ((days (* element oldest-in-map)))
- `[,(format "Span %.1f days" days)
- (vc-annotate-display-select nil ,days)
- :style toggle :selected
- (eql vc-annotate-display-mode ,days) ]))
- vc-annotate-menu-elements))
- ["Span ..."
- (vc-annotate-display-select
- nil (float (string-to-number (read-string "Span how many days? "))))]
- "--"
- ["Span to Oldest"
- (unless (eq vc-annotate-display-mode 'scale)
- (vc-annotate-display-select nil 'scale))
- :help
- "Use an autoscaled color map from the oldest annotation to the current time"
- :style toggle :selected
- (eq vc-annotate-display-mode 'scale)]
- ["Span Oldest->Newest"
- (unless (eq vc-annotate-display-mode 'fullscale)
- (vc-annotate-display-select nil 'fullscale))
- :help
- "Use an autoscaled color map from the oldest to the newest annotation"
- :style toggle :selected
- (eq vc-annotate-display-mode 'fullscale)]
- "--"
- ["Toggle annotation visibility" vc-annotate-toggle-annotation-visibility
- :help
- "Toggle whether the annotation is visible or not"]
- ["Annotate previous revision" vc-annotate-prev-revision
- :help "Visit the annotation of the revision previous to this one"]
- ["Annotate next revision" vc-annotate-next-revision
- :help "Visit the annotation of the revision after this one"]
- ["Annotate revision at line" vc-annotate-revision-at-line
- :help
- "Visit the annotation of the revision identified in the current line"]
- ["Annotate revision previous to line" vc-annotate-revision-previous-to-line
- :help "Visit the annotation of the revision before the revision at line"]
- ["Annotate latest revision" vc-annotate-working-revision
- :help "Visit the annotation of the working revision of this file"]
- "--"
- ["Show log of revision at line" vc-annotate-show-log-revision-at-line
- :help "Visit the log of the revision at line"]
- ["Show diff of revision at line" vc-annotate-show-diff-revision-at-line
- :help "Visit the diff of the revision at line from its previous revision"]
- ["Show changeset diff of revision at line"
- vc-annotate-show-changeset-diff-revision-at-line
- :enable
- (eq 'repository (vc-call-backend ,vc-annotate-backend 'revision-granularity))
- :help "Visit the diff of the revision at line from its previous revision"]
- ["Visit revision at line" vc-annotate-find-revision-at-line
- :help "Visit the revision identified in the current line"]))
-
-(defun vc-annotate-display-select (&optional buffer mode)
- "Highlight the output of \\[vc-annotate].
-By default, the current buffer is highlighted, unless overridden by
-BUFFER. `vc-annotate-display-mode' specifies the highlighting mode to
-use; you may override this using the second optional arg MODE."
- (interactive)
- (when mode (setq vc-annotate-display-mode mode))
- (pop-to-buffer (or buffer (current-buffer)))
- (cond ((null vc-annotate-display-mode)
- ;; The ratio is global, thus relative to the global color-map.
- (kill-local-variable 'vc-annotate-color-map)
- (vc-annotate-display-default (or vc-annotate-ratio 1.0)))
- ;; One of the auto-scaling modes
- ((eq vc-annotate-display-mode 'scale)
- (vc-exec-after `(vc-annotate-display-autoscale)))
- ((eq vc-annotate-display-mode 'fullscale)
- (vc-exec-after `(vc-annotate-display-autoscale t)))
- ((numberp vc-annotate-display-mode) ; A fixed number of days lookback
- (vc-annotate-display-default
- (/ vc-annotate-display-mode
- (vc-annotate-oldest-in-map vc-annotate-color-map))))
- (t (error "No such display mode: %s"
- vc-annotate-display-mode))))
-
-;;;###autoload
-(defun vc-annotate (file rev &optional display-mode buf move-point-to)
- "Display the edit history of the current file using colors.
-
-This command creates a buffer that shows, for each line of the current
-file, when it was last edited and by whom. Additionally, colors are
-used to show the age of each line--blue means oldest, red means
-youngest, and intermediate colors indicate intermediate ages. By
-default, the time scale stretches back one year into the past;
-everything that is older than that is shown in blue.
-
-With a prefix argument, this command asks two questions in the
-minibuffer. First, you may enter a revision number; then the buffer
-displays and annotates that revision instead of the working revision
-\(type RET in the minibuffer to leave that default unchanged). Then,
-you are prompted for the time span in days which the color range
-should cover. For example, a time span of 20 days means that changes
-over the past 20 days are shown in red to blue, according to their
-age, and everything that is older than that is shown in blue.
-
-If MOVE-POINT-TO is given, move the point to that line.
-
-Customization variables:
-
-`vc-annotate-menu-elements' customizes the menu elements of the
-mode-specific menu. `vc-annotate-color-map' and
-`vc-annotate-very-old-color' define the mapping of time to colors.
-`vc-annotate-background' specifies the background color."
- (interactive
- (save-current-buffer
- (vc-ensure-vc-buffer)
- (list buffer-file-name
- (let ((def (vc-working-revision buffer-file-name)))
- (if (null current-prefix-arg) def
- (read-string
- (format "Annotate from revision (default %s): " def)
- nil nil def)))
- (if (null current-prefix-arg)
- vc-annotate-display-mode
- (float (string-to-number
- (read-string "Annotate span days (default 20): "
- nil nil "20")))))))
- (vc-ensure-vc-buffer)
- (setq vc-annotate-display-mode display-mode) ;Not sure why. --Stef
- (let* ((temp-buffer-name (format "*Annotate %s (rev %s)*" (buffer-name) rev))
- (temp-buffer-show-function 'vc-annotate-display-select)
- ;; If BUF is specified, we presume the caller maintains current line,
- ;; so we don't need to do it here. This implementation may give
- ;; strange results occasionally in the case of REV != WORKFILE-REV.
- (current-line (or move-point-to (unless buf
- (save-restriction
- (widen)
- (line-number-at-pos))))))
- (message "Annotating...")
- ;; If BUF is specified it tells in which buffer we should put the
- ;; annotations. This is used when switching annotations to another
- ;; revision, so we should update the buffer's name.
- (when buf (with-current-buffer buf
- (rename-buffer temp-buffer-name t)
- ;; In case it had to be uniquified.
- (setq temp-buffer-name (buffer-name))))
- (with-output-to-temp-buffer temp-buffer-name
- (let ((backend (vc-backend file))
- (coding-system-for-read buffer-file-coding-system))
- (vc-call-backend backend 'annotate-command file
- (get-buffer temp-buffer-name) rev)
- ;; we must setup the mode first, and then set our local
- ;; variables before the show-function is called at the exit of
- ;; with-output-to-temp-buffer
- (with-current-buffer temp-buffer-name
- (unless (equal major-mode 'vc-annotate-mode)
- (vc-annotate-mode))
- (set (make-local-variable 'vc-annotate-backend) backend)
- (set (make-local-variable 'vc-annotate-parent-file) file)
- (set (make-local-variable 'vc-annotate-parent-rev) rev)
- (set (make-local-variable 'vc-annotate-parent-display-mode)
- display-mode))))
-
- (with-current-buffer temp-buffer-name
- (vc-exec-after
- `(progn
- ;; Ideally, we'd rather not move point if the user has already
- ;; moved it elsewhere, but really point here is not the position
- ;; of the user's cursor :-(
- (when ,current-line ;(and (bobp))
- (goto-line ,current-line)
- (setq vc-sentinel-movepoint (point)))
- (unless (active-minibuffer-window)
- (message "Annotating... done")))))))
-
-(defun vc-annotate-prev-revision (prefix)
- "Visit the annotation of the revision previous to this one.
-
-With a numeric prefix argument, annotate the revision that many
-revisions previous."
- (interactive "p")
- (vc-annotate-warp-revision (- 0 prefix)))
-
-(defun vc-annotate-next-revision (prefix)
- "Visit the annotation of the revision after this one.
-
-With a numeric prefix argument, annotate the revision that many
-revisions after."
- (interactive "p")
- (vc-annotate-warp-revision prefix))
-
-(defun vc-annotate-working-revision ()
- "Visit the annotation of the working revision of this file."
- (interactive)
- (if (not (equal major-mode 'vc-annotate-mode))
- (message "Cannot be invoked outside of a vc annotate buffer")
- (let ((warp-rev (vc-working-revision vc-annotate-parent-file)))
- (if (equal warp-rev vc-annotate-parent-rev)
- (message "Already at revision %s" warp-rev)
- (vc-annotate-warp-revision warp-rev)))))
-
-(defun vc-annotate-extract-revision-at-line ()
- "Extract the revision number of the current line.
-Return a cons (REV . FILENAME)."
- ;; This function must be invoked from a buffer in vc-annotate-mode
- (let ((rev (vc-call-backend vc-annotate-backend
- 'annotate-extract-revision-at-line)))
- (if (or (null rev) (consp rev))
- rev
- (cons rev vc-annotate-parent-file))))
-
-(defun vc-annotate-revision-at-line ()
- "Visit the annotation of the revision identified in the current line."
- (interactive)
- (if (not (equal major-mode 'vc-annotate-mode))
- (message "Cannot be invoked outside of a vc annotate buffer")
- (let ((rev-at-line (vc-annotate-extract-revision-at-line)))
- (if (not rev-at-line)
- (message "Cannot extract revision number from the current line")
- (if (and (equal (car rev-at-line) vc-annotate-parent-rev)
- (string= (cdr rev-at-line) vc-annotate-parent-file))
- (message "Already at revision %s" rev-at-line)
- (vc-annotate-warp-revision (car rev-at-line) (cdr rev-at-line)))))))
-
-(defun vc-annotate-find-revision-at-line ()
- "Visit the revision identified in the current line."
- (interactive)
- (if (not (equal major-mode 'vc-annotate-mode))
- (message "Cannot be invoked outside of a vc annotate buffer")
- (let ((rev-at-line (vc-annotate-extract-revision-at-line)))
- (if (not rev-at-line)
- (message "Cannot extract revision number from the current line")
- (switch-to-buffer-other-window
- (vc-find-revision (cdr rev-at-line) (car rev-at-line)))))))
-
-(defun vc-annotate-revision-previous-to-line ()
- "Visit the annotation of the revision before the revision at line."
- (interactive)
- (if (not (equal major-mode 'vc-annotate-mode))
- (message "Cannot be invoked outside of a vc annotate buffer")
- (let* ((rev-at-line (vc-annotate-extract-revision-at-line))
- (prev-rev nil)
- (rev (car rev-at-line))
- (fname (cdr rev-at-line)))
- (if (not rev-at-line)
- (message "Cannot extract revision number from the current line")
- (setq prev-rev
- (vc-call-backend vc-annotate-backend 'previous-revision
- fname rev))
- (vc-annotate-warp-revision prev-rev fname)))))
-
-(defvar log-view-vc-backend)
-(defvar log-view-vc-fileset)
-
-(defun vc-annotate-show-log-revision-at-line ()
- "Visit the log of the revision at line.
-If the VC backend supports it, only show the log entry for the revision.
-If a *vc-change-log* buffer exists and already shows a log for
-the file in question, search for the log entry required and move point ."
- (interactive)
- (if (not (equal major-mode 'vc-annotate-mode))
- (message "Cannot be invoked outside of a vc annotate buffer")
- (let ((rev-at-line (vc-annotate-extract-revision-at-line)))
- (if (not rev-at-line)
- (message "Cannot extract revision number from the current line")
- (let ((backend vc-annotate-backend)
- (log-buf (get-buffer "*vc-change-log*"))
- pos)
- (if (and
- log-buf
- ;; Look for a log buffer that already displays the correct file.
- (with-current-buffer log-buf
- (and (eq backend log-view-vc-backend)
- (null (cdr log-view-vc-fileset))
- (string= (car log-view-vc-fileset) (cdr rev-at-line))
- ;; Check if the entry we require can be found.
- (vc-call-backend
- backend 'show-log-entry (car rev-at-line))
- (setq pos (point)))))
- (progn
- (pop-to-buffer log-buf)
- (goto-char pos))
- ;; Ask the backend to display a single log entry.
- (vc-print-log-internal
- vc-annotate-backend (list (cdr rev-at-line))
- (car rev-at-line) t 1)))))))
-
-(defun vc-annotate-show-diff-revision-at-line-internal (filediff)
- (if (not (equal major-mode 'vc-annotate-mode))
- (message "Cannot be invoked outside of a vc annotate buffer")
- (let* ((rev-at-line (vc-annotate-extract-revision-at-line))
- (prev-rev nil)
- (rev (car rev-at-line))
- (fname (cdr rev-at-line)))
- (if (not rev-at-line)
- (message "Cannot extract revision number from the current line")
- (setq prev-rev
- (vc-call-backend vc-annotate-backend 'previous-revision
- fname rev))
- (if (not prev-rev)
- (message "Cannot diff from any revision prior to %s" rev)
- (save-window-excursion
- (vc-diff-internal
- nil
- ;; The value passed here should follow what
- ;; `vc-deduce-fileset' returns.
- (list vc-annotate-backend
- (if filediff
- (list fname)
- nil))
- prev-rev rev))
- (switch-to-buffer "*vc-diff*"))))))
-
-(defun vc-annotate-show-diff-revision-at-line ()
- "Visit the diff of the revision at line from its previous revision."
- (interactive)
- (vc-annotate-show-diff-revision-at-line-internal t))
-
-(defun vc-annotate-show-changeset-diff-revision-at-line ()
- "Visit the diff of the revision at line from its previous revision for all files in the changeset."
- (interactive)
- (when (eq 'file (vc-call-backend vc-annotate-backend 'revision-granularity))
- (error "The %s backend does not support changeset diffs" vc-annotate-backend))
- (vc-annotate-show-diff-revision-at-line-internal nil))
-
-(defun vc-annotate-warp-revision (revspec &optional file)
- "Annotate the revision described by REVSPEC.
-
-If REVSPEC is a positive integer, warp that many revisions forward,
-if possible, otherwise echo a warning message. If REVSPEC is a
-negative integer, warp that many revisions backward, if possible,
-otherwise echo a warning message. If REVSPEC is a string, then it
-describes a revision number, so warp to that revision."
- (if (not (equal major-mode 'vc-annotate-mode))
- (message "Cannot be invoked outside of a vc annotate buffer")
- (let* ((buf (current-buffer))
- (oldline (line-number-at-pos))
- (revspeccopy revspec)
- (newrev nil))
- (cond
- ((and (integerp revspec) (> revspec 0))
- (setq newrev vc-annotate-parent-rev)
- (while (and (> revspec 0) newrev)
- (setq newrev (vc-call-backend vc-annotate-backend 'next-revision
- (or file vc-annotate-parent-file) newrev))
- (setq revspec (1- revspec)))
- (unless newrev
- (message "Cannot increment %d revisions from revision %s"
- revspeccopy vc-annotate-parent-rev)))
- ((and (integerp revspec) (< revspec 0))
- (setq newrev vc-annotate-parent-rev)
- (while (and (< revspec 0) newrev)
- (setq newrev (vc-call-backend vc-annotate-backend 'previous-revision
- (or file vc-annotate-parent-file) newrev))
- (setq revspec (1+ revspec)))
- (unless newrev
- (message "Cannot decrement %d revisions from revision %s"
- (- 0 revspeccopy) vc-annotate-parent-rev)))
- ((stringp revspec) (setq newrev revspec))
- (t (error "Invalid argument to vc-annotate-warp-revision")))
- (when newrev
- (vc-annotate (or file vc-annotate-parent-file) newrev
- vc-annotate-parent-display-mode
- buf
- ;; Pass the current line so that vc-annotate will
- ;; place the point in the line.
- (min oldline (progn (goto-char (point-max))
- (forward-line -1)
- (line-number-at-pos))))))))
-
-(defun vc-annotate-compcar (threshold a-list)
- "Test successive cons cells of A-LIST against THRESHOLD.
-Return the first cons cell with a car that is not less than THRESHOLD,
-nil if no such cell exists."
- (let ((i 1)
- (tmp-cons (car a-list)))
- (while (and tmp-cons (< (car tmp-cons) threshold))
- (setq tmp-cons (car (nthcdr i a-list)))
- (setq i (+ i 1)))
- tmp-cons)) ; Return the appropriate value
-
-(defun vc-annotate-convert-time (time)
- "Convert a time value to a floating-point number of days.
-The argument TIME is a list as returned by `current-time' or
-`encode-time', only the first two elements of that list are considered."
- (/ (+ (* (float (car time)) (lsh 1 16)) (cadr time)) 24 3600))
-
-(defun vc-annotate-difference (&optional offset)
- "Return the time span in days to the next annotation.
-This calls the backend function annotate-time, and returns the
-difference in days between the time returned and the current time,
-or OFFSET if present."
- (let ((next-time (vc-annotate-get-time-set-line-props)))
- (when next-time
- (- (or offset
- (vc-call-backend vc-annotate-backend 'annotate-current-time))
- next-time))))
-
-(defun vc-default-annotate-current-time (backend)
- "Return the current time, encoded as fractional days."
- (vc-annotate-convert-time (current-time)))
-
-(defvar vc-annotate-offset nil)
-
-(defun vc-annotate-display (ratio &optional offset)
- "Highlight `vc-annotate' output in the current buffer.
-RATIO is the expansion that should be applied to `vc-annotate-color-map'.
-The annotations are relative to the current time, unless overridden by OFFSET."
- (when (/= ratio 1.0)
- (set (make-local-variable 'vc-annotate-color-map)
- (mapcar (lambda (elem) (cons (* (car elem) ratio) (cdr elem)))
- vc-annotate-color-map)))
- (set (make-local-variable 'vc-annotate-offset) offset)
- (font-lock-mode 1))
-
-(defun vc-annotate-lines (limit)
- (while (< (point) limit)
- (let ((difference (vc-annotate-difference vc-annotate-offset))
- (start (point))
- (end (progn (forward-line 1) (point))))
- (when difference
- (let* ((color (or (vc-annotate-compcar difference vc-annotate-color-map)
- (cons nil vc-annotate-very-old-color)))
- ;; substring from index 1 to remove any leading `#' in the name
- (face-name (concat "vc-annotate-face-"
- (if (string-equal
- (substring (cdr color) 0 1) "#")
- (substring (cdr color) 1)
- (cdr color))))
- ;; Make the face if not done.
- (face (or (intern-soft face-name)
- (let ((tmp-face (make-face (intern face-name))))
- (set-face-foreground tmp-face (cdr color))
- (when vc-annotate-background
- (set-face-background tmp-face
- vc-annotate-background))
- tmp-face)))) ; Return the face
- (put-text-property start end 'face face)))))
- ;; Pretend to font-lock there were no matches.
- nil)
-
-(provide 'vc-annotate)
-
-;; arch-tag: c3454a89-80e5-4ffd-8993-671b59612898
-;;; vc-annotate.el ends here
+++ /dev/null
-;;; vc-arch.el --- VC backend for the Arch version-control system
-
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Author: FSF (see vc.el for full credits)
-;; Maintainer: Stefan Monnier <monnier@gnu.org>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; The home page of the Arch version control system is at
-;;
-;; http://www.gnuarch.org/
-;;
-;; This is derived from vc-mcvs.el as follows:
-;; - cp vc-mcvs.el vc-arch.el and then M-% mcvs RET arch RET
-;;
-;; Then of course started the hacking.
-;;
-;; What has been partly tested:
-;; - Open a file.
-;; - C-x v = without any prefix arg.
-;; - C-x v v to commit a change to a single file.
-
-;; Bugs:
-
-;; - *VC-log*'s initial content lacks the `Summary:' lines.
-;; - All files under the tree are considered as "under Arch's control"
-;; without regards to =tagging-method and such.
-;; - Files are always considered as `edited'.
-;; - C-x v l does not work.
-;; - C-x v i does not work.
-;; - C-x v ~ does not work.
-;; - C-x v u does not work.
-;; - C-x v s does not work.
-;; - C-x v r does not work.
-;; - VC directory listings do not work.
-;; - And more...
-
-;;; Code:
-
-(eval-when-compile (require 'vc) (require 'cl))
-
-;;; Properties of the backend
-
-(defun vc-arch-revision-granularity () 'repository)
-(defun vc-arch-checkout-model (files) 'implicit)
-
-;;;
-;;; Customization options
-;;;
-
-;; It seems Arch diff does not accept many options, so this is not
-;; very useful. It exists mainly so that the VC backends are all
-;; consistent with regards to their treatment of diff switches.
-(defcustom vc-arch-diff-switches t
- "String or list of strings specifying switches for Arch diff under VC.
-If nil, use the value of `vc-diff-switches'. If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "23.1"
- :group 'vc)
-
-(define-obsolete-variable-alias 'vc-arch-command 'vc-arch-program "23.1")
-
-(defcustom vc-arch-program
- (let ((candidates '("tla" "baz")))
- (while (and candidates (not (executable-find (car candidates))))
- (setq candidates (cdr candidates)))
- (or (car candidates) "tla"))
- "Name of the Arch executable."
- :type 'string
- :group 'vc)
-
-;; Clear up the cache to force vc-call to check again and discover
-;; new functions when we reload this file.
-(put 'Arch 'vc-functions nil)
-
-;;;###autoload (defun vc-arch-registered (file)
-;;;###autoload (if (vc-find-root file "{arch}/=tagging-method")
-;;;###autoload (progn
-;;;###autoload (load "vc-arch")
-;;;###autoload (vc-arch-registered file))))
-
-(defun vc-arch-add-tagline ()
- "Add an `arch-tag' to the end of the current file."
- (interactive)
- (comment-normalize-vars)
- (goto-char (point-max))
- (forward-comment -1)
- (skip-chars-forward " \t\n")
- (cond
- ((not (bolp)) (insert "\n\n"))
- ((not (eq ?\n (char-before (1- (point))))) (insert "\n")))
- (let ((beg (point))
- (idfile (and buffer-file-name
- (expand-file-name
- (concat ".arch-ids/"
- (file-name-nondirectory buffer-file-name)
- ".id")
- (file-name-directory buffer-file-name)))))
- (insert "arch-tag: ")
- (if (and idfile (file-exists-p idfile))
- ;; If the file is unreadable, we do want to get an error here.
- (progn
- (insert-file-contents idfile)
- (forward-line 1)
- (delete-file idfile))
- (condition-case nil
- (call-process "uuidgen" nil t)
- (file-error (insert (format "%s <%s> %s"
- (current-time-string)
- user-mail-address
- (+ (nth 2 (current-time))
- (buffer-size)))))))
- (comment-region beg (point))))
-
-(defconst vc-arch-tagline-re "^\\W*arch-tag:[ \t]*\\(.*[^ \t\n]\\)")
-
-(defmacro vc-with-current-file-buffer (file &rest body)
- (declare (indent 2) (debug t))
- `(let ((-kill-buf- nil)
- (-file- ,file))
- (with-current-buffer (or (find-buffer-visiting -file-)
- (setq -kill-buf- (generate-new-buffer " temp")))
- ;; Avoid find-file-literally since it can do many undesirable extra
- ;; things (among which, call us back into an infinite loop).
- (if -kill-buf- (insert-file-contents -file-))
- (unwind-protect
- (progn ,@body)
- (if (buffer-live-p -kill-buf-) (kill-buffer -kill-buf-))))))
-
-(defun vc-arch-file-source-p (file)
- "Can return nil, `maybe' or a non-nil value.
-Only the value `maybe' can be trusted :-(."
- ;; FIXME: Check the tag and name of parent dirs.
- (unless (string-match "\\`[,+]" (file-name-nondirectory file))
- (or (string-match "\\`{arch}/"
- (file-relative-name file (vc-arch-root file)))
- (file-exists-p
- ;; Check the presence of an ID file.
- (expand-file-name
- (concat ".arch-ids/" (file-name-nondirectory file) ".id")
- (file-name-directory file)))
- ;; Check the presence of a tagline.
- (vc-with-current-file-buffer file
- (save-excursion
- (goto-char (point-max))
- (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t)
- (progn
- (goto-char (point-min))
- (re-search-forward vc-arch-tagline-re (+ (point) 1000) t)))))
- ;; FIXME: check =tagging-method to see whether untagged files might
- ;; be source or not.
- (with-current-buffer
- (find-file-noselect (expand-file-name "{arch}/=tagging-method"
- (vc-arch-root file)))
- (let ((untagged-source t)) ;Default is `names'.
- (save-excursion
- (goto-char (point-min))
- (if (re-search-forward "^[ \t]*\\(\\(tagline\\|implicit\\|names\\)\\|explicit\\)" nil t)
- (setq untagged-source (match-end 2)))
- (if (re-search-forward "^[ \t]*untagged-source[ \t]+\\(\\(source\\)\\|precious\\|backup\\|junk\\|unrecognized\\)" nil t)
- (setq untagged-source (match-end 2))))
- (if untagged-source 'maybe))))))
-
-(defun vc-arch-file-id (file)
- ;; Don't include the kind of ID this is because it seems to be too messy.
- (let ((idfile (expand-file-name
- (concat ".arch-ids/" (file-name-nondirectory file) ".id")
- (file-name-directory file))))
- (if (file-exists-p idfile)
- (with-temp-buffer
- (insert-file-contents idfile)
- (looking-at ".*[^ \n\t]")
- (match-string 0))
- (with-current-buffer (find-file-noselect file)
- (save-excursion
- (goto-char (point-max))
- (if (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t)
- (progn
- (goto-char (point-min))
- (re-search-forward vc-arch-tagline-re (+ (point) 1000) t)))
- (match-string 1)
- (concat "./" (file-relative-name file (vc-arch-root file)))))))))
-
-(defun vc-arch-tagging-method (file)
- (with-current-buffer
- (find-file-noselect
- (expand-file-name "{arch}/=tagging-method" (vc-arch-root file)))
- (save-excursion
- (goto-char (point-min))
- (if (re-search-forward
- "^[ \t]*\\(tagline\\|implicit\\|names\\|explicit\\)" nil t)
- (intern (match-string 1))
- 'names))))
-
-(defun vc-arch-root (file)
- "Return the root directory of an Arch project, if any."
- (or (vc-file-getprop file 'arch-root)
- ;; Check the =tagging-method, in case someone naively manually
- ;; creates a {arch} directory somewhere.
- (let ((root (vc-find-root file "{arch}/=tagging-method")))
- (when root
- (vc-file-setprop
- file 'arch-root root)))))
-
-(defun vc-arch-register (files &optional rev comment)
- (if rev (error "Explicit initial revision not supported for Arch"))
- (dolist (file files)
- (let ((tagmet (vc-arch-tagging-method file)))
- (if (and (memq tagmet '(tagline implicit)) comment-start)
- (with-current-buffer (find-file-noselect file)
- (if (buffer-modified-p)
- (error "Save %s first" (buffer-name)))
- (vc-arch-add-tagline)
- (save-buffer)))))
- (vc-arch-command nil 0 files "add"))
-
-(defun vc-arch-registered (file)
- ;; Don't seriously check whether it's source or not. Checking would
- ;; require running TLA, so it's better to not do it, so it also works if
- ;; TLA is not installed.
- (and (vc-arch-root file)
- (vc-arch-file-source-p file)))
-
-(defun vc-arch-default-version (file)
- (or (vc-file-getprop (vc-arch-root file) 'arch-default-version)
- (let* ((root (vc-arch-root file))
- (f (expand-file-name "{arch}/++default-version" root)))
- (if (file-readable-p f)
- (vc-file-setprop
- root 'arch-default-version
- (with-temp-buffer
- (insert-file-contents f)
- ;; Strip the terminating newline.
- (buffer-substring (point-min) (1- (point-max)))))))))
-
-(defun vc-arch-workfile-unchanged-p (file)
- "Stub: arch workfiles are always considered to be in a changed state,"
- nil)
-
-(defun vc-arch-state (file)
- ;; There's no checkout operation and merging is not done from VC
- ;; so the only operation that's state dependent that VC supports is commit
- ;; which is only activated if the file is `edited'.
- (let* ((root (vc-arch-root file))
- (ver (vc-arch-default-version file))
- (pat (concat "\\`" (subst-char-in-string ?/ ?% ver)))
- (dir (expand-file-name ",,inode-sigs/"
- (expand-file-name "{arch}" root)))
- (sigfile nil))
- (dolist (f (if (file-directory-p dir) (directory-files dir t pat)))
- (if (or (not sigfile) (file-newer-than-file-p f sigfile))
- (setq sigfile f)))
- (if (not sigfile)
- 'edited ;We know nothing.
- (let ((id (vc-arch-file-id file)))
- (setq id (replace-regexp-in-string "[ \t]" "_" id))
- (with-current-buffer (find-file-noselect sigfile)
- (goto-char (point-min))
- (while (and (search-forward id nil 'move)
- (save-excursion
- (goto-char (- (match-beginning 0) 2))
- ;; For `names', the lines start with `?./foo/bar'.
- ;; For others there's 2 chars before the ./foo/bar.
- (or (not (or (bolp) (looking-at "\n?")))
- ;; Ignore E_ entries used for foo.id files.
- (looking-at "E_")))))
- (if (eobp)
- ;; ID not found.
- (if (equal (file-name-nondirectory sigfile)
- (subst-char-in-string
- ?/ ?% (vc-arch-working-revision file)))
- 'added
- ;; Might be `added' or `up-to-date' as well.
- ;; FIXME: Check in the patch logs to find out.
- 'edited)
- ;; Found the ID, let's check the inode.
- (if (not (re-search-forward
- "\t.*mtime=\\([0-9]+\\):size=\\([0-9]+\\)"
- (line-end-position) t))
- ;; Buh? Unexpected format.
- 'edited
- (let ((ats (file-attributes file)))
- (if (and (eq (nth 7 ats) (string-to-number (match-string 2)))
- (equal (format-time-string "%s" (nth 5 ats))
- (match-string 1)))
- 'up-to-date
- 'edited)))))))))
-
-(defun vc-arch-dir-status (dir callback)
- "Run 'tla inventory' for DIR and pass results to CALLBACK.
-CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
-`vc-dir-refresh'."
- (let ((default-directory dir))
- (vc-arch-command t 'async nil "changes"))
- ;; The updating could be done asynchronously.
- (vc-exec-after
- `(vc-arch-after-dir-status ',callback)))
-
-(defun vc-arch-after-dir-status (callback)
- (let* ((state-map '(("M " . edited)
- ("Mb" . edited) ;binary
- ("D " . removed)
- ("D/" . removed) ;directory
- ("A " . added)
- ("A/" . added) ;directory
- ("=>" . renamed)
- ("/>" . renamed) ;directory
- ("lf" . symlink-to-file)
- ("fl" . file-to-symlink)
- ("--" . permissions-changed)
- ("-/" . permissions-changed) ;directory
- ))
- (state-map-regexp (regexp-opt (mapcar 'car state-map) t))
- (entry-regexp (concat "^" state-map-regexp " \\(.*\\)$"))
- result)
- (goto-char (point-min))
- ;;(message "Got %s" (buffer-string))
- (while (re-search-forward entry-regexp nil t)
- (let* ((state-string (match-string 1))
- (state (cdr (assoc state-string state-map)))
- (filename (match-string 2)))
- (push (list filename state) result)))
-
- (funcall callback result nil)))
-
-(defun vc-arch-working-revision (file)
- (let* ((root (expand-file-name "{arch}" (vc-arch-root file)))
- (defbranch (vc-arch-default-version file)))
- (when (and defbranch (string-match "\\`\\(.+@[^/\n]+\\)/\\(\\(\\(.*?\\)\\(?:--.*\\)?\\)--.*\\)\\'" defbranch))
- (let* ((archive (match-string 1 defbranch))
- (category (match-string 4 defbranch))
- (branch (match-string 3 defbranch))
- (version (match-string 2 defbranch))
- (sealed nil) (rev-nb 0)
- (rev nil)
- logdir tmp)
- (setq logdir (expand-file-name category root))
- (setq logdir (expand-file-name branch logdir))
- (setq logdir (expand-file-name version logdir))
- (setq logdir (expand-file-name archive logdir))
- (setq logdir (expand-file-name "patch-log" logdir))
- (dolist (file (if (file-directory-p logdir) (directory-files logdir)))
- ;; Revision names go: base-0, patch-N, version-0, versionfix-M.
- (when (and (eq (aref file 0) ?v) (not sealed))
- (setq sealed t rev-nb 0))
- (if (and (string-match "-\\([0-9]+\\)\\'" file)
- (setq tmp (string-to-number (match-string 1 file)))
- (or (not sealed) (eq (aref file 0) ?v))
- (>= tmp rev-nb))
- (setq rev-nb tmp rev file)))
- ;; Use "none-000" if the tree hasn't yet been committed on the
- ;; default branch. We'll then get "Arch:000[branch]" on the mode-line.
- (concat defbranch "--" (or rev "none-000"))))))
-
-
-(defcustom vc-arch-mode-line-rewrite
- '(("\\`.*--\\(.*--.*\\)--\\(v?\\).*-\\([0-9]+\\)\\'" . "\\2\\3[\\1]"))
- "Rewrite rules to shorten Arch's revision names on the mode-line."
- :type '(repeat (cons regexp string))
- :group 'vc)
-
-(defun vc-arch-mode-line-string (file)
- "Return string for placement in modeline by `vc-mode-line' for FILE."
- (let ((rev (vc-working-revision file)))
- (dolist (rule vc-arch-mode-line-rewrite)
- (if (string-match (car rule) rev)
- (setq rev (replace-match (cdr rule) t nil rev))))
- (format "Arch%c%s"
- (case (vc-state file)
- ((up-to-date needs-update) ?-)
- (added ?@)
- (t ?:))
- rev)))
-
-(defun vc-arch-diff3-rej-p (rej)
- (let ((attrs (file-attributes rej)))
- (and attrs (< (nth 7 attrs) 60)
- (with-temp-buffer
- (insert-file-contents rej)
- (goto-char (point-min))
- (looking-at "Conflicts occured, diff3 conflict markers left in file\\.")))))
-
-(defun vc-arch-delete-rej-if-obsolete ()
- "For use in `after-save-hook'."
- (save-excursion
- (let ((rej (concat buffer-file-name ".rej")))
- (when (and buffer-file-name (vc-arch-diff3-rej-p rej))
- (unless (re-search-forward "^<<<<<<< " nil t)
- ;; The .rej file is obsolete.
- (condition-case nil (delete-file rej) (error nil))
- ;; Remove the hook so that it is not called multiple times.
- (remove-hook 'after-save-hook 'vc-arch-delete-rej-if-obsolete t))))))
-
-(defun vc-arch-find-file-hook ()
- (let ((rej (concat buffer-file-name ".rej")))
- (when (and buffer-file-name (file-exists-p rej))
- (if (vc-arch-diff3-rej-p rej)
- (save-excursion
- (goto-char (point-min))
- (if (not (re-search-forward "^<<<<<<< " nil t))
- ;; The .rej file is obsolete.
- (condition-case nil (delete-file rej) (error nil))
- (smerge-mode 1)
- (add-hook 'after-save-hook
- 'vc-arch-delete-rej-if-obsolete nil t)
- (message "There are unresolved conflicts in this file")))
- (message "There are unresolved conflicts in %s"
- (file-name-nondirectory rej))))))
-
-(defun vc-arch-checkin (files rev comment &optional extra-args-ignored)
- (if rev (error "Committing to a specific revision is unsupported"))
- ;; FIXME: This implementation probably only works for singleton filesets
- (let ((summary (file-relative-name (car files) (vc-arch-root (car files)))))
- ;; Extract a summary from the comment.
- (when (or (string-match "\\`Summary:[ \t]*\\(.*[^ \t\n]\\)\\([ \t]*\n\\)*" comment)
- (string-match "\\`[ \t]*\\(.*[^ \t\n]\\)[ \t]*\\(\n?\\'\\|\n\\([ \t]*\n\\)+\\)" comment))
- (setq summary (match-string 1 comment))
- (setq comment (substring comment (match-end 0))))
- (vc-arch-command nil 0 files "commit" "-s" summary "-L" comment "--"
- (vc-switches 'Arch 'checkin))))
-
-(defun vc-arch-diff (files &optional oldvers newvers buffer)
- "Get a difference report using Arch between two versions of FILES."
- ;; FIXME: This implementation only works for singleton filesets. To make
- ;; it work for more cases, we have to either call `file-diffs' manually on
- ;; each and every `file' in the fileset, or use `changes --diffs' (and
- ;; variants) and maybe filter the output with `filterdiff' to only include
- ;; the files in which we're interested.
- (let ((file (car files)))
- (if (and newvers
- (vc-up-to-date-p file)
- (equal newvers (vc-working-revision file)))
- ;; Newvers is the base revision and the current file is unchanged,
- ;; so we can diff with the current file.
- (setq newvers nil))
- (if newvers
- (error "Diffing specific revisions not implemented")
- (let* (process-file-side-effects
- (async (not vc-disable-async-diff))
- ;; Run the command from the root dir.
- (default-directory (vc-arch-root file))
- (status
- (vc-arch-command
- (or buffer "*vc-diff*")
- (if async 'async 1)
- nil "file-diffs"
- (vc-switches 'Arch 'diff)
- (file-relative-name file)
- (if (equal oldvers (vc-working-revision file))
- nil
- oldvers))))
- (if async 1 status))))) ; async diff, pessimistic assumption.
-
-(defun vc-arch-delete-file (file)
- (vc-arch-command nil 0 file "rm"))
-
-(defun vc-arch-rename-file (old new)
- (vc-arch-command nil 0 new "mv" (file-relative-name old)))
-
-(defalias 'vc-arch-responsible-p 'vc-arch-root)
-
-(defun vc-arch-command (buffer okstatus file &rest flags)
- "A wrapper around `vc-do-command' for use in vc-arch.el."
- (apply 'vc-do-command (or buffer "*vc*") okstatus vc-arch-program file flags))
-
-(defun vc-arch-init-revision () nil)
-
-;;; Completion of versions and revisions.
-
-(defun vc-arch--version-completion-table (root string)
- (delq nil
- (mapcar
- (lambda (d)
- (when (string-match "/\\([^/]+\\)/\\([^/]+\\)\\'" d)
- (concat (match-string 2 d) "/" (match-string 1 d))))
- (let ((default-directory root))
- (file-expand-wildcards
- (concat "*/*/"
- (if (string-match "/" string)
- (concat (substring string (match-end 0))
- "*/" (substring string 0 (match-beginning 0)))
- (concat "*/" string))
- "*"))))))
-
-(defun vc-arch-revision-completion-table (files)
- (lexical-let ((files files))
- (lambda (string pred action)
- ;; FIXME: complete revision patches as well.
- (let* ((root (expand-file-name "{arch}" (vc-arch-root (car files))))
- (table (vc-arch--version-completion-table root string)))
- (complete-with-action action table string pred)))))
-
-;;; Trimming revision libraries.
-
-;; This code is not directly related to VC and there are many variants of
-;; this functionality available as scripts, but I like this version better,
-;; so maybe others will like it too.
-
-(defun vc-arch-trim-find-least-useful-rev (revs)
- (let* ((first (pop revs))
- (second (pop revs))
- (third (pop revs))
- ;; We try to give more importance to recent revisions. The idea is
- ;; that it's OK if checking out a revision 1000-patch-old is ten
- ;; times slower than checking out a revision 100-patch-old. But at
- ;; the same time a 2-patch-old rev isn't really ten times more
- ;; important than a 20-patch-old, so we use an arbitrary constant
- ;; "100" to reduce this effect for recent revisions. Making this
- ;; constant a float has the side effect of causing the subsequent
- ;; computations to be done as floats as well.
- (max (+ 100.0 (car (or (car (last revs)) third))))
- (cost (lambda () (/ (- (car third) (car first)) (- max (car second)))))
- (minrev second)
- (mincost (funcall cost)))
- (while revs
- (setq first second)
- (setq second third)
- (setq third (pop revs))
- (when (< (funcall cost) mincost)
- (setq minrev second)
- (setq mincost (funcall cost))))
- minrev))
-
-(defun vc-arch-trim-make-sentinel (revs)
- (if (null revs) (lambda (proc msg) (message "VC-Arch trimming ... done"))
- (lexical-let ((revs revs))
- (lambda (proc msg)
- (message "VC-Arch trimming %s..." (file-name-nondirectory (car revs)))
- (rename-file (car revs) (concat (car revs) "*rm*"))
- (setq proc (start-process "vc-arch-trim" nil
- "rm" "-rf" (concat (car revs) "*rm*")))
- (set-process-sentinel proc (vc-arch-trim-make-sentinel (cdr revs)))))))
-
-(defun vc-arch-trim-one-revlib (dir)
- "Delete half of the revisions in the revision library."
- (interactive "Ddirectory: ")
- (let ((garbage (directory-files dir 'full "\\`,," 'nosort)))
- (when garbage
- (funcall (vc-arch-trim-make-sentinel garbage) nil nil)))
- (let ((revs
- (sort (delq nil
- (mapcar
- (lambda (f)
- (when (string-match "-\\([0-9]+\\)\\'" f)
- (cons (string-to-number (match-string 1 f)) f)))
- (directory-files dir nil nil 'nosort)))
- 'car-less-than-car))
- (subdirs nil))
- (when (cddr revs)
- (dotimes (i (/ (length revs) 2))
- (let ((minrev (vc-arch-trim-find-least-useful-rev revs)))
- (setq revs (delq minrev revs))
- (push minrev subdirs)))
- (funcall (vc-arch-trim-make-sentinel
- (mapcar (lambda (x) (expand-file-name (cdr x) dir)) subdirs))
- nil nil))))
-
-(defun vc-arch-trim-revlib ()
- "Delete half of the revisions in the revision library."
- (interactive)
- (let ((rl-dir (with-output-to-string
- (call-process vc-arch-program nil standard-output nil
- "my-revision-library"))))
- (while (string-match "\\(.*\\)\n" rl-dir)
- (let ((dir (match-string 1 rl-dir)))
- (setq rl-dir
- (if (and (file-directory-p dir) (file-writable-p dir))
- dir
- (substring rl-dir (match-end 0))))))
- (unless (file-writable-p rl-dir)
- (error "No writable revlib directory found"))
- (message "Revlib at %s" rl-dir)
- (let* ((archives (directory-files rl-dir 'full "[^.]\\|..."))
- (categories
- (apply 'append
- (mapcar (lambda (dir)
- (when (file-directory-p dir)
- (directory-files dir 'full "[^.]\\|...")))
- archives)))
- (branches
- (apply 'append
- (mapcar (lambda (dir)
- (when (file-directory-p dir)
- (directory-files dir 'full "[^.]\\|...")))
- categories)))
- (versions
- (apply 'append
- (mapcar (lambda (dir)
- (when (file-directory-p dir)
- (directory-files dir 'full "--.*--")))
- branches))))
- (mapc 'vc-arch-trim-one-revlib versions))
- ))
-
-(defvar vc-arch-extra-menu-map
- (let ((map (make-sparse-keymap)))
- (define-key map [add-tagline]
- '(menu-item "Add tagline" vc-arch-add-tagline))
- map))
-
-(defun vc-arch-extra-menu () vc-arch-extra-menu-map)
-
-
-;;; Less obvious implementations.
-
-(defun vc-arch-find-revision (file rev buffer)
- (let ((out (make-temp-file "vc-out")))
- (unwind-protect
- (progn
- (with-temp-buffer
- (vc-arch-command (current-buffer) 1 nil "file-diffs" file rev)
- (call-process-region (point-min) (point-max)
- "patch" nil nil nil "-R" "-o" out file))
- (with-current-buffer buffer
- (insert-file-contents out)))
- (delete-file out))))
-
-(provide 'vc-arch)
-
-;; arch-tag: a35c7c1c-5237-429d-88ef-3d718fd2e704
-;;; vc-arch.el ends here
+++ /dev/null
-;;; vc-bzr.el --- VC backend for the bzr revision control system
-
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Dave Love <fx@gnu.org>
-;; Riccardo Murri <riccardo.murri@gmail.com>
-;; Keywords: tools
-;; Created: Sept 2006
-;; Version: 2008-01-04 (Bzr revno 25)
-;; URL: http://launchpad.net/vc-bzr
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; See <URL:http://bazaar-vcs.org/> concerning bzr. See
-;; <URL:http://launchpad.net/vc-bzr> for alternate development
-;; branches of `vc-bzr'.
-
-;; Load this library to register bzr support in VC.
-
-;; Known bugs
-;; ==========
-
-;; When editing a symlink and *both* the symlink and its target
-;; are bzr-versioned, `vc-bzr` presently runs `bzr status` on the
-;; symlink, thereby not detecting whether the actual contents
-;; (that is, the target contents) are changed.
-;; See https://bugs.launchpad.net/vc-bzr/+bug/116607
-
-;; For an up-to-date list of bugs, please see:
-;; https://bugs.launchpad.net/vc-bzr/+bugs
-
-;;; Properties of the backend
-
-(defun vc-bzr-revision-granularity () 'repository)
-(defun vc-bzr-checkout-model (files) 'implicit)
-
-;;; Code:
-
-(eval-when-compile
- (require 'cl)
- (require 'vc) ;; for vc-exec-after
- (require 'vc-dir))
-
-;; Clear up the cache to force vc-call to check again and discover
-;; new functions when we reload this file.
-(put 'Bzr 'vc-functions nil)
-
-(defgroup vc-bzr nil
- "VC bzr backend."
- :version "22.2"
- :group 'vc)
-
-(defcustom vc-bzr-program "bzr"
- "Name of the bzr command (excluding any arguments)."
- :group 'vc-bzr
- :type 'string)
-
-(defcustom vc-bzr-diff-switches nil
- "String or list of strings specifying switches for bzr diff under VC.
-If nil, use the value of `vc-diff-switches'. If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :group 'vc-bzr)
-
-(defcustom vc-bzr-log-switches nil
- "String or list of strings specifying switches for bzr log under VC."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :group 'vc-bzr)
-
-;; since v0.9, bzr supports removing the progress indicators
-;; by setting environment variable BZR_PROGRESS_BAR to "none".
-(defun vc-bzr-command (bzr-command buffer okstatus file-or-list &rest args)
- "Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND.
-Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
-`LC_MESSAGES=C' to the environment."
- (let ((process-environment
- (list* "BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9)
- "LC_MESSAGES=C" ; Force English output
- process-environment)))
- (apply 'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program
- file-or-list bzr-command args)))
-
-
-;;;###autoload
-(defconst vc-bzr-admin-dirname ".bzr"
- "Name of the directory containing Bzr repository status files.")
-;;;###autoload
-(defconst vc-bzr-admin-checkout-format-file
- (concat vc-bzr-admin-dirname "/checkout/format"))
-(defconst vc-bzr-admin-dirstate
- (concat vc-bzr-admin-dirname "/checkout/dirstate"))
-(defconst vc-bzr-admin-branch-format-file
- (concat vc-bzr-admin-dirname "/branch/format"))
-(defconst vc-bzr-admin-revhistory
- (concat vc-bzr-admin-dirname "/branch/revision-history"))
-(defconst vc-bzr-admin-lastrev
- (concat vc-bzr-admin-dirname "/branch/last-revision"))
-
-;;;###autoload (defun vc-bzr-registered (file)
-;;;###autoload (if (vc-find-root file vc-bzr-admin-checkout-format-file)
-;;;###autoload (progn
-;;;###autoload (load "vc-bzr")
-;;;###autoload (vc-bzr-registered file))))
-
-(defun vc-bzr-root (file)
- "Return the root directory of the bzr repository containing FILE."
- ;; Cache technique copied from vc-arch.el.
- (or (vc-file-getprop file 'bzr-root)
- (let ((root (vc-find-root file vc-bzr-admin-checkout-format-file)))
- (when root (vc-file-setprop file 'bzr-root root)))))
-
-(require 'sha1) ;For sha1-program
-
-(defun vc-bzr-sha1 (file)
- (with-temp-buffer
- (set-buffer-multibyte nil)
- (let ((prog sha1-program)
- (args nil)
- process-file-side-effects)
- (when (consp prog)
- (setq args (cdr prog))
- (setq prog (car prog)))
- (apply 'process-file prog (file-relative-name file) t nil args)
- (buffer-substring (point-min) (+ (point-min) 40)))))
-
-(defun vc-bzr-state-heuristic (file)
- "Like `vc-bzr-state' but hopefully without running Bzr."
- ;; `bzr status' was excrutiatingly slow with large histories and
- ;; pending merges, so try to avoid using it until they fix their
- ;; performance problems.
- ;; This function tries first to parse Bzr internal file
- ;; `checkout/dirstate', but it may fail if Bzr internal file format
- ;; has changed. As a safeguard, the `checkout/dirstate' file is
- ;; only parsed if it contains the string `#bazaar dirstate flat
- ;; format 3' in the first line.
- ;; If the `checkout/dirstate' file cannot be parsed, fall back to
- ;; running `vc-bzr-state'."
- (lexical-let ((root (vc-bzr-root file)))
- (when root ; Short cut.
- ;; This looks at internal files. May break if they change
- ;; their format.
- (lexical-let ((dirstate (expand-file-name vc-bzr-admin-dirstate root)))
- (condition-case nil
- (with-temp-buffer
- (insert-file-contents dirstate)
- (goto-char (point-min))
- (if (not (looking-at "#bazaar dirstate flat format 3"))
- (vc-bzr-state file) ; Some other unknown format?
- (let* ((relfile (file-relative-name file root))
- (reldir (file-name-directory relfile)))
- (if (re-search-forward
- (concat "^\0"
- (if reldir (regexp-quote
- (directory-file-name reldir)))
- "\0"
- (regexp-quote (file-name-nondirectory relfile))
- "\0"
- "[^\0]*\0" ;id?
- "\\([^\0]*\\)\0" ;"a/f/d", a=removed?
- "\\([^\0]*\\)\0" ;sha1 (empty if conflicted)?
- "\\([^\0]*\\)\0" ;size?p
- "[^\0]*\0" ;"y/n", executable?
- "[^\0]*\0" ;?
- "\\([^\0]*\\)\0" ;"a/f/d" a=added?
- "\\([^\0]*\\)\0" ;sha1 again?
- "\\([^\0]*\\)\0" ;size again?
- "[^\0]*\0" ;"y/n", executable again?
- "[^\0]*\0" ;last revid?
- ;; There are more fields when merges are pending.
- )
- nil t)
- ;; Apparently the second sha1 is the one we want: when
- ;; there's a conflict, the first sha1 is absent (and the
- ;; first size seems to correspond to the file with
- ;; conflict markers).
- (cond
- ((eq (char-after (match-beginning 1)) ?a) 'removed)
- ((eq (char-after (match-beginning 4)) ?a) 'added)
- ((or (and (eq (string-to-number (match-string 3))
- (nth 7 (file-attributes file)))
- (equal (match-string 5)
- (vc-bzr-sha1 file)))
- (and
- ;; It looks like for lightweight
- ;; checkouts \2 is empty and we need to
- ;; look for size in \6.
- (eq (match-beginning 2) (match-end 2))
- (eq (string-to-number (match-string 6))
- (nth 7 (file-attributes file)))
- (equal (match-string 5)
- (vc-bzr-sha1 file))))
- 'up-to-date)
- (t 'edited))
- 'unregistered))))
- ;; Either the dirstate file can't be read, or the sha1
- ;; executable is missing, or ...
- ;; In either case, recent versions of Bzr aren't that slow
- ;; any more.
- (error (vc-bzr-state file)))))))
-
-
-(defun vc-bzr-registered (file)
- "Return non-nil if FILE is registered with bzr."
- (let ((state (vc-bzr-state-heuristic file)))
- (not (memq state '(nil unregistered ignored)))))
-
-(defconst vc-bzr-state-words
- "added\\|ignored\\|kind changed\\|modified\\|removed\\|renamed\\|unknown"
- "Regexp matching file status words as reported in `bzr' output.")
-
-(defun vc-bzr-file-name-relative (filename)
- "Return file name FILENAME stripped of the initial Bzr repository path."
- (lexical-let*
- ((filename* (expand-file-name filename))
- (rootdir (vc-bzr-root filename*)))
- (when rootdir
- (file-relative-name filename* rootdir))))
-
-(defun vc-bzr-status (file)
- "Return FILE status according to Bzr.
-Return value is a cons (STATUS . WARNING), where WARNING is a
-string or nil, and STATUS is one of the symbols: `added',
-`ignored', `kindchanged', `modified', `removed', `renamed', `unknown',
-which directly correspond to `bzr status' output, or 'unchanged
-for files whose copy in the working tree is identical to the one
-in the branch repository, or nil for files that are not
-registered with Bzr.
-
-If any error occurred in running `bzr status', then return nil."
- (with-temp-buffer
- (let ((ret (condition-case nil
- (vc-bzr-command "status" t 0 file)
- (file-error nil))) ; vc-bzr-program not found.
- (status 'unchanged))
- ;; the only secure status indication in `bzr status' output
- ;; is a couple of lines following the pattern::
- ;; | <status>:
- ;; | <file name>
- ;; if the file is up-to-date, we get no status report from `bzr',
- ;; so if the regexp search for the above pattern fails, we consider
- ;; the file to be up-to-date.
- (goto-char (point-min))
- (when (re-search-forward
- ;; bzr prints paths relative to the repository root.
- (concat "^\\(" vc-bzr-state-words "\\):[ \t\n]+"
- (regexp-quote (vc-bzr-file-name-relative file))
- ;; Bzr appends a '/' to directory names and
- ;; '*' to executable files
- (if (file-directory-p file) "/?" "\\*?")
- "[ \t\n]*$")
- nil t)
- (lexical-let ((statusword (match-string 1)))
- ;; Erase the status text that matched.
- (delete-region (match-beginning 0) (match-end 0))
- (setq status
- (intern (replace-regexp-in-string " " "" statusword)))))
- (when status
- (goto-char (point-min))
- (skip-chars-forward " \n\t") ;Throw away spaces.
- (cons status
- ;; "bzr" will output warnings and informational messages to
- ;; stderr; due to Emacs' `vc-do-command' (and, it seems,
- ;; `start-process' itself) limitations, we cannot catch stderr
- ;; and stdout into different buffers. So, if there's anything
- ;; left in the buffer after removing the above status
- ;; keywords, let us just presume that any other message from
- ;; "bzr" is a user warning, and display it.
- (unless (eobp) (buffer-substring (point) (point-max))))))))
-
-(defun vc-bzr-state (file)
- (lexical-let ((result (vc-bzr-status file)))
- (when (consp result)
- (when (cdr result)
- (message "Warnings in `bzr' output: %s" (cdr result)))
- (cdr (assq (car result)
- '((added . added)
- (kindchanged . edited)
- (renamed . edited)
- (modified . edited)
- (removed . removed)
- (ignored . ignored)
- (unknown . unregistered)
- (unchanged . up-to-date)))))))
-
-(defun vc-bzr-resolve-when-done ()
- "Call \"bzr resolve\" if the conflict markers have been removed."
- (save-excursion
- (goto-char (point-min))
- (unless (re-search-forward "^<<<<<<< " nil t)
- (vc-bzr-command "resolve" nil 0 buffer-file-name)
- ;; Remove the hook so that it is not called multiple times.
- (remove-hook 'after-save-hook 'vc-bzr-resolve-when-done t))))
-
-(defun vc-bzr-find-file-hook ()
- (when (and buffer-file-name
- ;; FIXME: We should check that "bzr status" says "conflict".
- (file-exists-p (concat buffer-file-name ".BASE"))
- (file-exists-p (concat buffer-file-name ".OTHER"))
- (file-exists-p (concat buffer-file-name ".THIS"))
- ;; If "bzr status" says there's a conflict but there are no
- ;; conflict markers, it's not clear what we should do.
- (save-excursion
- (goto-char (point-min))
- (re-search-forward "^<<<<<<< " nil t)))
- ;; TODO: the merge algorithm used in `bzr merge' is nicely configurable,
- ;; but the one in `bzr pull' isn't, so it would be good to provide an
- ;; elisp function to remerge from the .BASE/OTHER/THIS files.
- (smerge-start-session)
- (add-hook 'after-save-hook 'vc-bzr-resolve-when-done nil t)
- (message "There are unresolved conflicts in this file")))
-
-(defun vc-bzr-workfile-unchanged-p (file)
- (eq 'unchanged (car (vc-bzr-status file))))
-
-(defun vc-bzr-working-revision (file)
- ;; Together with the code in vc-state-heuristic, this makes it possible
- ;; to get the initial VC state of a Bzr file even if Bzr is not installed.
- (lexical-let*
- ((rootdir (vc-bzr-root file))
- (branch-format-file (expand-file-name vc-bzr-admin-branch-format-file
- rootdir))
- (revhistory-file (expand-file-name vc-bzr-admin-revhistory rootdir))
- (lastrev-file (expand-file-name vc-bzr-admin-lastrev rootdir)))
- ;; This looks at internal files to avoid forking a bzr process.
- ;; May break if they change their format.
- (if (and (file-exists-p branch-format-file)
- ;; For lightweight checkouts (obtained with bzr checkout --lightweight)
- ;; the branch-format-file does not contain the revision
- ;; information, we need to look up the branch-format-file
- ;; in the place where the lightweight checkout comes
- ;; from. We only do that if it's a local file.
- (let ((location-fname (expand-file-name
- (concat vc-bzr-admin-dirname
- "/branch/location") rootdir)))
- ;; The existence of this file is how we distinguish
- ;; lightweight checkouts.
- (if (file-exists-p location-fname)
- (with-temp-buffer
- (insert-file-contents location-fname)
- ;; If the lightweight checkout points to a
- ;; location in the local file system, then we can
- ;; look there for the version information.
- (when (re-search-forward "file://\\(.+\\)" nil t)
- (let ((l-c-parent-dir (match-string 1)))
- (when (and (memq system-type '(ms-dos windows-nt))
- (string-match-p "^/[[:alpha:]]:" l-c-parent-dir))
- ;;; The non-Windows code takes a shortcut by using the host/path
- ;;; separator slash as the start of the absolute path. That
- ;;; does not work on Windows, so we must remove it (bug#5345)
- (setq l-c-parent-dir (substring l-c-parent-dir 1)))
- (setq branch-format-file
- (expand-file-name vc-bzr-admin-branch-format-file
- l-c-parent-dir))
- (setq lastrev-file
- (expand-file-name vc-bzr-admin-lastrev l-c-parent-dir))
- ;; FIXME: maybe it's overkill to check if both these files exist.
- (and (file-exists-p branch-format-file)
- (file-exists-p lastrev-file)))))
- t)))
- (with-temp-buffer
- (insert-file-contents branch-format-file)
- (goto-char (point-min))
- (cond
- ((or
- (looking-at "Bazaar-NG branch, format 0.0.4")
- (looking-at "Bazaar-NG branch format 5"))
- ;; count lines in .bzr/branch/revision-history
- (insert-file-contents revhistory-file)
- (number-to-string (count-lines (line-end-position) (point-max))))
- ((or
- (looking-at "Bazaar Branch Format 6 (bzr 0.15)")
- (looking-at "Bazaar Branch Format 7 (needs bzr 1.6)"))
- ;; revno is the first number in .bzr/branch/last-revision
- (insert-file-contents lastrev-file)
- (when (re-search-forward "[0-9]+" nil t)
- (buffer-substring (match-beginning 0) (match-end 0))))))
- ;; fallback to calling "bzr revno"
- (lexical-let*
- ((result (vc-bzr-command-discarding-stderr
- vc-bzr-program "revno" (file-relative-name file)))
- (exitcode (car result))
- (output (cdr result)))
- (cond
- ((eq exitcode 0) (substring output 0 -1))
- (t nil))))))
-
-(defun vc-bzr-create-repo ()
- "Create a new Bzr repository."
- (vc-bzr-command "init" nil 0 nil))
-
-(defun vc-bzr-init-revision (&optional file)
- "Always return nil, as Bzr cannot register explicit versions."
- nil)
-
-(defun vc-bzr-previous-revision (file rev)
- (if (string-match "\\`[0-9]+\\'" rev)
- (number-to-string (1- (string-to-number rev)))
- (concat "before:" rev)))
-
-(defun vc-bzr-next-revision (file rev)
- (if (string-match "\\`[0-9]+\\'" rev)
- (number-to-string (1+ (string-to-number rev)))
- (error "Don't know how to compute the next revision of %s" rev)))
-
-(defun vc-bzr-register (files &optional rev comment)
- "Register FILE under bzr.
-Signal an error unless REV is nil.
-COMMENT is ignored."
- (if rev (error "Can't register explicit revision with bzr"))
- (vc-bzr-command "add" nil 0 files))
-
-;; Could run `bzr status' in the directory and see if it succeeds, but
-;; that's relatively expensive.
-(defalias 'vc-bzr-responsible-p 'vc-bzr-root
- "Return non-nil if FILE is (potentially) controlled by bzr.
-The criterion is that there is a `.bzr' directory in the same
-or a superior directory.")
-
-(defun vc-bzr-could-register (file)
- "Return non-nil if FILE could be registered under bzr."
- (and (vc-bzr-responsible-p file) ; shortcut
- (condition-case ()
- (with-temp-buffer
- (vc-bzr-command "add" t 0 file "--dry-run")
- ;; The command succeeds with no output if file is
- ;; registered (in bzr 0.8).
- (goto-char (point-min))
- (looking-at "added "))
- (error))))
-
-(defun vc-bzr-unregister (file)
- "Unregister FILE from bzr."
- (vc-bzr-command "remove" nil 0 file "--keep"))
-
-(declare-function log-edit-extract-headers "log-edit" (headers string))
-
-(defun vc-bzr-checkin (files rev comment)
- "Check FILE in to bzr with log message COMMENT.
-REV non-nil gets an error."
- (if rev (error "Can't check in a specific revision with bzr"))
- (apply 'vc-bzr-command "commit" nil 0
- files (cons "-m" (log-edit-extract-headers '(("Author" . "--author")
- ("Date" . "--commit-time")
- ("Fixes" . "--fixes"))
- comment))))
-
-(defun vc-bzr-find-revision (file rev buffer)
- "Fetch revision REV of file FILE and put it into BUFFER."
- (with-current-buffer buffer
- (if (and rev (stringp rev) (not (string= rev "")))
- (vc-bzr-command "cat" t 0 file "-r" rev)
- (vc-bzr-command "cat" t 0 file))))
-
-(defun vc-bzr-checkout (file &optional editable rev)
- (if rev (error "Operation not supported")
- ;; Else, there's nothing to do.
- nil))
-
-(defun vc-bzr-revert (file &optional contents-done)
- (unless contents-done
- (with-temp-buffer (vc-bzr-command "revert" t 0 file))))
-
-(defvar log-view-message-re)
-(defvar log-view-file-re)
-(defvar log-view-font-lock-keywords)
-(defvar log-view-current-tag-function)
-(defvar log-view-per-file-logs)
-
-(define-derived-mode vc-bzr-log-view-mode log-view-mode "Bzr-Log-View"
- (remove-hook 'log-view-mode-hook 'vc-bzr-log-view-mode) ;Deactivate the hack.
- (require 'add-log)
- (set (make-local-variable 'log-view-per-file-logs) nil)
- (set (make-local-variable 'log-view-file-re) "\\`a\\`")
- (set (make-local-variable 'log-view-message-re)
- (if (eq vc-log-view-type 'short)
- "^ *\\([0-9.]+\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)\\( \\[merge\\]\\)?"
- "^ *\\(?:revno: \\([0-9.]+\\)\\|merged: .+\\)"))
- (set (make-local-variable 'log-view-font-lock-keywords)
- ;; log-view-font-lock-keywords is careful to use the buffer-local
- ;; value of log-view-message-re only since Emacs-23.
- (if (eq vc-log-view-type 'short)
- (append `((,log-view-message-re
- (1 'log-view-message-face)
- (2 'change-log-name)
- (3 'change-log-date)
- (4 'change-log-list nil lax))))
- (append `((,log-view-message-re . 'log-view-message-face))
- ;; log-view-font-lock-keywords
- '(("^ *\\(?:committer\\|author\\): \
-\\([^<(]+?\\)[ ]*[(<]\\([[:alnum:]_.+-]+@[[:alnum:]_.-]+\\)[>)]"
- (1 'change-log-name)
- (2 'change-log-email))
- ("^ *timestamp: \\(.*\\)" (1 'change-log-date-face)))))))
-
-(defun vc-bzr-print-log (files buffer &optional shortlog start-revision limit)
- "Get bzr change log for FILES into specified BUFFER."
- ;; `vc-do-command' creates the buffer, but we need it before running
- ;; the command.
- (vc-setup-buffer buffer)
- ;; If the buffer exists from a previous invocation it might be
- ;; read-only.
- ;; FIXME: `vc-bzr-command' runs `bzr log' with `LC_MESSAGES=C', so
- ;; the log display may not what the user wants - but I see no other
- ;; way of getting the above regexps working.
- (with-current-buffer buffer
- (apply 'vc-bzr-command "log" buffer 'async files
- (append
- (when shortlog '("--line"))
- (when start-revision (list (format "-r..%s" start-revision)))
- (when limit (list "-l" (format "%s" limit)))
- (if (stringp vc-bzr-log-switches)
- (list vc-bzr-log-switches)
- vc-bzr-log-switches)))))
-
-(defun vc-bzr-log-incoming (buffer remote-location)
- (apply 'vc-bzr-command "missing" buffer 'async nil
- (list "--theirs-only" (unless (string= remote-location "") remote-location))))
-
-(defun vc-bzr-log-outgoing (buffer remote-location)
- (apply 'vc-bzr-command "missing" buffer 'async nil
- (list "--mine-only" (unless (string= remote-location "") remote-location))))
-
-(defun vc-bzr-show-log-entry (revision)
- "Find entry for patch name REVISION in bzr change log buffer."
- (goto-char (point-min))
- (when revision
- (let (case-fold-search
- found)
- (if (re-search-forward
- ;; "revno:" can appear either at the beginning of a line,
- ;; or indented.
- (concat "^[ ]*-+\n[ ]*revno: "
- ;; The revision can contain ".", quote it so that it
- ;; does not interfere with regexp matching.
- (regexp-quote revision) "$") nil t)
- (progn
- (beginning-of-line 0)
- (setq found t))
- (goto-char (point-min)))
- found)))
-
-(defun vc-bzr-diff (files &optional rev1 rev2 buffer)
- "VC bzr backend for diff."
- ;; `bzr diff' exits with code 1 if diff is non-empty.
- (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*")
- (if vc-disable-async-diff 1 'async) files
- "--diff-options" (mapconcat 'identity
- (vc-switches 'bzr 'diff)
- " ")
- ;; This `when' is just an optimization because bzr-1.2 is *much*
- ;; faster when the revision argument is not given.
- (when (or rev1 rev2)
- (list "-r" (format "%s..%s"
- (or rev1 "revno:-1")
- (or rev2 ""))))))
-
-
-;; FIXME: vc-{next,previous}-revision need fixing in vc.el to deal with
-;; straight integer revisions.
-
-(defun vc-bzr-delete-file (file)
- "Delete FILE and delete it in the bzr repository."
- (condition-case ()
- (delete-file file)
- (file-error nil))
- (vc-bzr-command "remove" nil 0 file))
-
-(defun vc-bzr-rename-file (old new)
- "Rename file from OLD to NEW using `bzr mv'."
- (vc-bzr-command "mv" nil 0 new old))
-
-(defvar vc-bzr-annotation-table nil
- "Internal use.")
-(make-variable-buffer-local 'vc-bzr-annotation-table)
-
-(defun vc-bzr-annotate-command (file buffer &optional revision)
- "Prepare BUFFER for `vc-annotate' on FILE.
-Each line is tagged with the revision number, which has a `help-echo'
-property containing author and date information."
- (apply #'vc-bzr-command "annotate" buffer 'async file "--long" "--all"
- (if revision (list "-r" revision)))
- (lexical-let ((table (make-hash-table :test 'equal)))
- (set-process-filter
- (get-buffer-process buffer)
- (lambda (proc string)
- (when (process-buffer proc)
- (with-current-buffer (process-buffer proc)
- (setq string (concat (process-get proc :vc-left-over) string))
- (while (string-match "^\\( *[0-9.]+ *\\) \\([^\n ]+\\) +\\([0-9]\\{8\\}\\)\\( |.*\n\\)" string)
- (let* ((rev (match-string 1 string))
- (author (match-string 2 string))
- (date (match-string 3 string))
- (key (substring string (match-beginning 0)
- (match-beginning 4)))
- (line (match-string 4 string))
- (tag (gethash key table))
- (inhibit-read-only t))
- (setq string (substring string (match-end 0)))
- (unless tag
- (setq tag
- (propertize
- (format "%s %-7.7s" rev author)
- 'help-echo (format "Revision: %d, author: %s, date: %s"
- (string-to-number rev)
- author date)
- 'mouse-face 'highlight))
- (puthash key tag table))
- (goto-char (process-mark proc))
- (insert tag line)
- (move-marker (process-mark proc) (point))))
- (process-put proc :vc-left-over string)))))))
-
-(declare-function vc-annotate-convert-time "vc-annotate" (time))
-
-(defun vc-bzr-annotate-time ()
- (when (re-search-forward "^ *[0-9.]+ +[^\n ]* +|" nil t)
- (let ((prop (get-text-property (line-beginning-position) 'help-echo)))
- (string-match "[0-9]+\\'" prop)
- (let ((str (match-string-no-properties 0 prop)))
- (vc-annotate-convert-time
- (encode-time 0 0 0
- (string-to-number (substring str 6 8))
- (string-to-number (substring str 4 6))
- (string-to-number (substring str 0 4))))))))
-
-(defun vc-bzr-annotate-extract-revision-at-line ()
- "Return revision for current line of annoation buffer, or nil.
-Return nil if current line isn't annotated."
- (save-excursion
- (beginning-of-line)
- (if (looking-at "^ *\\([0-9.]+\\) +[^\n ]* +|")
- (match-string-no-properties 1))))
-
-(defun vc-bzr-command-discarding-stderr (command &rest args)
- "Execute shell command COMMAND (with ARGS); return its output and exitcode.
-Return value is a cons (EXITCODE . OUTPUT), where EXITCODE is
-the (numerical) exit code of the process, and OUTPUT is a string
-containing whatever the process sent to its standard output
-stream. Standard error output is discarded."
- (with-temp-buffer
- (cons
- (apply #'process-file command nil (list (current-buffer) nil) nil args)
- (buffer-substring (point-min) (point-max)))))
-
-(defstruct (vc-bzr-extra-fileinfo
- (:copier nil)
- (:constructor vc-bzr-create-extra-fileinfo (extra-name))
- (:conc-name vc-bzr-extra-fileinfo->))
- extra-name) ;; original name for rename targets, new name for
-
-(defun vc-bzr-dir-printer (info)
- "Pretty-printer for the vc-dir-fileinfo structure."
- (let ((extra (vc-dir-fileinfo->extra info)))
- (vc-default-dir-printer 'Bzr info)
- (when extra
- (insert (propertize
- (format " (renamed from %s)"
- (vc-bzr-extra-fileinfo->extra-name extra))
- 'face 'font-lock-comment-face)))))
-
-;; FIXME: this needs testing, it's probably incomplete.
-(defun vc-bzr-after-dir-status (update-function relative-dir)
- (let ((status-str nil)
- (translation '(("+N " . added)
- ("-D " . removed)
- (" M " . edited) ;; file text modified
- (" *" . edited) ;; execute bit changed
- (" M*" . edited) ;; text modified + execute bit changed
- ;; FIXME: what about ignored files?
- (" D " . missing)
- ;; For conflicts, should we list the .THIS/.BASE/.OTHER?
- ("C " . conflict)
- ("? " . unregistered)
- ;; No such state, but we need to distinguish this case.
- ("R " . renamed)
- ("RM " . renamed)
- ;; For a non existent file FOO, the output is:
- ;; bzr: ERROR: Path(s) do not exist: FOO
- ("bzr" . not-found)
- ;; If the tree is not up to date, bzr will print this warning:
- ;; working tree is out of date, run 'bzr update'
- ;; ignore it.
- ;; FIXME: maybe this warning can be put in the vc-dir header...
- ("wor" . not-found)
- ;; Ignore "P " and "P." for pending patches.
- ("P " . not-found)
- ("P. " . not-found)
- ))
- (translated nil)
- (result nil))
- (goto-char (point-min))
- (while (not (eobp))
- (setq status-str
- (buffer-substring-no-properties (point) (+ (point) 3)))
- (setq translated (cdr (assoc status-str translation)))
- (cond
- ((eq translated 'conflict)
- ;; For conflicts the file appears twice in the listing: once
- ;; with the M flag and once with the C flag, so take care
- ;; not to add it twice to `result'. Ugly.
- (let* ((file
- (buffer-substring-no-properties
- ;;For files with conflicts the format is:
- ;;C Text conflict in FILENAME
- ;; Bah.
- (+ (point) 21) (line-end-position)))
- (entry (assoc file result)))
- (when entry
- (setf (nth 1 entry) 'conflict))))
- ((eq translated 'renamed)
- (re-search-forward "R[ M] \\(.*\\) => \\(.*\\)$" (line-end-position) t)
- (let ((new-name (file-relative-name (match-string 2) relative-dir))
- (old-name (file-relative-name (match-string 1) relative-dir)))
- (push (list new-name 'edited
- (vc-bzr-create-extra-fileinfo old-name)) result)))
- ;; do nothing for non existent files
- ((eq translated 'not-found))
- (t
- (push (list (file-relative-name
- (buffer-substring-no-properties
- (+ (point) 4)
- (line-end-position)) relative-dir)
- translated) result)))
- (forward-line))
- (funcall update-function result)))
-
-(defun vc-bzr-dir-status (dir update-function)
- "Return a list of conses (file . state) for DIR."
- (vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S")
- (vc-exec-after
- `(vc-bzr-after-dir-status (quote ,update-function)
- ;; "bzr status" results are relative to
- ;; the bzr root directory, NOT to the
- ;; directory "bzr status" was invoked in.
- ;; Ugh.
- ;; We pass the relative directory here so
- ;; that `vc-bzr-after-dir-status' can
- ;; frob the results accordingly.
- (file-relative-name ,dir (vc-bzr-root ,dir)))))
-
-(defun vc-bzr-dir-status-files (dir files default-state update-function)
- "Return a list of conses (file . state) for DIR."
- (apply 'vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S" files)
- (vc-exec-after
- `(vc-bzr-after-dir-status (quote ,update-function)
- (file-relative-name ,dir (vc-bzr-root ,dir)))))
-
-(defvar vc-bzr-shelve-map
- (let ((map (make-sparse-keymap)))
- ;; Turn off vc-dir marking
- (define-key map [mouse-2] 'ignore)
-
- (define-key map [down-mouse-3] 'vc-bzr-shelve-menu)
- (define-key map "\C-k" 'vc-bzr-shelve-delete-at-point)
- (define-key map "=" 'vc-bzr-shelve-show-at-point)
- (define-key map "\C-m" 'vc-bzr-shelve-show-at-point)
- (define-key map "A" 'vc-bzr-shelve-apply-and-keep-at-point)
- (define-key map "P" 'vc-bzr-shelve-apply-at-point)
- (define-key map "S" 'vc-bzr-shelve-snapshot)
- map))
-
-(defvar vc-bzr-shelve-menu-map
- (let ((map (make-sparse-keymap "Bzr Shelve")))
- (define-key map [de]
- '(menu-item "Delete shelf" vc-bzr-shelve-delete-at-point
- :help "Delete the current shelf"))
- (define-key map [ap]
- '(menu-item "Apply and keep shelf" vc-bzr-shelve-apply-and-keep-at-point
- :help "Apply the current shelf and keep it"))
- (define-key map [po]
- '(menu-item "Apply and remove shelf (pop)" vc-bzr-shelve-apply-at-point
- :help "Apply the current shelf and remove it"))
- (define-key map [sh]
- '(menu-item "Show shelve" vc-bzr-shelve-show-at-point
- :help "Show the contents of the current shelve"))
- map))
-
-(defvar vc-bzr-extra-menu-map
- (let ((map (make-sparse-keymap)))
- (define-key map [bzr-sn]
- '(menu-item "Shelve a snapshot" vc-bzr-shelve-snapshot
- :help "Shelve the current state of the tree and keep the current state"))
- (define-key map [bzr-sh]
- '(menu-item "Shelve..." vc-bzr-shelve
- :help "Shelve changes"))
- map))
-
-(defun vc-bzr-extra-menu () vc-bzr-extra-menu-map)
-
-(defun vc-bzr-extra-status-menu () vc-bzr-extra-menu-map)
-
-(defun vc-bzr-dir-extra-headers (dir)
- (let*
- ((str (with-temp-buffer
- (vc-bzr-command "info" t 0 dir)
- (buffer-string)))
- (shelve (vc-bzr-shelve-list))
- (shelve-help-echo "Use M-x vc-bzr-shelve to create shelves")
- (root-dir (vc-bzr-root dir))
- (pending-merge
- ;; FIXME: looking for .bzr/checkout/merge-hashes is not a
- ;; reliable method to detect pending merges, disable this
- ;; until a proper solution is implemented.
- (and nil
- (file-exists-p
- (expand-file-name ".bzr/checkout/merge-hashes" root-dir))))
- (pending-merge-help-echo
- (format "A merge has been performed.\nA commit from the top-level directory (%s)\nis required before being able to check in anything else" root-dir))
- (light-checkout
- (when (string-match ".+light checkout root: \\(.+\\)$" str)
- (match-string 1 str)))
- (light-checkout-branch
- (when light-checkout
- (when (string-match ".+checkout of branch: \\(.+\\)$" str)
- (match-string 1 str)))))
- (concat
- (propertize "Parent branch : " 'face 'font-lock-type-face)
- (propertize
- (if (string-match "parent branch: \\(.+\\)$" str)
- (match-string 1 str)
- "None")
- 'face 'font-lock-variable-name-face)
- "\n"
- (when light-checkout
- (concat
- (propertize "Light checkout root: " 'face 'font-lock-type-face)
- (propertize light-checkout 'face 'font-lock-variable-name-face)
- "\n"))
- (when light-checkout-branch
- (concat
- (propertize "Checkout of branch : " 'face 'font-lock-type-face)
- (propertize light-checkout-branch 'face 'font-lock-variable-name-face)
- "\n"))
- (when pending-merge
- (concat
- (propertize "Warning : " 'face 'font-lock-warning-face
- 'help-echo pending-merge-help-echo)
- (propertize "Pending merges, commit recommended before any other action"
- 'help-echo pending-merge-help-echo
- 'face 'font-lock-warning-face)
- "\n"))
- (if shelve
- (concat
- (propertize "Shelves :\n" 'face 'font-lock-type-face
- 'help-echo shelve-help-echo)
- (mapconcat
- (lambda (x)
- (propertize x
- 'face 'font-lock-variable-name-face
- 'mouse-face 'highlight
- 'help-echo "mouse-3: Show shelve menu\nA: Apply and keep shelf\nP: Apply and remove shelf (pop)\nS: Snapshot to a shelf\nC-k: Delete shelf"
- 'keymap vc-bzr-shelve-map))
- shelve "\n"))
- (concat
- (propertize "Shelves : " 'face 'font-lock-type-face
- 'help-echo shelve-help-echo)
- (propertize "No shelved changes"
- 'help-echo shelve-help-echo
- 'face 'font-lock-variable-name-face))))))
-
-(defun vc-bzr-shelve (name)
- "Create a shelve."
- (interactive "sShelf name: ")
- (let ((root (vc-bzr-root default-directory)))
- (when root
- (vc-bzr-command "shelve" nil 0 nil "--all" "-m" name)
- (vc-resynch-buffer root t t))))
-
-(defun vc-bzr-shelve-show (name)
- "Show the contents of shelve NAME."
- (interactive "sShelve name: ")
- (vc-setup-buffer "*vc-diff*")
- ;; FIXME: how can you show the contents of a shelf?
- (vc-bzr-command "unshelve" "*vc-diff*" 'async nil "--preview" name)
- (set-buffer "*vc-diff*")
- (diff-mode)
- (setq buffer-read-only t)
- (pop-to-buffer (current-buffer)))
-
-(defun vc-bzr-shelve-apply (name)
- "Apply shelve NAME and remove it afterwards."
- (interactive "sApply (and remove) shelf: ")
- (vc-bzr-command "unshelve" nil 0 nil "--apply" name)
- (vc-resynch-buffer (vc-bzr-root default-directory) t t))
-
-(defun vc-bzr-shelve-apply-and-keep (name)
- "Apply shelve NAME and keep it afterwards."
- (interactive "sApply (and keep) shelf: ")
- (vc-bzr-command "unshelve" nil 0 nil "--apply" "--keep" name)
- (vc-resynch-buffer (vc-bzr-root default-directory) t t))
-
-(defun vc-bzr-shelve-snapshot ()
- "Create a stash with the current tree state."
- (interactive)
- (vc-bzr-command "shelve" nil 0 nil "--all" "-m"
- (let ((ct (current-time)))
- (concat
- (format-time-string "Snapshot on %Y-%m-%d" ct)
- (format-time-string " at %H:%M" ct))))
- (vc-bzr-command "unshelve" nil 0 nil "--apply" "--keep")
- (vc-resynch-buffer (vc-bzr-root default-directory) t t))
-
-(defun vc-bzr-shelve-list ()
- (with-temp-buffer
- (vc-bzr-command "shelve" (current-buffer) 1 nil "--list" "-q")
- (delete
- ""
- (split-string
- (buffer-substring (point-min) (point-max))
- "\n"))))
-
-(defun vc-bzr-shelve-get-at-point (point)
- (save-excursion
- (goto-char point)
- (beginning-of-line)
- (if (looking-at "^ +\\([0-9]+\\):")
- (match-string 1)
- (error "Cannot find shelf at point"))))
-
-(defun vc-bzr-shelve-delete-at-point ()
- (interactive)
- (let ((shelve (vc-bzr-shelve-get-at-point (point))))
- (when (y-or-n-p (format "Remove shelf %s ?" shelve))
- (vc-bzr-command "unshelve" nil 0 nil "--delete-only" shelve)
- (vc-dir-refresh))))
-
-(defun vc-bzr-shelve-show-at-point ()
- (interactive)
- (vc-bzr-shelve-show (vc-bzr-shelve-get-at-point (point))))
-
-(defun vc-bzr-shelve-apply-at-point ()
- (interactive)
- (vc-bzr-shelve-apply (vc-bzr-shelve-get-at-point (point))))
-
-(defun vc-bzr-shelve-apply-and-keep-at-point ()
- (interactive)
- (vc-bzr-shelve-apply-and-keep (vc-bzr-shelve-get-at-point (point))))
-
-(defun vc-bzr-shelve-menu (e)
- (interactive "e")
- (vc-dir-at-event e (popup-menu vc-bzr-shelve-menu-map e)))
-
-(defun vc-bzr-revision-table (files)
- (let ((vc-bzr-revisions '())
- (default-directory (file-name-directory (car files))))
- (with-temp-buffer
- (vc-bzr-command "log" t 0 files "--line")
- (let ((start (point-min))
- (loglines (buffer-substring-no-properties (point-min) (point-max))))
- (while (string-match "^\\([0-9]+\\):" loglines)
- (push (match-string 1 loglines) vc-bzr-revisions)
- (setq start (+ start (match-end 0)))
- (setq loglines (buffer-substring-no-properties start (point-max))))))
- vc-bzr-revisions))
-
-(defun vc-bzr-conflicted-files (dir)
- (let ((default-directory (vc-bzr-root dir))
- (files ()))
- (with-temp-buffer
- (vc-bzr-command "status" t 0 default-directory)
- (goto-char (point-min))
- (when (re-search-forward "^conflicts:\n" nil t)
- (while (looking-at " \\(?:Text conflict in \\(.*\\)\\|.*\\)\n")
- (if (match-end 1)
- (push (expand-file-name (match-string 1)) files))
- (goto-char (match-end 0)))))
- files))
-
-;;; Revision completion
-
-(eval-and-compile
- (defconst vc-bzr-revision-keywords
- '("revno" "revid" "last" "before"
- "tag" "date" "ancestor" "branch" "submit")))
-
-(defun vc-bzr-revision-completion-table (files)
- (lexical-let ((files files))
- ;; What about using `files'?!? --Stef
- (lambda (string pred action)
- (cond
- ((string-match "\\`\\(ancestor\\|branch\\|\\(revno:\\)?[-0-9]+:\\):"
- string)
- (completion-table-with-context (substring string 0 (match-end 0))
- (apply-partially
- 'completion-table-with-predicate
- 'completion-file-name-table
- 'file-directory-p t)
- (substring string (match-end 0))
- pred
- action))
- ((string-match "\\`\\(before\\):" string)
- (completion-table-with-context (substring string 0 (match-end 0))
- (vc-bzr-revision-completion-table files)
- (substring string (match-end 0))
- pred
- action))
- ((string-match "\\`\\(tag\\):" string)
- (let ((prefix (substring string 0 (match-end 0)))
- (tag (substring string (match-end 0)))
- (table nil)
- process-file-side-effects)
- (with-temp-buffer
- ;; "bzr-1.2 tags" is much faster with --show-ids.
- (process-file vc-bzr-program nil '(t) nil "tags" "--show-ids")
- ;; The output is ambiguous, unless we assume that revids do not
- ;; contain spaces.
- (goto-char (point-min))
- (while (re-search-forward "^\\(.*[^ \n]\\) +[^ \n]*$" nil t)
- (push (match-string-no-properties 1) table)))
- (completion-table-with-context prefix table tag pred action)))
-
- ((string-match "\\`\\([a-z]+\\):" string)
- ;; no actual completion for the remaining keywords.
- (completion-table-with-context (substring string 0 (match-end 0))
- (if (member (match-string 1 string)
- vc-bzr-revision-keywords)
- ;; If it's a valid keyword,
- ;; use a non-empty table to
- ;; indicate it.
- '("") nil)
- (substring string (match-end 0))
- pred
- action))
- (t
- ;; Could use completion-table-with-terminator, except that it
- ;; currently doesn't work right w.r.t pcm and doesn't give
- ;; the *Completions* output we want.
- (complete-with-action action (eval-when-compile
- (mapcar (lambda (s) (concat s ":"))
- vc-bzr-revision-keywords))
- string pred))))))
-
-(eval-after-load "vc"
- '(add-to-list 'vc-directory-exclusion-list vc-bzr-admin-dirname t))
-
-(provide 'vc-bzr)
-;; arch-tag: 8101bad8-4e92-4e7d-85ae-d8e08b4e7c06
-;;; vc-bzr.el ends here
+++ /dev/null
-;;; vc-cvs.el --- non-resident support for CVS version-control
-
-;; Copyright (C) 1995, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: FSF (see vc.el for full credits)
-;; Maintainer: Andre Spiegel <spiegel@gnu.org>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile (require 'cl) (require 'vc))
-
-;; Clear up the cache to force vc-call to check again and discover
-;; new functions when we reload this file.
-(put 'CVS 'vc-functions nil)
-
-;;; Properties of the backend.
-
-(defun vc-cvs-revision-granularity () 'file)
-
-(defun vc-cvs-checkout-model (files)
- "CVS-specific version of `vc-checkout-model'."
- (if (getenv "CVSREAD")
- 'announce
- (let* ((file (if (consp files) (car files) files))
- (attrib (file-attributes file)))
- (or (vc-file-getprop file 'vc-checkout-model)
- (vc-file-setprop
- file 'vc-checkout-model
- (if (and attrib ;; don't check further if FILE doesn't exist
- ;; If the file is not writable (despite CVSREAD being
- ;; undefined), this is probably because the file is being
- ;; "watched" by other developers.
- ;; (If vc-mistrust-permissions was t, we actually shouldn't
- ;; trust this, but there is no other way to learn this from
- ;; CVS at the moment (version 1.9).)
- (string-match "r-..-..-." (nth 8 attrib)))
- 'announce
- 'implicit))))))
-
-;;;
-;;; Customization options
-;;;
-
-(defcustom vc-cvs-global-switches nil
- "Global switches to pass to any CVS command."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List"
- :value ("")
- string))
- :version "22.1"
- :group 'vc)
-
-(defcustom vc-cvs-register-switches nil
- "Switches for registering a file into CVS.
-A string or list of strings passed to the checkin program by
-\\[vc-register]. If nil, use the value of `vc-register-switches'.
-If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc)
-
-(defcustom vc-cvs-diff-switches nil
- "String or list of strings specifying switches for CVS diff under VC.
-If nil, use the value of `vc-diff-switches'. If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc)
-
-(defcustom vc-cvs-header (or (cdr (assoc 'CVS vc-header-alist)) '("\$Id\$"))
- "Header keywords to be inserted by `vc-insert-headers'."
- :version "21.1"
- :type '(repeat string)
- :group 'vc)
-
-(defcustom vc-cvs-use-edit t
- "Non-nil means to use `cvs edit' to \"check out\" a file.
-This is only meaningful if you don't use the implicit checkout model
-\(i.e. if you have $CVSREAD set)."
- :type 'boolean
- :version "21.1"
- :group 'vc)
-
-(defcustom vc-cvs-stay-local 'only-file
- "Non-nil means use local operations when possible for remote repositories.
-This avoids slow queries over the network and instead uses heuristics
-and past information to determine the current status of a file.
-
-If value is the symbol `only-file' `vc-dir' will connect to the
-server, but heuristics will be used to determine the status for
-all other VC operations.
-
-The value can also be a regular expression or list of regular
-expressions to match against the host name of a repository; then VC
-only stays local for hosts that match it. Alternatively, the value
-can be a list of regular expressions where the first element is the
-symbol `except'; then VC always stays local except for hosts matched
-by these regular expressions."
- :type '(choice (const :tag "Always stay local" t)
- (const :tag "Only for file operations" only-file)
- (const :tag "Don't stay local" nil)
- (list :format "\nExamine hostname and %v"
- :tag "Examine hostname ..."
- (set :format "%v" :inline t
- (const :format "%t" :tag "don't" except))
- (regexp :format " stay local,\n%t: %v"
- :tag "if it matches")
- (repeat :format "%v%i\n" :inline t (regexp :tag "or"))))
- :version "23.1"
- :group 'vc)
-
-(defcustom vc-cvs-sticky-date-format-string "%c"
- "Format string for mode-line display of sticky date.
-Format is according to `format-time-string'. Only used if
-`vc-cvs-sticky-tag-display' is t."
- :type '(string)
- :version "22.1"
- :group 'vc)
-
-(defcustom vc-cvs-sticky-tag-display t
- "Specify the mode-line display of sticky tags.
-Value t means default display, nil means no display at all. If the
-value is a function or macro, it is called with the sticky tag and
-its' type as parameters, in that order. TYPE can have three different
-values: `symbolic-name' (TAG is a string), `revision-number' (TAG is a
-string) and `date' (TAG is a date as returned by `encode-time'). The
-return value of the function or macro will be displayed as a string.
-
-Here's an example that will display the formatted date for sticky
-dates and the word \"Sticky\" for sticky tag names and revisions.
-
- (lambda (tag type)
- (cond ((eq type 'date) (format-time-string
- vc-cvs-sticky-date-format-string tag))
- ((eq type 'revision-number) \"Sticky\")
- ((eq type 'symbolic-name) \"Sticky\")))
-
-Here's an example that will abbreviate to the first character only,
-any text before the first occurrence of `-' for sticky symbolic tags.
-If the sticky tag is a revision number, the word \"Sticky\" is
-displayed. Date and time is displayed for sticky dates.
-
- (lambda (tag type)
- (cond ((eq type 'date) (format-time-string \"%Y%m%d %H:%M\" tag))
- ((eq type 'revision-number) \"Sticky\")
- ((eq type 'symbolic-name)
- (condition-case nil
- (progn
- (string-match \"\\\\([^-]*\\\\)\\\\(.*\\\\)\" tag)
- (concat (substring (match-string 1 tag) 0 1) \":\"
- (substring (match-string 2 tag) 1 nil)))
- (error tag))))) ; Fall-back to given tag name.
-
-See also variable `vc-cvs-sticky-date-format-string'."
- :type '(choice boolean function)
- :version "22.1"
- :group 'vc)
-
-;;;
-;;; Internal variables
-;;;
-
-
-;;;
-;;; State-querying functions
-;;;
-
-;;;###autoload (defun vc-cvs-registered (f)
-;;;###autoload (when (file-readable-p (expand-file-name
-;;;###autoload "CVS/Entries" (file-name-directory f)))
-;;;###autoload (load "vc-cvs")
-;;;###autoload (vc-cvs-registered f)))
-
-(defun vc-cvs-registered (file)
- "Check if FILE is CVS registered."
- (let ((dirname (or (file-name-directory file) ""))
- (basename (file-name-nondirectory file))
- ;; make sure that the file name is searched case-sensitively
- (case-fold-search nil))
- (if (file-readable-p (expand-file-name "CVS/Entries" dirname))
- (or (string= basename "")
- (with-temp-buffer
- (vc-cvs-get-entries dirname)
- (goto-char (point-min))
- (cond ((re-search-forward
- (concat "^/" (regexp-quote basename) "/[^/]") nil t)
- (beginning-of-line)
- (vc-cvs-parse-entry file)
- t)
- (t nil))))
- nil)))
-
-(defun vc-cvs-state (file)
- "CVS-specific version of `vc-state'."
- (if (vc-stay-local-p file 'CVS)
- (let ((state (vc-file-getprop file 'vc-state)))
- ;; If we should stay local, use the heuristic but only if
- ;; we don't have a more precise state already available.
- (if (memq state '(up-to-date edited nil))
- (vc-cvs-state-heuristic file)
- state))
- (with-temp-buffer
- (cd (file-name-directory file))
- (let (process-file-side-effects)
- (vc-cvs-command t 0 file "status"))
- (vc-cvs-parse-status t))))
-
-(defun vc-cvs-state-heuristic (file)
- "CVS-specific state heuristic."
- ;; If the file has not changed since checkout, consider it `up-to-date'.
- ;; Otherwise consider it `edited'.
- (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
- (lastmod (nth 5 (file-attributes file))))
- (cond
- ((equal checkout-time lastmod) 'up-to-date)
- ((string= (vc-working-revision file) "0") 'added)
- ((null checkout-time) 'unregistered)
- (t 'edited))))
-
-(defun vc-cvs-working-revision (file)
- "CVS-specific version of `vc-working-revision'."
- ;; There is no need to consult RCS headers under CVS, because we
- ;; get the workfile version for free when we recognize that a file
- ;; is registered in CVS.
- (vc-cvs-registered file)
- (vc-file-getprop file 'vc-working-revision))
-
-(defun vc-cvs-mode-line-string (file)
- "Return string for placement into the modeline for FILE.
-Compared to the default implementation, this function does two things:
-Handle the special case of a CVS file that is added but not yet
-committed and support display of sticky tags."
- (let* ((sticky-tag (vc-file-getprop file 'vc-cvs-sticky-tag))
- help-echo
- (string
- (let ((def-ml (vc-default-mode-line-string 'CVS file)))
- (setq help-echo
- (get-text-property 0 'help-echo def-ml))
- def-ml)))
- (propertize
- (if (zerop (length sticky-tag))
- string
- (setq help-echo (format "%s on the '%s' branch"
- help-echo sticky-tag))
- (concat string "[" sticky-tag "]"))
- 'help-echo help-echo)))
-
-
-;;;
-;;; State-changing functions
-;;;
-
-(defun vc-cvs-register (files &optional rev comment)
- "Register FILES into the CVS version-control system.
-COMMENT can be used to provide an initial description of FILES.
-Passes either `vc-cvs-register-switches' or `vc-register-switches'
-to the CVS command."
- ;; Register the directories if needed.
- (let (dirs)
- (dolist (file files)
- (and (not (vc-cvs-responsible-p file))
- (vc-cvs-could-register file)
- (push (directory-file-name (file-name-directory file)) dirs)))
- (if dirs (vc-cvs-register dirs)))
- (apply 'vc-cvs-command nil 0 files
- "add"
- (and comment (string-match "[^\t\n ]" comment)
- (concat "-m" comment))
- (vc-switches 'CVS 'register)))
-
-(defun vc-cvs-responsible-p (file)
- "Return non-nil if CVS thinks it is responsible for FILE."
- (file-directory-p (expand-file-name "CVS"
- (if (file-directory-p file)
- file
- (file-name-directory file)))))
-
-(defun vc-cvs-could-register (file)
- "Return non-nil if FILE could be registered in CVS.
-This is only possible if CVS is managing FILE's directory or one of
-its parents."
- (let ((dir file))
- (while (and (stringp dir)
- (not (equal dir (setq dir (file-name-directory dir))))
- dir)
- (setq dir (if (file-exists-p
- (expand-file-name "CVS/Entries" dir))
- t
- (directory-file-name dir))))
- (eq dir t)))
-
-(defun vc-cvs-checkin (files rev comment &optional extra-args-ignored)
- "CVS-specific version of `vc-backend-checkin'."
- (unless (or (not rev) (vc-cvs-valid-revision-number-p rev))
- (if (not (vc-cvs-valid-symbolic-tag-name-p rev))
- (error "%s is not a valid symbolic tag name" rev)
- ;; If the input revison is a valid symbolic tag name, we create it
- ;; as a branch, commit and switch to it.
- (apply 'vc-cvs-command nil 0 files "tag" "-b" (list rev))
- (apply 'vc-cvs-command nil 0 files "update" "-r" (list rev))
- (mapc (lambda (file) (vc-file-setprop file 'vc-cvs-sticky-tag rev))
- files)))
- (let ((status (apply 'vc-cvs-command nil 1 files
- "ci" (if rev (concat "-r" rev))
- (concat "-m" comment)
- (vc-switches 'CVS 'checkin))))
- (set-buffer "*vc*")
- (goto-char (point-min))
- (when (not (zerop status))
- ;; Check checkin problem.
- (cond
- ((re-search-forward "Up-to-date check failed" nil t)
- (mapc (lambda (file) (vc-file-setprop file 'vc-state 'needs-merge))
- files)
- (error "%s" (substitute-command-keys
- (concat "Up-to-date check failed: "
- "type \\[vc-next-action] to merge in changes"))))
- (t
- (pop-to-buffer (current-buffer))
- (goto-char (point-min))
- (shrink-window-if-larger-than-buffer)
- (error "Check-in failed"))))
- ;; Single-file commit? Then update the revision by parsing the buffer.
- ;; Otherwise we can't necessarily tell what goes with what; clear
- ;; its properties so they have to be refetched.
- (if (= (length files) 1)
- (vc-file-setprop
- (car files) 'vc-working-revision
- (vc-parse-buffer "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" 2))
- (mapc 'vc-file-clearprops files))
- ;; Anyway, forget the checkout model of the file, because we might have
- ;; guessed wrong when we found the file. After commit, we can
- ;; tell it from the permissions of the file (see
- ;; vc-cvs-checkout-model).
- (mapc (lambda (file) (vc-file-setprop file 'vc-checkout-model nil))
- files)
-
- ;; if this was an explicit check-in (does not include creation of
- ;; a branch), remove the sticky tag.
- (if (and rev (not (vc-cvs-valid-symbolic-tag-name-p rev)))
- (vc-cvs-command nil 0 files "update" "-A"))))
-
-(defun vc-cvs-find-revision (file rev buffer)
- (apply 'vc-cvs-command
- buffer 0 file
- "-Q" ; suppress diagnostic output
- "update"
- (and rev (not (string= rev ""))
- (concat "-r" rev))
- "-p"
- (vc-switches 'CVS 'checkout)))
-
-(defun vc-cvs-checkout (file &optional editable rev)
- "Checkout a revision of FILE into the working area.
-EDITABLE non-nil means that the file should be writable.
-REV is the revision to check out."
- (message "Checking out %s..." file)
- ;; Change buffers to get local value of vc-checkout-switches.
- (with-current-buffer (or (get-file-buffer file) (current-buffer))
- (if (and (file-exists-p file) (not rev))
- ;; If no revision was specified, just make the file writable
- ;; if necessary (using `cvs-edit' if requested).
- (and editable (not (eq (vc-cvs-checkout-model (list file)) 'implicit))
- (if vc-cvs-use-edit
- (vc-cvs-command nil 0 file "edit")
- (set-file-modes file (logior (file-modes file) 128))
- (if (equal file buffer-file-name) (toggle-read-only -1))))
- ;; Check out a particular revision (or recreate the file).
- (vc-file-setprop file 'vc-working-revision nil)
- (apply 'vc-cvs-command nil 0 file
- (and editable "-w")
- "update"
- (when rev
- (unless (eq rev t)
- ;; default for verbose checkout: clear the
- ;; sticky tag so that the actual update will
- ;; get the head of the trunk
- (if (string= rev "")
- "-A"
- (concat "-r" rev))))
- (vc-switches 'CVS 'checkout)))
- (vc-mode-line file 'CVS))
- (message "Checking out %s...done" file))
-
-(defun vc-cvs-delete-file (file)
- (vc-cvs-command nil 0 file "remove" "-f"))
-
-(defun vc-cvs-revert (file &optional contents-done)
- "Revert FILE to the working revision on which it was based."
- (vc-default-revert 'CVS file contents-done)
- (unless (eq (vc-cvs-checkout-model (list file)) 'implicit)
- (if vc-cvs-use-edit
- (vc-cvs-command nil 0 file "unedit")
- ;; Make the file read-only by switching off all w-bits
- (set-file-modes file (logand (file-modes file) 3950)))))
-
-(defun vc-cvs-merge (file first-revision &optional second-revision)
- "Merge changes into current working copy of FILE.
-The changes are between FIRST-REVISION and SECOND-REVISION."
- (vc-cvs-command nil 0 file
- "update" "-kk"
- (concat "-j" first-revision)
- (concat "-j" second-revision))
- (vc-file-setprop file 'vc-state 'edited)
- (with-current-buffer (get-buffer "*vc*")
- (goto-char (point-min))
- (if (re-search-forward "conflicts during merge" nil t)
- (progn
- (vc-file-setprop file 'vc-state 'conflict)
- ;; signal error
- 1)
- (vc-file-setprop file 'vc-state 'edited)
- ;; signal success
- 0)))
-
-(defun vc-cvs-merge-news (file)
- "Merge in any new changes made to FILE."
- (message "Merging changes into %s..." file)
- ;; (vc-file-setprop file 'vc-working-revision nil)
- (vc-file-setprop file 'vc-checkout-time 0)
- (vc-cvs-command nil nil file "update")
- ;; Analyze the merge result reported by CVS, and set
- ;; file properties accordingly.
- (with-current-buffer (get-buffer "*vc*")
- (goto-char (point-min))
- ;; get new working revision
- (if (re-search-forward
- "^Merging differences between [0-9.]* and \\([0-9.]*\\) into" nil t)
- (vc-file-setprop file 'vc-working-revision (match-string 1))
- (vc-file-setprop file 'vc-working-revision nil))
- ;; get file status
- (prog1
- (if (eq (buffer-size) 0)
- 0 ;; there were no news; indicate success
- (if (re-search-forward
- (concat "^\\([CMUP] \\)?"
- (regexp-quote
- (substring file (1+ (length (expand-file-name
- "." default-directory)))))
- "\\( already contains the differences between \\)?")
- nil t)
- (cond
- ;; Merge successful, we are in sync with repository now
- ((or (match-string 2)
- (string= (match-string 1) "U ")
- (string= (match-string 1) "P "))
- (vc-file-setprop file 'vc-state 'up-to-date)
- (vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file)))
- 0);; indicate success to the caller
- ;; Merge successful, but our own changes are still in the file
- ((string= (match-string 1) "M ")
- (vc-file-setprop file 'vc-state 'edited)
- 0);; indicate success to the caller
- ;; Conflicts detected!
- (t
- (vc-file-setprop file 'vc-state 'conflict)
- 1);; signal the error to the caller
- )
- (pop-to-buffer "*vc*")
- (error "Couldn't analyze cvs update result")))
- (message "Merging changes into %s...done" file))))
-
-(defun vc-cvs-modify-change-comment (files rev comment)
- "Modify the change comments for FILES on a specified REV.
-Will fail unless you have administrative privileges on the repo."
- (vc-cvs-command nil 0 files "admin" (concat "-m" rev ":" comment)))
-
-;;;
-;;; History functions
-;;;
-
-(declare-function vc-rcs-print-log-cleanup "vc-rcs" ())
-
-(defun vc-cvs-print-log (files buffer &optional shortlog start-revision-ignored limit)
- "Get change logs associated with FILES."
- (require 'vc-rcs)
- ;; It's just the catenation of the individual logs.
- (vc-cvs-command
- buffer
- (if (vc-stay-local-p files 'CVS) 'async 0)
- files "log")
- (with-current-buffer buffer
- (vc-exec-after (vc-rcs-print-log-cleanup)))
- (when limit 'limit-unsupported))
-
-(defun vc-cvs-comment-history (file)
- "Get comment history of a file."
- (vc-call-backend 'RCS 'comment-history file))
-
-(defun vc-cvs-diff (files &optional oldvers newvers buffer)
- "Get a difference report using CVS between two revisions of FILE."
- (let* (process-file-side-effects
- (async (and (not vc-disable-async-diff)
- (vc-stay-local-p files 'CVS)))
- (invoke-cvs-diff-list nil)
- status)
- ;; Look through the file list and see if any files have backups
- ;; that can be used to do a plain "diff" instead of "cvs diff".
- (dolist (file files)
- (let ((ov oldvers)
- (nv newvers))
- (when (or (not ov) (string-equal ov ""))
- (setq ov (vc-working-revision file)))
- (when (string-equal nv "")
- (setq nv nil))
- (let ((file-oldvers (vc-version-backup-file file ov))
- (file-newvers (if (not nv)
- file
- (vc-version-backup-file file nv)))
- (coding-system-for-read (vc-coding-system-for-diff file)))
- (if (and file-oldvers file-newvers)
- (progn
- ;; This used to append diff-switches and vc-diff-switches,
- ;; which was consistent with the vc-diff-switches doc at that
- ;; time, but not with the actual behavior of any other VC diff.
- (apply 'vc-do-command (or buffer "*vc-diff*") 1 "diff" nil
- ;; Not a CVS diff, does not use vc-cvs-diff-switches.
- (append (vc-switches nil 'diff)
- (list (file-relative-name file-oldvers)
- (file-relative-name file-newvers))))
- (setq status 0))
- (push file invoke-cvs-diff-list)))))
- (when invoke-cvs-diff-list
- (setq status (apply 'vc-cvs-command (or buffer "*vc-diff*")
- (if async 'async 1)
- invoke-cvs-diff-list "diff"
- (and oldvers (concat "-r" oldvers))
- (and newvers (concat "-r" newvers))
- (vc-switches 'CVS 'diff))))
- (if async 1 status))) ; async diff, pessimistic assumption
-
-(defconst vc-cvs-annotate-first-line-re "^[0-9]")
-
-(defun vc-cvs-annotate-process-filter (process string)
- (setq string (concat (process-get process 'output) string))
- (if (not (string-match vc-cvs-annotate-first-line-re string))
- ;; Still waiting for the first real line.
- (process-put process 'output string)
- (let ((vc-filter (process-get process 'vc-filter)))
- (set-process-filter process vc-filter)
- (funcall vc-filter process (substring string (match-beginning 0))))))
-
-(defun vc-cvs-annotate-command (file buffer &optional revision)
- "Execute \"cvs annotate\" on FILE, inserting the contents in BUFFER.
-Optional arg REVISION is a revision to annotate from."
- (vc-cvs-command buffer
- (if (vc-stay-local-p file 'CVS)
- 'async 0)
- file "annotate"
- (if revision (concat "-r" revision)))
- ;; Strip the leading few lines.
- (let ((proc (get-buffer-process buffer)))
- (if proc
- ;; If running asynchronously, use a process filter.
- (progn
- (process-put proc 'vc-filter (process-filter proc))
- (set-process-filter proc 'vc-cvs-annotate-process-filter))
- (with-current-buffer buffer
- (goto-char (point-min))
- (re-search-forward vc-cvs-annotate-first-line-re)
- (delete-region (point-min) (1- (point)))))))
-
-(declare-function vc-annotate-convert-time "vc-annotate" (time))
-
-(defun vc-cvs-annotate-current-time ()
- "Return the current time, based at midnight of the current day, and
-encoded as fractional days."
- (vc-annotate-convert-time
- (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time))))))
-
-(defun vc-cvs-annotate-time ()
- "Return the time of the next annotation (as fraction of days)
-systime, or nil if there is none."
- (let* ((bol (point))
- (cache (get-text-property bol 'vc-cvs-annotate-time))
- (inhibit-read-only t)
- (inhibit-modification-hooks t))
- (cond
- (cache)
- ((looking-at
- "^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): ")
- (let ((day (string-to-number (match-string 1)))
- (month (cdr (assq (intern (match-string 2))
- '((Jan . 1) (Feb . 2) (Mar . 3)
- (Apr . 4) (May . 5) (Jun . 6)
- (Jul . 7) (Aug . 8) (Sep . 9)
- (Oct . 10) (Nov . 11) (Dec . 12)))))
- (year (let ((tmp (string-to-number (match-string 3))))
- ;; Years 0..68 are 2000..2068.
- ;; Years 69..99 are 1969..1999.
- (+ (cond ((> 69 tmp) 2000)
- ((> 100 tmp) 1900)
- (t 0))
- tmp))))
- (put-text-property
- bol (1+ bol) 'vc-cvs-annotate-time
- (setq cache (cons
- ;; Position at end makes for nicer overlay result.
- ;; Don't put actual buffer pos here, but only relative
- ;; distance, so we don't ever move backward in the
- ;; goto-char below, even if the text is moved.
- (- (match-end 0) (match-beginning 0))
- (vc-annotate-convert-time
- (encode-time 0 0 0 day month year))))))))
- (when cache
- (goto-char (+ bol (car cache))) ; Fontify from here to eol.
- (cdr cache)))) ; days (float)
-
-(defun vc-cvs-annotate-extract-revision-at-line ()
- (save-excursion
- (beginning-of-line)
- (if (re-search-forward "^\\([0-9]+\\.[0-9]+\\(\\.[0-9]+\\)*\\) +("
- (line-end-position) t)
- (match-string-no-properties 1)
- nil)))
-
-(defun vc-cvs-previous-revision (file rev)
- (vc-call-backend 'RCS 'previous-revision file rev))
-
-(defun vc-cvs-next-revision (file rev)
- (vc-call-backend 'RCS 'next-revision file rev))
-
-;; FIXME: This should probably be replaced by code using cvs2cl.
-(defun vc-cvs-update-changelog (files)
- (vc-call-backend 'RCS 'update-changelog files))
-
-;;;
-;;; Tag system
-;;;
-
-(defun vc-cvs-create-tag (dir name branchp)
- "Assign to DIR's current revision a given NAME.
-If BRANCHP is non-nil, the name is created as a branch (and the current
-workspace is immediately moved to that new branch)."
- (vc-cvs-command nil 0 dir "tag" "-c" (if branchp "-b") name)
- (when branchp (vc-cvs-command nil 0 dir "update" "-r" name)))
-
-(defun vc-cvs-retrieve-tag (dir name update)
- "Retrieve a tag at and below DIR.
-NAME is the name of the tag; if it is empty, do a `cvs update'.
-If UPDATE is non-nil, then update (resynch) any affected buffers."
- (with-current-buffer (get-buffer-create "*vc*")
- (let ((default-directory dir)
- (sticky-tag))
- (erase-buffer)
- (if (or (not name) (string= name ""))
- (vc-cvs-command t 0 nil "update")
- (vc-cvs-command t 0 nil "update" "-r" name)
- (setq sticky-tag name))
- (when update
- (goto-char (point-min))
- (while (not (eobp))
- (if (looking-at "\\([CMUP]\\) \\(.*\\)")
- (let* ((file (expand-file-name (match-string 2) dir))
- (state (match-string 1))
- (buffer (find-buffer-visiting file)))
- (when buffer
- (cond
- ((or (string= state "U")
- (string= state "P"))
- (vc-file-setprop file 'vc-state 'up-to-date)
- (vc-file-setprop file 'vc-working-revision nil)
- (vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file))))
- ((or (string= state "M")
- (string= state "C"))
- (vc-file-setprop file 'vc-state 'edited)
- (vc-file-setprop file 'vc-working-revision nil)
- (vc-file-setprop file 'vc-checkout-time 0)))
- (vc-file-setprop file 'vc-cvs-sticky-tag sticky-tag)
- (vc-resynch-buffer file t t))))
- (forward-line 1))))))
-
-
-;;;
-;;; Miscellaneous
-;;;
-
-(defun vc-cvs-make-version-backups-p (file)
- "Return non-nil if version backups should be made for FILE."
- (vc-stay-local-p file 'CVS))
-
-(defun vc-cvs-check-headers ()
- "Check if the current file has any headers in it."
- (save-excursion
- (goto-char (point-min))
- (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
-\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))
-
-
-;;;
-;;; Internal functions
-;;;
-
-(defun vc-cvs-command (buffer okstatus files &rest flags)
- "A wrapper around `vc-do-command' for use in vc-cvs.el.
-The difference to vc-do-command is that this function always invokes `cvs',
-and that it passes `vc-cvs-global-switches' to it before FLAGS."
- (apply 'vc-do-command (or buffer "*vc*") okstatus "cvs" files
- (if (stringp vc-cvs-global-switches)
- (cons vc-cvs-global-switches flags)
- (append vc-cvs-global-switches
- flags))))
-
-(defun vc-cvs-stay-local-p (file) ;Back-compatibility.
- (vc-stay-local-p file 'CVS))
-
-(defun vc-cvs-repository-hostname (dirname)
- "Hostname of the CVS server associated to workarea DIRNAME."
- (let ((rootname (expand-file-name "CVS/Root" dirname)))
- (when (file-readable-p rootname)
- (with-temp-buffer
- (let ((coding-system-for-read
- (or file-name-coding-system
- default-file-name-coding-system)))
- (vc-insert-file rootname))
- (goto-char (point-min))
- (nth 2 (vc-cvs-parse-root
- (buffer-substring (point)
- (line-end-position))))))))
-
-(defun vc-cvs-parse-uhp (path)
- "parse user@host/path into (user@host /path)"
- (if (string-match "\\([^/]+\\)\\(/.*\\)" path)
- (list (match-string 1 path) (match-string 2 path))
- (list nil path)))
-
-(defun vc-cvs-parse-root (root)
- "Split CVS ROOT specification string into a list of fields.
-A CVS root specification of the form
- [:METHOD:][[USER@]HOSTNAME]:?/path/to/repository
-is converted to a normalized record with the following structure:
- \(METHOD USER HOSTNAME CVS-ROOT).
-The default METHOD for a CVS root of the form
- /path/to/repository
-is `local'.
-The default METHOD for a CVS root of the form
- [USER@]HOSTNAME:/path/to/repository
-is `ext'.
-For an empty string, nil is returned (invalid CVS root)."
- ;; Split CVS root into colon separated fields (0-4).
- ;; The `x:' makes sure, that leading colons are not lost;
- ;; `HOST:/PATH' is then different from `:METHOD:/PATH'.
- (let* ((root-list (cdr (split-string (concat "x:" root) ":")))
- (len (length root-list))
- ;; All syntactic varieties will get a proper METHOD.
- (root-list
- (cond
- ((= len 0)
- ;; Invalid CVS root
- nil)
- ((= len 1)
- (let ((uhp (vc-cvs-parse-uhp (car root-list))))
- (cons (if (car uhp) "ext" "local") uhp)))
- ((= len 2)
- ;; [USER@]HOST:PATH => method `ext'
- (and (not (equal (car root-list) ""))
- (cons "ext" root-list)))
- ((= len 3)
- ;; :METHOD:PATH or :METHOD:USER@HOSTNAME/PATH
- (cons (cadr root-list)
- (vc-cvs-parse-uhp (caddr root-list))))
- (t
- ;; :METHOD:[USER@]HOST:PATH
- (cdr root-list)))))
- (if root-list
- (let ((method (car root-list))
- (uhost (or (cadr root-list) ""))
- (root (nth 2 root-list))
- user host)
- ;; Split USER@HOST
- (if (string-match "\\(.*\\)@\\(.*\\)" uhost)
- (setq user (match-string 1 uhost)
- host (match-string 2 uhost))
- (setq host uhost))
- ;; Remove empty HOST
- (and (equal host "")
- (setq host))
- ;; Fix windows style CVS root `:local:C:\\project\\cvs\\some\\dir'
- (and host
- (equal method "local")
- (setq root (concat host ":" root) host))
- ;; Normalize CVS root record
- (list method user host root)))))
-
-;; XXX: This does not work correctly for subdirectories. "cvs status"
-;; information is context sensitive, it contains lines like:
-;; cvs status: Examining DIRNAME
-;; and the file entries after that don't show the full path.
-;; Because of this VC directory listings only show changed files
-;; at the top level for CVS.
-(defun vc-cvs-parse-status (&optional full)
- "Parse output of \"cvs status\" command in the current buffer.
-Set file properties accordingly. Unless FULL is t, parse only
-essential information. Note that this can never set the 'ignored
-state."
- (let (file status missing)
- (goto-char (point-min))
- (while (looking-at "? \\(.*\\)")
- (setq file (expand-file-name (match-string 1)))
- (vc-file-setprop file 'vc-state 'unregistered)
- (forward-line 1))
- (when (re-search-forward "^File: " nil t)
- (when (setq missing (looking-at "no file "))
- (goto-char (match-end 0)))
- (cond
- ((re-search-forward "\\=\\([^ \t]+\\)" nil t)
- (setq file (expand-file-name (match-string 1)))
- (setq status(if (re-search-forward "\\=[ \t]+Status: \\(.*\\)" nil t)
- (match-string 1) "Unknown"))
- (when (and full
- (re-search-forward
- "\\(RCS Version\\|RCS Revision\\|Repository revision\\):\
-\[\t ]+\\([0-9.]+\\)"
- nil t))
- (vc-file-setprop file 'vc-latest-revision (match-string 2)))
- (vc-file-setprop
- file 'vc-state
- (cond
- ((string-match "Up-to-date" status)
- (vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file)))
- 'up-to-date)
- ((string-match "Locally Modified" status) 'edited)
- ((string-match "Needs Merge" status) 'needs-merge)
- ((string-match "Needs \\(Checkout\\|Patch\\)" status)
- (if missing 'missing 'needs-update))
- ((string-match "Locally Added" status) 'added)
- ((string-match "Locally Removed" status) 'removed)
- ((string-match "File had conflicts " status) 'conflict)
- ((string-match "Unknown" status) 'unregistered)
- (t 'edited))))))))
-
-(defun vc-cvs-after-dir-status (update-function)
- ;; Heavily inspired by vc-cvs-parse-status. AKA a quick hack.
- ;; This needs a lot of testing.
- (let ((status nil)
- (status-str nil)
- (file nil)
- (result nil)
- (missing nil)
- (ignore-next nil)
- (subdir default-directory))
- (goto-char (point-min))
- (while
- ;; Look for either a file entry, an unregistered file, or a
- ;; directory change.
- (re-search-forward
- "\\(^=+\n\\([^=c?\n].*\n\\|\n\\)+\\)\\|\\(\\(^?? .*\n\\)+\\)\\|\\(^cvs status: \\(Examining\\|nothing\\) .*\n\\)"
- nil t)
- ;; FIXME: get rid of narrowing here.
- (narrow-to-region (match-beginning 0) (match-end 0))
- (goto-char (point-min))
- ;; The subdir
- (when (looking-at "cvs status: Examining \\(.+\\)")
- (setq subdir (expand-file-name (match-string 1))))
- ;; Unregistered files
- (while (looking-at "? \\(.*\\)")
- (setq file (file-relative-name
- (expand-file-name (match-string 1) subdir)))
- (push (list file 'unregistered) result)
- (forward-line 1))
- (when (looking-at "cvs status: nothing known about")
- ;; We asked about a non existent file. The output looks like this:
-
- ;; cvs status: nothing known about `lisp/v.diff'
- ;; ===================================================================
- ;; File: no file v.diff Status: Unknown
- ;;
- ;; Working revision: No entry for v.diff
- ;; Repository revision: No revision control file
- ;;
-
- ;; Due to narrowing in this iteration we only see the "cvs
- ;; status:" line, so just set a flag so that we can ignore the
- ;; file in the next iteration.
- (setq ignore-next t))
- ;; A file entry.
- (when (re-search-forward "^File: \\(no file \\)?\\(.*[^ \t]\\)[ \t]+Status: \\(.*\\)" nil t)
- (setq missing (match-string 1))
- (setq file (file-relative-name
- (expand-file-name (match-string 2) subdir)))
- (setq status-str (match-string 3))
- (setq status
- (cond
- ((string-match "Up-to-date" status-str) 'up-to-date)
- ((string-match "Locally Modified" status-str) 'edited)
- ((string-match "Needs Merge" status-str) 'needs-merge)
- ((string-match "Needs \\(Checkout\\|Patch\\)" status-str)
- (if missing 'missing 'needs-update))
- ((string-match "Locally Added" status-str) 'added)
- ((string-match "Locally Removed" status-str) 'removed)
- ((string-match "File had conflicts " status-str) 'conflict)
- ((string-match "Unknown" status-str) 'unregistered)
- (t 'edited)))
- (if ignore-next
- (setq ignore-next nil)
- (unless (eq status 'up-to-date)
- (push (list file status) result))))
- (goto-char (point-max))
- (widen))
- (funcall update-function result))
- ;; Alternative implementation: use the "update" command instead of
- ;; the "status" command.
- ;; (let ((result nil)
- ;; (translation '((?? . unregistered)
- ;; (?A . added)
- ;; (?C . conflict)
- ;; (?M . edited)
- ;; (?P . needs-merge)
- ;; (?R . removed)
- ;; (?U . needs-update))))
- ;; (goto-char (point-min))
- ;; (while (not (eobp))
- ;; (if (looking-at "^[ACMPRU?] \\(.*\\)$")
- ;; (push (list (match-string 1)
- ;; (cdr (assoc (char-after) translation)))
- ;; result)
- ;; (cond
- ;; ((looking-at "cvs update: warning: \\(.*\\) was lost")
- ;; ;; Format is:
- ;; ;; cvs update: warning: FILENAME was lost
- ;; ;; U FILENAME
- ;; (push (list (match-string 1) 'missing) result)
- ;; ;; Skip the "U" line
- ;; (forward-line 1))
- ;; ((looking-at "cvs update: New directory `\\(.*\\)' -- ignored")
- ;; (push (list (match-string 1) 'unregistered) result))))
- ;; (forward-line 1))
- ;; (funcall update-function result)))
- )
-
-;; Based on vc-cvs-dir-state-heuristic from Emacs 22.
-;; FIXME does not mention unregistered files.
-(defun vc-cvs-dir-status-heuristic (dir update-function &optional basedir)
- "Find the CVS state of all files in DIR, using only local information."
- (let (file basename status result dirlist)
- (with-temp-buffer
- (vc-cvs-get-entries dir)
- (goto-char (point-min))
- (while (not (eobp))
- (if (looking-at "D/\\([^/]*\\)////")
- (push (expand-file-name (match-string 1) dir) dirlist)
- ;; CVS-removed files are not taken under VC control.
- (when (looking-at "/\\([^/]*\\)/[^/-]")
- (setq basename (match-string 1)
- file (expand-file-name basename dir)
- status (or (vc-file-getprop file 'vc-state)
- (vc-cvs-parse-entry file t)))
- (unless (eq status 'up-to-date)
- (push (list (if basedir
- (file-relative-name file basedir)
- basename)
- status) result))))
- (forward-line 1)))
- (dolist (subdir dirlist)
- (setq result (append result
- (vc-cvs-dir-status-heuristic subdir nil
- (or basedir dir)))))
- (if basedir result
- (funcall update-function result))))
-
-(defun vc-cvs-dir-status (dir update-function)
- "Create a list of conses (file . state) for DIR."
- ;; FIXME check all files in DIR instead?
- (let ((local (vc-stay-local-p dir 'CVS)))
- (if (and local (not (eq local 'only-file)))
- (vc-cvs-dir-status-heuristic dir update-function)
- (vc-cvs-command (current-buffer) 'async dir "-f" "status")
- ;; Alternative implementation: use the "update" command instead of
- ;; the "status" command.
- ;; (vc-cvs-command (current-buffer) 'async
- ;; (file-relative-name dir)
- ;; "-f" "-n" "update" "-d" "-P")
- (vc-exec-after
- `(vc-cvs-after-dir-status (quote ,update-function))))))
-
-(defun vc-cvs-dir-status-files (dir files default-state update-function)
- "Create a list of conses (file . state) for DIR."
- (apply 'vc-cvs-command (current-buffer) 'async dir "-f" "status" files)
- (vc-exec-after
- `(vc-cvs-after-dir-status (quote ,update-function))))
-
-(defun vc-cvs-file-to-string (file)
- "Read the content of FILE and return it as a string."
- (condition-case nil
- (with-temp-buffer
- (insert-file-contents file)
- (goto-char (point-min))
- (buffer-substring (point) (point-max)))
- (file-error nil)))
-
-(defun vc-cvs-dir-extra-headers (dir)
- "Extract and represent per-directory properties of a CVS working copy."
- (let ((repo
- (condition-case nil
- (with-temp-buffer
- (insert-file-contents "CVS/Root")
- (goto-char (point-min))
- (and (looking-at ":ext:") (delete-char 5))
- (concat (buffer-substring (point) (1- (point-max))) "\n"))
- (file-error nil)))
- (module
- (condition-case nil
- (with-temp-buffer
- (insert-file-contents "CVS/Repository")
- (goto-char (point-min))
- (skip-chars-forward "^\n")
- (concat (buffer-substring (point-min) (point)) "\n"))
- (file-error nil))))
- (concat
- (cond (repo
- (concat (propertize "Repository : " 'face 'font-lock-type-face)
- (propertize repo 'face 'font-lock-variable-name-face)))
- (t ""))
- (cond (module
- (concat (propertize "Module : " 'face 'font-lock-type-face)
- (propertize module 'face 'font-lock-variable-name-face)))
- (t ""))
- (if (file-readable-p "CVS/Tag")
- (let ((tag (vc-cvs-file-to-string "CVS/Tag")))
- (cond
- ((string-match "\\`T" tag)
- (concat (propertize "Tag : " 'face 'font-lock-type-face)
- (propertize (substring tag 1)
- 'face 'font-lock-variable-name-face)))
- ((string-match "\\`D" tag)
- (concat (propertize "Date : " 'face 'font-lock-type-face)
- (propertize (substring tag 1)
- 'face 'font-lock-variable-name-face)))
- (t ""))))
-
- ;; In CVS, branch is a per-file property, not a per-directory property.
- ;; We can't really do this here without making dangerous assumptions.
- ;;(propertize "Branch: " 'face 'font-lock-type-face)
- ;;(propertize "ADD CODE TO PRINT THE BRANCH NAME\n"
- ;; 'face 'font-lock-warning-face)
- )))
-
-(defun vc-cvs-get-entries (dir)
- "Insert the CVS/Entries file from below DIR into the current buffer.
-This function ensures that the correct coding system is used for that,
-which may not be the one that is used for the files' contents.
-CVS/Entries should only be accessed through this function."
- (let ((coding-system-for-read (or file-name-coding-system
- default-file-name-coding-system)))
- (vc-insert-file (expand-file-name "CVS/Entries" dir))))
-
-(defun vc-cvs-valid-symbolic-tag-name-p (tag)
- "Return non-nil if TAG is a valid symbolic tag name."
- ;; According to the CVS manual, a valid symbolic tag must start with
- ;; an uppercase or lowercase letter and can contain uppercase and
- ;; lowercase letters, digits, `-', and `_'.
- (and (string-match "^[a-zA-Z]" tag)
- (not (string-match "[^a-z0-9A-Z-_]" tag))))
-
-(defun vc-cvs-valid-revision-number-p (tag)
- "Return non-nil if TAG is a valid revision number."
- (and (string-match "^[0-9]" tag)
- (not (string-match "[^0-9.]" tag))))
-
-(defun vc-cvs-parse-sticky-tag (match-type match-tag)
- "Parse and return the sticky tag as a string.
-`match-data' is protected."
- (let ((data (match-data))
- (tag)
- (type (cond ((string= match-type "D") 'date)
- ((string= match-type "T")
- (if (vc-cvs-valid-symbolic-tag-name-p match-tag)
- 'symbolic-name
- 'revision-number))
- (t nil))))
- (unwind-protect
- (progn
- (cond
- ;; Sticky Date tag. Convert to a proper date value (`encode-time')
- ((eq type 'date)
- (string-match
- "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)"
- match-tag)
- (let* ((year-tmp (string-to-number (match-string 1 match-tag)))
- (month (string-to-number (match-string 2 match-tag)))
- (day (string-to-number (match-string 3 match-tag)))
- (hour (string-to-number (match-string 4 match-tag)))
- (min (string-to-number (match-string 5 match-tag)))
- (sec (string-to-number (match-string 6 match-tag)))
- ;; Years 0..68 are 2000..2068.
- ;; Years 69..99 are 1969..1999.
- (year (+ (cond ((> 69 year-tmp) 2000)
- ((> 100 year-tmp) 1900)
- (t 0))
- year-tmp)))
- (setq tag (encode-time sec min hour day month year))))
- ;; Sticky Tag name or revision number
- ((eq type 'symbolic-name) (setq tag match-tag))
- ((eq type 'revision-number) (setq tag match-tag))
- ;; Default is no sticky tag at all
- (t nil))
- (cond ((eq vc-cvs-sticky-tag-display nil) nil)
- ((eq vc-cvs-sticky-tag-display t)
- (cond ((eq type 'date) (format-time-string
- vc-cvs-sticky-date-format-string
- tag))
- ((eq type 'symbolic-name) tag)
- ((eq type 'revision-number) tag)
- (t nil)))
- ((functionp vc-cvs-sticky-tag-display)
- (funcall vc-cvs-sticky-tag-display tag type))
- (t nil)))
-
- (set-match-data data))))
-
-(defun vc-cvs-parse-entry (file &optional set-state)
- "Parse a line from CVS/Entries.
-Compare modification time to that of the FILE, set file properties
-accordingly. However, `vc-state' is set only if optional arg SET-STATE
-is non-nil."
- (cond
- ;; entry for a "locally added" file (not yet committed)
- ((looking-at "/[^/]+/0/")
- (vc-file-setprop file 'vc-checkout-time 0)
- (vc-file-setprop file 'vc-working-revision "0")
- (if set-state (vc-file-setprop file 'vc-state 'added)))
- ;; normal entry
- ((looking-at
- (concat "/[^/]+"
- ;; revision
- "/\\([^/]*\\)"
- ;; timestamp and optional conflict field
- "/\\([^/]*\\)/"
- ;; options
- "\\([^/]*\\)/"
- ;; sticky tag
- "\\(.\\|\\)" ;Sticky tag type (date or tag name, could be empty)
- "\\(.*\\)")) ;Sticky tag
- (vc-file-setprop file 'vc-working-revision (match-string 1))
- (vc-file-setprop file 'vc-cvs-sticky-tag
- (vc-cvs-parse-sticky-tag (match-string 4)
- (match-string 5)))
- ;; Compare checkout time and modification time.
- ;; This is intentionally different from the algorithm that CVS uses
- ;; (which is based on textual comparison), because there can be problems
- ;; generating a time string that looks exactly like the one from CVS.
- (let* ((time (match-string 2))
- (mtime (nth 5 (file-attributes file)))
- (parsed-time (progn (require 'parse-time)
- (parse-time-string (concat time " +0000")))))
- (cond ((and (not (string-match "\\+" time))
- (car parsed-time)
- (equal mtime (apply 'encode-time parsed-time)))
- (vc-file-setprop file 'vc-checkout-time mtime)
- (if set-state (vc-file-setprop file 'vc-state 'up-to-date)))
- (t
- (vc-file-setprop file 'vc-checkout-time 0)
- (if set-state (vc-file-setprop file 'vc-state 'edited))))))))
-
-;; Completion of revision names.
-;; Just so I don't feel like I'm duplicating code from pcl-cvs, I'll use
-;; `cvs log' so I can list all the revision numbers rather than only
-;; tag names.
-
-(defun vc-cvs-revision-table (file)
- (let (process-file-side-effects
- (default-directory (file-name-directory file))
- (res nil))
- (with-temp-buffer
- (vc-cvs-command t nil file "log")
- (goto-char (point-min))
- (when (re-search-forward "^symbolic names:\n" nil t)
- (while (looking-at "^ \\(.*\\): \\(.*\\)")
- (push (cons (match-string 1) (match-string 2)) res)
- (forward-line 1)))
- (while (re-search-forward "^revision \\([0-9.]+\\)" nil t)
- (push (match-string 1) res))
- res)))
-
-(defun vc-cvs-revision-completion-table (files)
- (lexical-let ((files files)
- table)
- (setq table (lazy-completion-table
- table (lambda () (vc-cvs-revision-table (car files)))))
- table))
-
-
-(provide 'vc-cvs)
-
-;; arch-tag: 60e1402a-aa53-4607-927a-cf74f144b432
-;;; vc-cvs.el ends here
+++ /dev/null
-;;; vc-dav.el --- vc.el support for WebDAV
-
-;; Copyright (C) 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Bill Perry <wmperry@gnu.org>
-;; Maintainer: Bill Perry <wmperry@gnu.org>
-;; Keywords: url, vc
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-
-;;; Commentary:
-
-;;; Todo:
-;;
-;; - Some methods need to be updated to match the current vc.el.
-;; - rename "version" -> "revision"
-;; - some methods need to take a fileset as a parameter instead of a
-;; single file.
-
-;;; Code:
-
-(require 'url)
-(require 'url-dav)
-
-;;; Required functions for a vc backend
-(defun vc-dav-registered (url)
- "Return t if URL is registered with a DAV aware server."
- (url-dav-vc-registered url))
-
-(defun vc-dav-state (url)
- "Return the current version control state of URL.
-For a list of possible values, see `vc-state'."
- ;; Things we can support for WebDAV
- ;;
- ;; up-to-date - use lockdiscovery
- ;; edited - check for an active lock by us
- ;; USER - use lockdiscovery + owner
- ;;
- ;; These don't make sense for WebDAV
- ;; needs-patch
- ;; needs-merge
- ;; unlocked-changes
- (let ((locks (url-dav-active-locks url)))
- (cond
- ((null locks) 'up-to-date)
- ((assoc url locks)
- ;; SOMEBODY has a lock... let's find out who.
- (setq locks (cdr (assoc url locks)))
- (if (rassoc url-dav-lock-identifier locks)
- ;; _WE_ have a lock
- 'edited
- (cdr (car locks)))))))
-
-(defun vc-dav-checkout-model (url)
- "Indicate whether URL needs to be \"checked out\" before it can be edited.
-See `vc-checkout-model' for a list of possible values."
- ;; The only thing we can support with webdav is 'locking
- 'locking)
-
-;; This should figure out the version # of the file somehow. What is
-;; the most appropriate property in WebDAV to look at for this?
-(defun vc-dav-workfile-version (url)
- "Return the current workfile version of URL."
- "Unknown")
-
-(defun vc-dav-register (url &optional rev comment)
- "Register URL in the DAV backend."
- ;; Do we need to do anything here? FIXME?
- )
-
-(defun vc-dav-checkin (url rev comment)
- "Commit changes in URL to WebDAV.
-If REV is non-nil, that should become the new revision number.
-COMMENT is used as a check-in comment."
- ;; This should PUT the resource and release any locks that we hold.
- )
-
-(defun vc-dav-checkout (url &optional editable rev destfile)
- "Check out revision REV of URL into the working area.
-
-If EDITABLE is non-nil URL should be writable by the user and if
-locking is used for URL, a lock should also be set.
-
-If REV is non-nil, that is the revision to check out. If REV is the
-empty string, that means to check ou tht ehead of the trunk.
-
-If optional arg DESTFILE is given, it is an alternate filename to
-write the contents to.
-"
- ;; This should LOCK the resource.
- )
-
-(defun vc-dav-revert (url &optional contents-done)
- "Revert URL back to the current workfile version.
-
-If optional arg CONTENTS-DONE is non-nil, then the contents of FILE
-have already been reverted from a version backup, and this function
-only needs to update the status of URL within the backend.
-"
- ;; Should do a GET if !contents_done
- ;; Should UNLOCK the file.
- )
-
-(defun vc-dav-print-log (url)
- "Insert the revision log of URL into the *vc* buffer."
- )
-
-(defun vc-dav-diff (url &optional rev1 rev2)
- "Insert the diff for URL into the *vc-diff* buffer.
-If REV1 and REV2 are non-nil report differences from REV1 to REV2.
-If REV1 is nil, use the current workfile version as the older version.
-If REV2 is nil, use the current workfile contents as the nwer version.
-
-It should return a status of either 0 (no differences found), or
-1 (either non-empty diff or the diff is run asynchronously).
-"
- ;; We should do this asynchronously...
- ;; How would we do it at all, that is the question!
- )
-
-
-
-;;; Optional functions
-;; Should be faster than vc-dav-state - but how?
-(defun vc-dav-state-heuristic (url)
- "Estimate the version control state of URL at visiting time."
- (vc-dav-state url))
-
-;; This should use url-dav-get-properties with a depth of `1' to get
-;; all the properties.
-(defun vc-dav-dir-state (url)
- "find the version control state of all files in DIR in a fast way."
- )
-
-(defun vc-dav-workfile-unchanged-p (url)
- "Return non-nil if URL is unchanged from its current workfile version."
- ;; Probably impossible with webdav
- )
-
-(defun vc-dav-responsible-p (url)
- "Return non-nil if DAV considers itself `responsible' for URL."
- ;; Check for DAV support on the web server.
- t)
-
-(defun vc-dav-could-register (url)
- "Return non-nil if URL could be registered under this backend."
- ;; Check for DAV support on the web server.
- t)
-
-;;; Unimplemented functions
-;;
-;; vc-dav-latest-on-branch-p(URL)
-;; Return non-nil if the current workfile version of FILE is the
-;; latest on its branch. There are no branches in webdav yet.
-;;
-;; vc-dav-mode-line-string(url)
-;; Return a dav-specific mode line string for URL. Are there any
-;; specific states that we want exposed?
-;;
-;; vc-dav-dired-state-info(url)
-;; Translate the `vc-state' property of URL into a string that can
-;; be used in a vc-dired buffer. Are there any extra states that
-;; we want exposed?
-;;
-;; vc-dav-receive-file(url rev)
-;; Let this backend `receive' a file that is already registered
-;; under another backend. The default just calls `register', which
-;; should be sufficient for WebDAV.
-;;
-;; vc-dav-unregister(url)
-;; Unregister URL. Not possible with WebDAV, other than by
-;; deleting the resource.
-
-(provide 'vc-dav)
-
-;; arch-tag: 0a0fb9fe-8190-4c0a-a179-5c291d3a467e
-;;; vc-dav.el ends here
+++ /dev/null
-;;; vc-dir.el --- Directory status display under VC
-
-;; Copyright (C) 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Author: Dan Nicolaescu <dann@ics.uci.edu>
-;; Keywords: tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Credits:
-
-;; The original VC directory status implementation was based on dired.
-;; This implementation was inspired by PCL-CVS.
-;; Many people contributed comments, ideas and code to this
-;; implementation. These include:
-;;
-;; Alexandre Julliard <julliard@winehq.org>
-;; Stefan Monnier <monnier@iro.umontreal.ca>
-;; Tom Tromey <tromey@redhat.com>
-
-;;; Commentary:
-;;
-
-;;; Todo: see vc.el.
-
-(require 'vc-hooks)
-(require 'vc)
-(require 'tool-bar)
-(require 'ewoc)
-
-;;; Code:
-(eval-when-compile
- (require 'cl))
-
-(defcustom vc-dir-mode-hook nil
- "Normal hook run by `vc-dir-mode'.
-See `run-hooks'."
- :type 'hook
- :group 'vc)
-
-;; Used to store information for the files displayed in the directory buffer.
-;; Each item displayed corresponds to one of these defstructs.
-(defstruct (vc-dir-fileinfo
- (:copier nil)
- (:type list) ;So we can use `member' on lists of FIs.
- (:constructor
- ;; We could define it as an alias for `list'.
- vc-dir-create-fileinfo (name state &optional extra marked directory))
- (:conc-name vc-dir-fileinfo->))
- name ;Keep it as first, for `member'.
- state
- ;; For storing backend specific information.
- extra
- marked
- ;; To keep track of not updated files during a global refresh
- needs-update
- ;; To distinguish files and directories.
- directory)
-
-(defvar vc-ewoc nil)
-
-(defvar vc-dir-process-buffer nil
- "The buffer used for the asynchronous call that computes status.")
-
-(defvar vc-dir-backend nil
- "The backend used by the current *vc-dir* buffer.")
-
-(defun vc-dir-move-to-goal-column ()
- ;; Used to keep the cursor on the file name column.
- (beginning-of-line)
- (unless (eolp)
- ;; Must be in sync with vc-default-dir-printer.
- (forward-char 25)))
-
-(defun vc-dir-prepare-status-buffer (bname dir backend &optional create-new)
- "Find a buffer named BNAME showing DIR, or create a new one."
- (setq dir (file-name-as-directory (expand-file-name dir)))
- (let* ;; Look for another buffer name BNAME visiting the same directory.
- ((buf (save-excursion
- (unless create-new
- (dolist (buffer vc-dir-buffers)
- (when (buffer-live-p buffer)
- (set-buffer buffer)
- (when (and (derived-mode-p 'vc-dir-mode)
- (eq vc-dir-backend backend)
- (string= default-directory dir))
- (return buffer))))))))
- (or buf
- ;; Create a new buffer named BNAME.
- ;; We pass a filename to create-file-buffer because it is what
- ;; the function expects, and also what uniquify needs (if active)
- (with-current-buffer (create-file-buffer (expand-file-name bname dir))
- (cd dir)
- (vc-setup-buffer (current-buffer))
- ;; Reset the vc-parent-buffer-name so that it does not appear
- ;; in the mode-line.
- (setq vc-parent-buffer-name nil)
- (current-buffer)))))
-
-(defvar vc-dir-menu-map
- (let ((map (make-sparse-keymap "VC-dir")))
- (define-key map [quit]
- '(menu-item "Quit" quit-window
- :help "Quit"))
- (define-key map [kill]
- '(menu-item "Kill Update Command" vc-dir-kill-dir-status-process
- :enable (vc-dir-busy)
- :help "Kill the command that updates the directory buffer"))
- (define-key map [refresh]
- '(menu-item "Refresh" revert-buffer
- :enable (not (vc-dir-busy))
- :help "Refresh the contents of the directory buffer"))
- (define-key map [remup]
- '(menu-item "Hide up-to-date" vc-dir-hide-up-to-date
- :help "Hide up-to-date items from display"))
- ;; Movement.
- (define-key map [sepmv] '("--"))
- (define-key map [next-line]
- '(menu-item "Next line" vc-dir-next-line
- :help "Go to the next line" :keys "n"))
- (define-key map [previous-line]
- '(menu-item "Previous line" vc-dir-previous-line
- :help "Go to the previous line"))
- ;; Marking.
- (define-key map [sepmrk] '("--"))
- (define-key map [unmark-all]
- '(menu-item "Unmark All" vc-dir-unmark-all-files
- :help "Unmark all files that are in the same state as the current file\
-\nWith prefix argument unmark all files"))
- (define-key map [unmark-previous]
- '(menu-item "Unmark previous " vc-dir-unmark-file-up
- :help "Move to the previous line and unmark the file"))
-
- (define-key map [mark-all]
- '(menu-item "Mark All" vc-dir-mark-all-files
- :help "Mark all files that are in the same state as the current file\
-\nWith prefix argument mark all files"))
- (define-key map [unmark]
- '(menu-item "Unmark" vc-dir-unmark
- :help "Unmark the current file or all files in the region"))
-
- (define-key map [mark]
- '(menu-item "Mark" vc-dir-mark
- :help "Mark the current file or all files in the region"))
-
- (define-key map [sepopn] '("--"))
- (define-key map [qr]
- '(menu-item "Query Replace in Files..." vc-dir-query-replace-regexp
- :help "Replace a string in the marked files"))
- (define-key map [se]
- '(menu-item "Search Files..." vc-dir-search
- :help "Search a regexp in the marked files"))
- (define-key map [ires]
- '(menu-item "Isearch Regexp Files..." vc-dir-isearch-regexp
- :help "Incremental search a regexp in the marked files"))
- (define-key map [ise]
- '(menu-item "Isearch Files..." vc-dir-isearch
- :help "Incremental search a string in the marked files"))
- (define-key map [open-other]
- '(menu-item "Open in other window" vc-dir-find-file-other-window
- :help "Find the file on the current line, in another window"))
- (define-key map [open]
- '(menu-item "Open file" vc-dir-find-file
- :help "Find the file on the current line"))
- (define-key map [sepvcdet] '("--"))
- ;; FIXME: This needs a key binding. And maybe a better name
- ;; ("Insert" like PCL-CVS uses does not sound that great either)...
- (define-key map [ins]
- '(menu-item "Show File" vc-dir-show-fileentry
- :help "Show a file in the VC status listing even though it might be up to date"))
- (define-key map [annotate]
- '(menu-item "Annotate" vc-annotate
- :help "Display the edit history of the current file using colors"))
- (define-key map [diff]
- '(menu-item "Compare with Base Version" vc-diff
- :help "Compare file set with the base version"))
- (define-key map [logo]
- '(menu-item "Show Outgoing Log" vc-log-outgoing
- :help "Show a log of changes that will be sent with a push operation"))
- (define-key map [logi]
- '(menu-item "Show Incoming Log" vc-log-incoming
- :help "Show a log of changes that will be received with a pull operation"))
- (define-key map [log]
- '(menu-item "Show history" vc-print-log
- :help "List the change log of the current file set in a window"))
- (define-key map [rlog]
- '(menu-item "Show Top of the Tree History " vc-print-root-log
- :help "List the change log for the current tree in a window"))
- ;; VC commands.
- (define-key map [sepvccmd] '("--"))
- (define-key map [update]
- '(menu-item "Update to latest version" vc-update
- :help "Update the current fileset's files to their tip revisions"))
- (define-key map [revert]
- '(menu-item "Revert to base version" vc-revert
- :help "Revert working copies of the selected fileset to their repository contents."))
- (define-key map [next-action]
- ;; FIXME: This really really really needs a better name!
- ;; And a key binding too.
- '(menu-item "Check In/Out" vc-next-action
- :help "Do the next logical version control operation on the current fileset"))
- (define-key map [register]
- '(menu-item "Register" vc-register
- :help "Register file set into the version control system"))
- map)
- "Menu for VC dir.")
-
-;; VC backends can use this to add mode-specific menu items to
-;; vc-dir-menu-map.
-(defun vc-dir-menu-map-filter (orig-binding)
- (when (and (symbolp orig-binding) (fboundp orig-binding))
- (setq orig-binding (indirect-function orig-binding)))
- (let ((ext-binding
- (when (derived-mode-p 'vc-dir-mode)
- (vc-call-backend vc-dir-backend 'extra-status-menu))))
- (if (null ext-binding)
- orig-binding
- (append orig-binding
- '("----")
- ext-binding))))
-
-(defvar vc-dir-mode-map
- (let ((map (make-sparse-keymap)))
- ;; VC commands
- (define-key map "v" 'vc-next-action) ;; C-x v v
- (define-key map "=" 'vc-diff) ;; C-x v =
- (define-key map "i" 'vc-register) ;; C-x v i
- (define-key map "+" 'vc-update) ;; C-x v +
- (define-key map "l" 'vc-print-log) ;; C-x v l
- ;; More confusing than helpful, probably
- ;;(define-key map "R" 'vc-revert) ;; u is taken by vc-dir-unmark.
- ;;(define-key map "A" 'vc-annotate) ;; g is taken by revert-buffer
- ;; bound by `special-mode'.
- ;; Marking.
- (define-key map "m" 'vc-dir-mark)
- (define-key map "M" 'vc-dir-mark-all-files)
- (define-key map "u" 'vc-dir-unmark)
- (define-key map "U" 'vc-dir-unmark-all-files)
- (define-key map "\C-?" 'vc-dir-unmark-file-up)
- (define-key map "\M-\C-?" 'vc-dir-unmark-all-files)
- ;; Movement.
- (define-key map "n" 'vc-dir-next-line)
- (define-key map " " 'vc-dir-next-line)
- (define-key map "\t" 'vc-dir-next-directory)
- (define-key map "p" 'vc-dir-previous-line)
- (define-key map [backtab] 'vc-dir-previous-directory)
- ;;; Rebind paragraph-movement commands.
- (define-key map "\M-}" 'vc-dir-next-directory)
- (define-key map "\M-{" 'vc-dir-previous-directory)
- (define-key map [C-down] 'vc-dir-next-directory)
- (define-key map [C-up] 'vc-dir-previous-directory)
- ;; The remainder.
- (define-key map "f" 'vc-dir-find-file)
- (define-key map "\C-m" 'vc-dir-find-file)
- (define-key map "o" 'vc-dir-find-file-other-window)
- (define-key map "\C-c\C-c" 'vc-dir-kill-dir-status-process)
- (define-key map [down-mouse-3] 'vc-dir-menu)
- (define-key map [mouse-2] 'vc-dir-toggle-mark)
- (define-key map [follow-link] 'mouse-face)
- (define-key map "x" 'vc-dir-hide-up-to-date)
- (define-key map [?\C-k] 'vc-dir-kill-line)
- (define-key map "S" 'vc-dir-search) ;; FIXME: Maybe use A like dired?
- (define-key map "Q" 'vc-dir-query-replace-regexp)
- (define-key map (kbd "M-s a C-s") 'vc-dir-isearch)
- (define-key map (kbd "M-s a M-C-s") 'vc-dir-isearch-regexp)
-
- ;; Hook up the menu.
- (define-key map [menu-bar vc-dir-mode]
- `(menu-item
- ;; VC backends can use this to add mode-specific menu items to
- ;; vc-dir-menu-map.
- "VC-dir" ,vc-dir-menu-map :filter vc-dir-menu-map-filter))
- map)
- "Keymap for directory buffer.")
-
-(defmacro vc-dir-at-event (event &rest body)
- "Evaluate BODY with point located at event-start of EVENT.
-If BODY uses EVENT, it should be a variable,
- otherwise it will be evaluated twice."
- (let ((posn (make-symbol "vc-dir-at-event-posn")))
- `(save-excursion
- (unless (equal ,event '(tool-bar))
- (let ((,posn (event-start ,event)))
- (set-buffer (window-buffer (posn-window ,posn)))
- (goto-char (posn-point ,posn))))
- ,@body)))
-
-(defun vc-dir-menu (e)
- "Popup the VC dir menu."
- (interactive "e")
- (vc-dir-at-event e (popup-menu vc-dir-menu-map e)))
-
-(defvar vc-dir-tool-bar-map
- (let ((map (make-sparse-keymap)))
- (tool-bar-local-item-from-menu 'vc-dir-find-file "open"
- map vc-dir-mode-map)
- (tool-bar-local-item "bookmark_add"
- 'vc-dir-toggle-mark 'vc-dir-toggle-mark map
- :help "Toggle mark on current item"
- :label "Toggle Mark")
- (tool-bar-local-item-from-menu 'vc-dir-previous-line "left-arrow"
- map vc-dir-mode-map
- :rtl "right-arrow")
- (tool-bar-local-item-from-menu 'vc-dir-next-line "right-arrow"
- map vc-dir-mode-map
- :rtl "left-arrow")
- (tool-bar-local-item-from-menu 'vc-print-log "info"
- map vc-dir-mode-map)
- (tool-bar-local-item-from-menu 'revert-buffer "refresh"
- map vc-dir-mode-map)
- (tool-bar-local-item-from-menu 'nonincremental-search-forward
- "search" map nil
- :label "Search")
- (tool-bar-local-item-from-menu 'vc-dir-query-replace-regexp
- "search-replace" map vc-dir-mode-map
- :label "Replace")
- (tool-bar-local-item-from-menu 'vc-dir-kill-dir-status-process "cancel"
- map vc-dir-mode-map
- :label "Cancel")
- (tool-bar-local-item-from-menu 'quit-window "exit"
- map vc-dir-mode-map)
- map))
-
-(defun vc-dir-node-directory (node)
- ;; Compute the directory for NODE.
- ;; If it's a directory node, get it from the node.
- (let ((data (ewoc-data node)))
- (or (vc-dir-fileinfo->directory data)
- ;; Otherwise compute it from the file name.
- (file-name-directory
- (directory-file-name
- (expand-file-name
- (vc-dir-fileinfo->name data)))))))
-
-(defun vc-dir-update (entries buffer &optional noinsert)
- "Update BUFFER's ewoc from the list of ENTRIES.
-If NOINSERT, ignore elements on ENTRIES which are not in the ewoc."
- ;; Add ENTRIES to the vc-dir buffer BUFFER.
- (with-current-buffer buffer
- ;; Insert the entries sorted by name into the ewoc.
- ;; We assume the ewoc is sorted too, which should be the
- ;; case if we always add entries with vc-dir-update.
- (setq entries
- ;; Sort: first files and then subdirectories.
- ;; XXX: this is VERY inefficient, it computes the directory
- ;; names too many times
- (sort entries
- (lambda (entry1 entry2)
- (let ((dir1 (file-name-directory
- (directory-file-name (expand-file-name (car entry1)))))
- (dir2 (file-name-directory
- (directory-file-name (expand-file-name (car entry2))))))
- (cond
- ((string< dir1 dir2) t)
- ((not (string= dir1 dir2)) nil)
- ((string< (car entry1) (car entry2))))))))
- ;; Insert directory entries in the right places.
- (let ((entry (car entries))
- (node (ewoc-nth vc-ewoc 0))
- (to-remove nil)
- (dotname (file-relative-name default-directory)))
- ;; Insert . if it is not present.
- (unless node
- (ewoc-enter-last
- vc-ewoc (vc-dir-create-fileinfo
- dotname nil nil nil default-directory))
- (setq node (ewoc-nth vc-ewoc 0)))
-
- (while (and entry node)
- (let* ((entryfile (car entry))
- (entrydir (file-name-directory (directory-file-name
- (expand-file-name entryfile))))
- (nodedir (vc-dir-node-directory node)))
- (cond
- ;; First try to find the directory.
- ((string-lessp nodedir entrydir)
- (setq node (ewoc-next vc-ewoc node)))
- ((string-equal nodedir entrydir)
- ;; Found the directory, find the place for the file name.
- (let ((nodefile (vc-dir-fileinfo->name (ewoc-data node))))
- (cond
- ((string= nodefile dotname)
- (setq node (ewoc-next vc-ewoc node)))
- ((string-lessp nodefile entryfile)
- (setq node (ewoc-next vc-ewoc node)))
- ((string-equal nodefile entryfile)
- (if (nth 1 entry)
- (progn
- (setf (vc-dir-fileinfo->state (ewoc-data node)) (nth 1 entry))
- (setf (vc-dir-fileinfo->extra (ewoc-data node)) (nth 2 entry))
- (setf (vc-dir-fileinfo->needs-update (ewoc-data node)) nil)
- (ewoc-invalidate vc-ewoc node))
- ;; If the state is nil, the file does not exist
- ;; anymore, so remember the entry so we can remove
- ;; it after we are done inserting all ENTRIES.
- (push node to-remove))
- (setq entries (cdr entries))
- (setq entry (car entries))
- (setq node (ewoc-next vc-ewoc node)))
- (t
- (ewoc-enter-before vc-ewoc node
- (apply 'vc-dir-create-fileinfo entry))
- (setq entries (cdr entries))
- (setq entry (car entries))))))
- (t
- ;; We might need to insert a directory node if the
- ;; previous node was in a different directory.
- (let* ((rd (file-relative-name entrydir))
- (prev-node (ewoc-prev vc-ewoc node))
- (prev-dir (vc-dir-node-directory prev-node)))
- (unless (string-equal entrydir prev-dir)
- (ewoc-enter-before
- vc-ewoc node (vc-dir-create-fileinfo rd nil nil nil entrydir))))
- ;; Now insert the node itself.
- (ewoc-enter-before vc-ewoc node
- (apply 'vc-dir-create-fileinfo entry))
- (setq entries (cdr entries) entry (car entries))))))
- ;; We're past the last node, all remaining entries go to the end.
- (unless (or node noinsert)
- (let ((lastdir (vc-dir-node-directory (ewoc-nth vc-ewoc -1))))
- (dolist (entry entries)
- (let ((entrydir (file-name-directory
- (directory-file-name (expand-file-name (car entry))))))
- ;; Insert a directory node if needed.
- (unless (string-equal lastdir entrydir)
- (setq lastdir entrydir)
- (let ((rd (file-relative-name entrydir)))
- (ewoc-enter-last
- vc-ewoc (vc-dir-create-fileinfo rd nil nil nil entrydir))))
- ;; Now insert the node itself.
- (ewoc-enter-last vc-ewoc
- (apply 'vc-dir-create-fileinfo entry))))))
- (when to-remove
- (let ((inhibit-read-only t))
- (apply 'ewoc-delete vc-ewoc (nreverse to-remove)))))))
-
-(defun vc-dir-busy ()
- (and (buffer-live-p vc-dir-process-buffer)
- (get-buffer-process vc-dir-process-buffer)))
-
-(defun vc-dir-kill-dir-status-process ()
- "Kill the temporary buffer and associated process."
- (interactive)
- (when (buffer-live-p vc-dir-process-buffer)
- (let ((proc (get-buffer-process vc-dir-process-buffer)))
- (when proc (delete-process proc))
- (setq vc-dir-process-buffer nil)
- (setq mode-line-process nil))))
-
-(defun vc-dir-kill-query ()
- ;; Make sure that when the status buffer is killed the update
- ;; process running in background is also killed.
- (if (vc-dir-busy)
- (when (y-or-n-p "Status update process running, really kill status buffer? ")
- (vc-dir-kill-dir-status-process)
- t)
- t))
-
-(defun vc-dir-next-line (arg)
- "Go to the next line.
-If a prefix argument is given, move by that many lines."
- (interactive "p")
- (with-no-warnings
- (ewoc-goto-next vc-ewoc arg)
- (vc-dir-move-to-goal-column)))
-
-(defun vc-dir-previous-line (arg)
- "Go to the previous line.
-If a prefix argument is given, move by that many lines."
- (interactive "p")
- (ewoc-goto-prev vc-ewoc arg)
- (vc-dir-move-to-goal-column))
-
-(defun vc-dir-next-directory ()
- "Go to the next directory."
- (interactive)
- (let ((orig (point)))
- (if
- (catch 'foundit
- (while t
- (let* ((next (ewoc-next vc-ewoc (ewoc-locate vc-ewoc))))
- (cond ((not next)
- (throw 'foundit t))
- (t
- (progn
- (ewoc-goto-node vc-ewoc next)
- (vc-dir-move-to-goal-column)
- (if (vc-dir-fileinfo->directory (ewoc-data next))
- (throw 'foundit nil))))))))
- (goto-char orig))))
-
-(defun vc-dir-previous-directory ()
- "Go to the previous directory."
- (interactive)
- (let ((orig (point)))
- (if
- (catch 'foundit
- (while t
- (let* ((prev (ewoc-prev vc-ewoc (ewoc-locate vc-ewoc))))
- (cond ((not prev)
- (throw 'foundit t))
- (t
- (progn
- (ewoc-goto-node vc-ewoc prev)
- (vc-dir-move-to-goal-column)
- (if (vc-dir-fileinfo->directory (ewoc-data prev))
- (throw 'foundit nil))))))))
- (goto-char orig))))
-
-(defun vc-dir-mark-unmark (mark-unmark-function)
- (if (use-region-p)
- (let ((firstl (line-number-at-pos (region-beginning)))
- (lastl (line-number-at-pos (region-end))))
- (save-excursion
- (goto-char (region-beginning))
- (while (<= (line-number-at-pos) lastl)
- (funcall mark-unmark-function))))
- (funcall mark-unmark-function)))
-
-(defun vc-dir-parent-marked-p (arg)
- ;; Return nil if none of the parent directories of arg is marked.
- (let* ((argdir (vc-dir-node-directory arg))
- (arglen (length argdir))
- (crt arg)
- data dir)
- ;; Go through the predecessors, checking if any directory that is
- ;; a parent is marked.
- (while (setq crt (ewoc-prev vc-ewoc crt))
- (setq data (ewoc-data crt))
- (setq dir (vc-dir-node-directory crt))
- (when (and (vc-dir-fileinfo->directory data)
- (vc-string-prefix-p dir argdir))
- (when (vc-dir-fileinfo->marked data)
- (error "Cannot mark `%s', parent directory `%s' marked"
- (vc-dir-fileinfo->name (ewoc-data arg))
- (vc-dir-fileinfo->name data)))))
- nil))
-
-(defun vc-dir-children-marked-p (arg)
- ;; Return nil if none of the children of arg is marked.
- (let* ((argdir-re (concat "\\`" (regexp-quote (vc-dir-node-directory arg))))
- (is-child t)
- (crt arg)
- data dir)
- (while (and is-child (setq crt (ewoc-next vc-ewoc crt)))
- (setq data (ewoc-data crt))
- (setq dir (vc-dir-node-directory crt))
- (if (string-match argdir-re dir)
- (when (vc-dir-fileinfo->marked data)
- (error "Cannot mark `%s', child `%s' marked"
- (vc-dir-fileinfo->name (ewoc-data arg))
- (vc-dir-fileinfo->name data)))
- ;; We are done, we got to an entry that is not a child of `arg'.
- (setq is-child nil)))
- nil))
-
-(defun vc-dir-mark-file (&optional arg)
- ;; Mark ARG or the current file and move to the next line.
- (let* ((crt (or arg (ewoc-locate vc-ewoc)))
- (file (ewoc-data crt))
- (isdir (vc-dir-fileinfo->directory file)))
- (when (or (and isdir (not (vc-dir-children-marked-p crt)))
- (and (not isdir) (not (vc-dir-parent-marked-p crt))))
- (setf (vc-dir-fileinfo->marked file) t)
- (ewoc-invalidate vc-ewoc crt)
- (unless (or arg (mouse-event-p last-command-event))
- (vc-dir-next-line 1)))))
-
-(defun vc-dir-mark ()
- "Mark the current file or all files in the region.
-If the region is active, mark all the files in the region.
-Otherwise mark the file on the current line and move to the next
-line."
- (interactive)
- (vc-dir-mark-unmark 'vc-dir-mark-file))
-
-(defun vc-dir-mark-all-files (arg)
- "Mark all files with the same state as the current one.
-With a prefix argument mark all files.
-If the current entry is a directory, mark all child files.
-
-The commands operate on files that are on the same state.
-This command is intended to make it easy to select all files that
-share the same state."
- (interactive "P")
- (if arg
- ;; Mark all files.
- (progn
- ;; First check that no directory is marked, we can't mark
- ;; files in that case.
- (ewoc-map
- (lambda (filearg)
- (when (and (vc-dir-fileinfo->directory filearg)
- (vc-dir-fileinfo->marked filearg))
- (error "Cannot mark all files, directory `%s' marked"
- (vc-dir-fileinfo->name filearg))))
- vc-ewoc)
- (ewoc-map
- (lambda (filearg)
- (unless (vc-dir-fileinfo->marked filearg)
- (setf (vc-dir-fileinfo->marked filearg) t)
- t))
- vc-ewoc))
- (let ((data (ewoc-data (ewoc-locate vc-ewoc))))
- (if (vc-dir-fileinfo->directory data)
- ;; It's a directory, mark child files.
- (let ((crt (ewoc-locate vc-ewoc)))
- (unless (vc-dir-children-marked-p crt)
- (while (setq crt (ewoc-next vc-ewoc crt))
- (let ((crt-data (ewoc-data crt)))
- (unless (vc-dir-fileinfo->directory crt-data)
- (setf (vc-dir-fileinfo->marked crt-data) t)
- (ewoc-invalidate vc-ewoc crt))))))
- ;; It's a file
- (let ((state (vc-dir-fileinfo->state data))
- (crt (ewoc-nth vc-ewoc 0)))
- (while crt
- (let ((crt-data (ewoc-data crt)))
- (when (and (not (vc-dir-fileinfo->marked crt-data))
- (eq (vc-dir-fileinfo->state crt-data) state)
- (not (vc-dir-fileinfo->directory crt-data)))
- (vc-dir-mark-file crt)))
- (setq crt (ewoc-next vc-ewoc crt))))))))
-
-(defun vc-dir-unmark-file ()
- ;; Unmark the current file and move to the next line.
- (let* ((crt (ewoc-locate vc-ewoc))
- (file (ewoc-data crt)))
- (setf (vc-dir-fileinfo->marked file) nil)
- (ewoc-invalidate vc-ewoc crt)
- (unless (mouse-event-p last-command-event)
- (vc-dir-next-line 1))))
-
-(defun vc-dir-unmark ()
- "Unmark the current file or all files in the region.
-If the region is active, unmark all the files in the region.
-Otherwise mark the file on the current line and move to the next
-line."
- (interactive)
- (vc-dir-mark-unmark 'vc-dir-unmark-file))
-
-(defun vc-dir-unmark-file-up ()
- "Move to the previous line and unmark the file."
- (interactive)
- ;; If we're on the first line, we won't move up, but we will still
- ;; remove the mark. This seems a bit odd but it is what buffer-menu
- ;; does.
- (let* ((prev (ewoc-goto-prev vc-ewoc 1))
- (file (ewoc-data prev)))
- (setf (vc-dir-fileinfo->marked file) nil)
- (ewoc-invalidate vc-ewoc prev)
- (vc-dir-move-to-goal-column)))
-
-(defun vc-dir-unmark-all-files (arg)
- "Unmark all files with the same state as the current one.
-With a prefix argument unmark all files.
-If the current entry is a directory, unmark all the child files.
-
-The commands operate on files that are on the same state.
-This command is intended to make it easy to deselect all files
-that share the same state."
- (interactive "P")
- (if arg
- (ewoc-map
- (lambda (filearg)
- (when (vc-dir-fileinfo->marked filearg)
- (setf (vc-dir-fileinfo->marked filearg) nil)
- t))
- vc-ewoc)
- (let* ((crt (ewoc-locate vc-ewoc))
- (data (ewoc-data crt)))
- (if (vc-dir-fileinfo->directory data)
- ;; It's a directory, unmark child files.
- (while (setq crt (ewoc-next vc-ewoc crt))
- (let ((crt-data (ewoc-data crt)))
- (unless (vc-dir-fileinfo->directory crt-data)
- (setf (vc-dir-fileinfo->marked crt-data) nil)
- (ewoc-invalidate vc-ewoc crt))))
- ;; It's a file
- (let ((crt-state (vc-dir-fileinfo->state (ewoc-data crt))))
- (ewoc-map
- (lambda (filearg)
- (when (and (vc-dir-fileinfo->marked filearg)
- (eq (vc-dir-fileinfo->state filearg) crt-state))
- (setf (vc-dir-fileinfo->marked filearg) nil)
- t))
- vc-ewoc))))))
-
-(defun vc-dir-toggle-mark-file ()
- (let* ((crt (ewoc-locate vc-ewoc))
- (file (ewoc-data crt)))
- (if (vc-dir-fileinfo->marked file)
- (vc-dir-unmark-file)
- (vc-dir-mark-file))))
-
-(defun vc-dir-toggle-mark (e)
- (interactive "e")
- (vc-dir-at-event e (vc-dir-mark-unmark 'vc-dir-toggle-mark-file)))
-
-(defun vc-dir-delete-file ()
- "Delete the marked files, or the current file if no marks."
- (interactive)
- (mapc 'vc-delete-file (or (vc-dir-marked-files)
- (list (vc-dir-current-file)))))
-
-(defun vc-dir-find-file ()
- "Find the file on the current line."
- (interactive)
- (find-file (vc-dir-current-file)))
-
-(defun vc-dir-find-file-other-window (&optional event)
- "Find the file on the current line, in another window."
- (interactive (list last-nonmenu-event))
- (if event (posn-set-point (event-end event)))
- (find-file-other-window (vc-dir-current-file)))
-
-(defun vc-dir-isearch ()
- "Search for a string through all marked buffers using Isearch."
- (interactive)
- (multi-isearch-files
- (mapcar 'car (vc-dir-marked-only-files-and-states))))
-
-(defun vc-dir-isearch-regexp ()
- "Search for a regexp through all marked buffers using Isearch."
- (interactive)
- (multi-isearch-files-regexp
- (mapcar 'car (vc-dir-marked-only-files-and-states))))
-
-(defun vc-dir-search (regexp)
- "Search through all marked files for a match for REGEXP.
-For marked directories, use the files displayed from those directories.
-Stops when a match is found.
-To continue searching for next match, use command \\[tags-loop-continue]."
- (interactive "sSearch marked files (regexp): ")
- (tags-search regexp '(mapcar 'car (vc-dir-marked-only-files-and-states))))
-
-(defun vc-dir-query-replace-regexp (from to &optional delimited)
- "Do `query-replace-regexp' of FROM with TO, on all marked files.
-For marked directories, use the files displayed from those directories.
-If a directory is marked, then use the files displayed for that directory.
-Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
-If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
-with the command \\[tags-loop-continue]."
- ;; FIXME: this is almost a copy of `dired-do-replace-regexp'. This
- ;; should probably be made generic and used in both places instead of
- ;; duplicating it here.
- (interactive
- (let ((common
- (query-replace-read-args
- "Query replace regexp in marked files" t t)))
- (list (nth 0 common) (nth 1 common) (nth 2 common))))
- (dolist (file (mapcar 'car (vc-dir-marked-only-files-and-states)))
- (let ((buffer (get-file-buffer file)))
- (if (and buffer (with-current-buffer buffer
- buffer-read-only))
- (error "File `%s' is visited read-only" file))))
- (tags-query-replace from to delimited
- '(mapcar 'car (vc-dir-marked-only-files-and-states))))
-
-(defun vc-dir-current-file ()
- (let ((node (ewoc-locate vc-ewoc)))
- (unless node
- (error "No file available"))
- (expand-file-name (vc-dir-fileinfo->name (ewoc-data node)))))
-
-(defun vc-dir-marked-files ()
- "Return the list of marked files."
- (mapcar
- (lambda (elem) (expand-file-name (vc-dir-fileinfo->name elem)))
- (ewoc-collect vc-ewoc 'vc-dir-fileinfo->marked)))
-
-(defun vc-dir-marked-only-files-and-states ()
- "Return the list of conses (FILE . STATE) for the marked files.
-For marked directories return the corresponding conses for the
-child files."
- (let ((crt (ewoc-nth vc-ewoc 0))
- result)
- (while crt
- (let ((crt-data (ewoc-data crt)))
- (if (vc-dir-fileinfo->marked crt-data)
- ;; FIXME: use vc-dir-child-files-and-states here instead of duplicating it.
- (if (vc-dir-fileinfo->directory crt-data)
- (let* ((dir (vc-dir-fileinfo->directory crt-data))
- (dirlen (length dir))
- data)
- (while
- (and (setq crt (ewoc-next vc-ewoc crt))
- (vc-string-prefix-p dir
- (progn
- (setq data (ewoc-data crt))
- (vc-dir-node-directory crt))))
- (unless (vc-dir-fileinfo->directory data)
- (push
- (cons (expand-file-name (vc-dir-fileinfo->name data))
- (vc-dir-fileinfo->state data))
- result))))
- (push (cons (expand-file-name (vc-dir-fileinfo->name crt-data))
- (vc-dir-fileinfo->state crt-data))
- result)
- (setq crt (ewoc-next vc-ewoc crt)))
- (setq crt (ewoc-next vc-ewoc crt)))))
- (nreverse result)))
-
-(defun vc-dir-child-files-and-states ()
- "Return the list of conses (FILE . STATE) for child files of the current entry if it's a directory.
-If it is a file, return the corresponding cons for the file itself."
- (let* ((crt (ewoc-locate vc-ewoc))
- (crt-data (ewoc-data crt))
- result)
- (if (vc-dir-fileinfo->directory crt-data)
- (let* ((dir (vc-dir-fileinfo->directory crt-data))
- (dirlen (length dir))
- data)
- (while
- (and (setq crt (ewoc-next vc-ewoc crt))
- (vc-string-prefix-p dir (progn
- (setq data (ewoc-data crt))
- (vc-dir-node-directory crt))))
- (unless (vc-dir-fileinfo->directory data)
- (push
- (cons (expand-file-name (vc-dir-fileinfo->name data))
- (vc-dir-fileinfo->state data))
- result))))
- (push
- (cons (expand-file-name (vc-dir-fileinfo->name crt-data))
- (vc-dir-fileinfo->state crt-data)) result))
- (nreverse result)))
-
-(defun vc-dir-recompute-file-state (fname def-dir)
- (let* ((file-short (file-relative-name fname def-dir))
- (remove-me-when-CVS-works
- (when (eq vc-dir-backend 'CVS)
- ;; FIXME: Warning: UGLY HACK. The CVS backend caches the state
- ;; info, this forces the backend to update it.
- (vc-call-backend vc-dir-backend 'registered fname)))
- (state (vc-call-backend vc-dir-backend 'state fname))
- (extra (vc-call-backend vc-dir-backend
- 'status-fileinfo-extra fname)))
- (list file-short state extra)))
-
-(defun vc-dir-find-child-files (dirname)
- ;; Give a DIRNAME string return the list of all child files shown in
- ;; the current *vc-dir* buffer.
- (let ((crt (ewoc-nth vc-ewoc 0))
- children
- dname)
- ;; Find DIR
- (while (and crt (not (vc-string-prefix-p
- dirname (vc-dir-node-directory crt))))
- (setq crt (ewoc-next vc-ewoc crt)))
- (while (and crt (vc-string-prefix-p
- dirname
- (setq dname (vc-dir-node-directory crt))))
- (let ((data (ewoc-data crt)))
- (unless (vc-dir-fileinfo->directory data)
- (push (expand-file-name (vc-dir-fileinfo->name data)) children)))
- (setq crt (ewoc-next vc-ewoc crt)))
- children))
-
-(defun vc-dir-resync-directory-files (dirname)
- ;; Update the entries for all the child files of DIRNAME shown in
- ;; the current *vc-dir* buffer.
- (let ((files (vc-dir-find-child-files dirname))
- (ddir default-directory)
- fileentries)
- (when files
- (dolist (crt files)
- (push (vc-dir-recompute-file-state crt ddir)
- fileentries))
- (vc-dir-update fileentries (current-buffer)))))
-
-(defun vc-dir-resynch-file (&optional fname)
- "Update the entries for FNAME in any directory buffers that list it."
- (let ((file (or fname (expand-file-name buffer-file-name)))
- (drop '()))
- (save-current-buffer
- ;; look for a vc-dir buffer that might show this file.
- (dolist (status-buf vc-dir-buffers)
- (if (not (buffer-live-p status-buf))
- (push status-buf drop)
- (set-buffer status-buf)
- (if (not (derived-mode-p 'vc-dir-mode))
- (push status-buf drop)
- (let ((ddir default-directory))
- (when (vc-string-prefix-p ddir file)
- (if (file-directory-p file)
- (progn
- (vc-dir-resync-directory-files file)
- (ewoc-set-hf vc-ewoc
- (vc-dir-headers vc-dir-backend default-directory) ""))
- (let ((state (vc-dir-recompute-file-state file ddir)))
- (vc-dir-update
- (list state)
- status-buf (eq (cadr state) 'up-to-date))))))))))
- ;; Remove out-of-date entries from vc-dir-buffers.
- (dolist (b drop) (setq vc-dir-buffers (delq b vc-dir-buffers)))))
-
-(defvar use-vc-backend) ;; dynamically bound
-
-(define-derived-mode vc-dir-mode special-mode "VC dir"
- "Major mode for VC directory buffers.
-Marking/Unmarking key bindings and actions:
-m - mark a file/directory
- - if the region is active, mark all the files in region.
- Restrictions: - a file cannot be marked if any parent directory is marked
- - a directory cannot be marked if any child file or
- directory is marked
-u - unmark a file/directory
- - if the region is active, unmark all the files in region.
-M - if the cursor is on a file: mark all the files with the same state as
- the current file
- - if the cursor is on a directory: mark all child files
- - with a prefix argument: mark all files
-U - if the cursor is on a file: unmark all the files with the same state
- as the current file
- - if the cursor is on a directory: unmark all child files
- - with a prefix argument: unmark all files
-mouse-2 - toggles the mark state
-
-VC commands
-VC commands in the `C-x v' prefix can be used.
-VC commands act on the marked entries. If nothing is marked, VC
-commands act on the current entry.
-
-Search & Replace
-S - searches the marked files
-Q - does a query replace on the marked files
-M-s a C-s - does an isearch on the marked files
-M-s a C-M-s - does a regexp isearch on the marked files
-If nothing is marked, these commands act on the current entry.
-When a directory is current or marked, the Search & Replace
-commands act on the child files of that directory that are displayed in
-the *vc-dir* buffer.
-
-\\{vc-dir-mode-map}"
- (set (make-local-variable 'vc-dir-backend) use-vc-backend)
- (setq buffer-read-only t)
- (when (boundp 'tool-bar-map)
- (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map))
- (let ((buffer-read-only nil))
- (erase-buffer)
- (set (make-local-variable 'vc-dir-process-buffer) nil)
- (set (make-local-variable 'vc-ewoc) (ewoc-create #'vc-dir-printer))
- (set (make-local-variable 'revert-buffer-function)
- 'vc-dir-revert-buffer-function)
- (setq list-buffers-directory (expand-file-name "*vc-dir*" default-directory))
- (add-to-list 'vc-dir-buffers (current-buffer))
- ;; Make sure that if the directory buffer is killed, the update
- ;; process running in the background is also killed.
- (add-hook 'kill-buffer-query-functions 'vc-dir-kill-query nil t)
- (hack-dir-local-variables-non-file-buffer)
- (vc-dir-refresh)))
-
-(defun vc-dir-headers (backend dir)
- "Display the headers in the *VC dir* buffer.
-It calls the `dir-extra-headers' backend method to display backend
-specific headers."
- (concat
- ;; First layout the common headers.
- (propertize "VC backend : " 'face 'font-lock-type-face)
- (propertize (format "%s\n" backend) 'face 'font-lock-variable-name-face)
- (propertize "Working dir: " 'face 'font-lock-type-face)
- (propertize (format "%s\n" (abbreviate-file-name dir))
- 'face 'font-lock-variable-name-face)
- ;; Then the backend specific ones.
- (vc-call-backend backend 'dir-extra-headers dir)
- "\n"))
-
-(defun vc-dir-refresh-files (files default-state)
- "Refresh some files in the *VC-dir* buffer."
- (let ((def-dir default-directory)
- (backend vc-dir-backend))
- (vc-set-mode-line-busy-indicator)
- ;; Call the `dir-status-file' backend function.
- ;; `dir-status-file' is supposed to be asynchronous.
- ;; It should compute the results, and then call the function
- ;; passed as an argument in order to update the vc-dir buffer
- ;; with the results.
- (unless (buffer-live-p vc-dir-process-buffer)
- (setq vc-dir-process-buffer
- (generate-new-buffer (format " *VC-%s* tmp status" backend))))
- (lexical-let ((buffer (current-buffer)))
- (with-current-buffer vc-dir-process-buffer
- (cd def-dir)
- (erase-buffer)
- (vc-call-backend
- backend 'dir-status-files def-dir files default-state
- (lambda (entries &optional more-to-come)
- ;; ENTRIES is a list of (FILE VC_STATE EXTRA) items.
- ;; If MORE-TO-COME is true, then more updates will come from
- ;; the asynchronous process.
- (with-current-buffer buffer
- (vc-dir-update entries buffer)
- (unless more-to-come
- (setq mode-line-process nil)
- ;; Remove the ones that haven't been updated at all.
- ;; Those not-updated are those whose state is nil because the
- ;; file/dir doesn't exist and isn't versioned.
- (ewoc-filter vc-ewoc
- (lambda (info)
- ;; The state for directory entries might
- ;; have been changed to 'up-to-date,
- ;; reset it, othewise it will be removed when doing 'x'
- ;; next time.
- ;; FIXME: There should be a more elegant way to do this.
- (when (and (vc-dir-fileinfo->directory info)
- (eq (vc-dir-fileinfo->state info)
- 'up-to-date))
- (setf (vc-dir-fileinfo->state info) nil))
-
- (not (vc-dir-fileinfo->needs-update info))))))))))))
-
-(defun vc-dir-revert-buffer-function (&optional ignore-auto noconfirm)
- (vc-dir-refresh))
-
-(defun vc-dir-refresh ()
- "Refresh the contents of the *VC-dir* buffer.
-Throw an error if another update process is in progress."
- (interactive)
- (if (vc-dir-busy)
- (error "Another update process is in progress, cannot run two at a time")
- (let ((def-dir default-directory)
- (backend vc-dir-backend))
- (vc-set-mode-line-busy-indicator)
- ;; Call the `dir-status' backend function.
- ;; `dir-status' is supposed to be asynchronous.
- ;; It should compute the results, and then call the function
- ;; passed as an argument in order to update the vc-dir buffer
- ;; with the results.
-
- ;; Create a buffer that can be used by `dir-status' and call
- ;; `dir-status' with this buffer as the current buffer. Use
- ;; `vc-dir-process-buffer' to remember this buffer, so that
- ;; it can be used later to kill the update process in case it
- ;; takes too long.
- (unless (buffer-live-p vc-dir-process-buffer)
- (setq vc-dir-process-buffer
- (generate-new-buffer (format " *VC-%s* tmp status" backend))))
- ;; set the needs-update flag on all non-directory entries
- (ewoc-map (lambda (info)
- (unless (vc-dir-fileinfo->directory info)
- (setf (vc-dir-fileinfo->needs-update info) t) nil))
- vc-ewoc)
- (lexical-let ((buffer (current-buffer)))
- (with-current-buffer vc-dir-process-buffer
- (cd def-dir)
- (erase-buffer)
- (vc-call-backend
- backend 'dir-status def-dir
- (lambda (entries &optional more-to-come)
- ;; ENTRIES is a list of (FILE VC_STATE EXTRA) items.
- ;; If MORE-TO-COME is true, then more updates will come from
- ;; the asynchronous process.
- (with-current-buffer buffer
- (vc-dir-update entries buffer)
- (unless more-to-come
- (let ((remaining
- (ewoc-collect
- vc-ewoc 'vc-dir-fileinfo->needs-update)))
- (if remaining
- (vc-dir-refresh-files
- (mapcar 'vc-dir-fileinfo->name remaining)
- 'up-to-date)
- (setq mode-line-process nil)))))))))
- (ewoc-set-hf vc-ewoc (vc-dir-headers backend def-dir) ""))))
-
-(defun vc-dir-show-fileentry (file)
- "Insert an entry for a specific file into the current *VC-dir* listing.
-This is typically used if the file is up-to-date (or has been added
-outside of VC) and one wants to do some operation on it."
- (interactive "fShow file: ")
- (vc-dir-update (list (list (file-relative-name file) (vc-state file))) (current-buffer)))
-
-(defun vc-dir-hide-up-to-date ()
- "Hide up-to-date items from display."
- (interactive)
- (let ((crt (ewoc-nth vc-ewoc -1))
- (first (ewoc-nth vc-ewoc 0)))
- ;; Go over from the last item to the first and remove the
- ;; up-to-date files and directories with no child files.
- (while (not (eq crt first))
- (let* ((data (ewoc-data crt))
- (dir (vc-dir-fileinfo->directory data))
- (next (ewoc-next vc-ewoc crt))
- (prev (ewoc-prev vc-ewoc crt))
- ;; ewoc-delete does not work without this...
- (inhibit-read-only t))
- (when (or
- ;; Remove directories with no child files.
- (and dir
- (or
- ;; Nothing follows this directory.
- (not next)
- ;; Next item is a directory.
- (vc-dir-fileinfo->directory (ewoc-data next))))
- ;; Remove files in the up-to-date state.
- (eq (vc-dir-fileinfo->state data) 'up-to-date))
- (ewoc-delete vc-ewoc crt))
- (setq crt prev)))))
-
-(defun vc-dir-kill-line ()
- "Remove the current line from display."
- (interactive)
- (let ((crt (ewoc-locate vc-ewoc))
- (inhibit-read-only t))
- (ewoc-delete vc-ewoc crt)))
-
-(defun vc-dir-printer (fileentry)
- (vc-call-backend vc-dir-backend 'dir-printer fileentry))
-
-(defun vc-dir-deduce-fileset (&optional state-model-only-files)
- (let ((marked (vc-dir-marked-files))
- files
- only-files-list
- state
- model)
- (if marked
- (progn
- (setq files marked)
- (when state-model-only-files
- (setq only-files-list (vc-dir-marked-only-files-and-states))))
- (let ((crt (vc-dir-current-file)))
- (setq files (list crt))
- (when state-model-only-files
- (setq only-files-list (vc-dir-child-files-and-states)))))
-
- (when state-model-only-files
- (setq state (cdar only-files-list))
- ;; Check that all files are in a consistent state, since we use that
- ;; state to decide which operation to perform.
- (dolist (crt (cdr only-files-list))
- (unless (vc-compatible-state (cdr crt) state)
- (error "When applying VC operations to multiple files, the files are required\nto be in similar VC states.\n%s in state %s clashes with %s in state %s"
- (car crt) (cdr crt) (caar only-files-list) state)))
- (setq only-files-list (mapcar 'car only-files-list))
- (when (and state (not (eq state 'unregistered)))
- (setq model (vc-checkout-model vc-dir-backend only-files-list))))
- (list vc-dir-backend files only-files-list state model)))
-
-;;;###autoload
-(defun vc-dir (dir &optional backend)
- "Show the VC status for \"interesting\" files in and below DIR.
-This allows you to mark files and perform VC operations on them.
-The list omits files which are up to date, with no changes in your copy
-or the repository, if there is nothing in particular to say about them.
-
-Preparing the list of file status takes time; when the buffer
-first appears, it has only the first few lines of summary information.
-The file lines appear later.
-
-Optional second argument BACKEND specifies the VC backend to use.
-Interactively, a prefix argument means to ask for the backend.
-
-These are the commands available for use in the file status buffer:
-
-\\{vc-dir-mode-map}"
-
- (interactive
- (list
- ;; When you hit C-x v d in a visited VC file,
- ;; the *vc-dir* buffer visits the directory under its truename;
- ;; therefore it makes sense to always do that.
- ;; Otherwise if you do C-x v d -> C-x C-f -> C-c v d
- ;; you may get a new *vc-dir* buffer, different from the original
- (file-truename (read-file-name "VC status for directory: "
- default-directory default-directory t
- nil #'file-directory-p))
- (if current-prefix-arg
- (intern
- (completing-read
- "Use VC backend: "
- (mapcar (lambda (b) (list (symbol-name b)))
- vc-handled-backends)
- nil t nil nil)))))
- (unless backend
- (setq backend (vc-responsible-backend dir)))
- (let (pop-up-windows) ; based on cvs-examine; bug#6204
- (pop-to-buffer (vc-dir-prepare-status-buffer "*vc-dir*" dir backend)))
- (if (derived-mode-p 'vc-dir-mode)
- (vc-dir-refresh)
- ;; FIXME: find a better way to pass the backend to `vc-dir-mode'.
- (let ((use-vc-backend backend))
- (vc-dir-mode))))
-
-(defun vc-default-dir-extra-headers (backend dir)
- ;; Be loud by default to remind people to add code to display
- ;; backend specific headers.
- ;; XXX: change this to return nil before the release.
- (concat
- (propertize "Extra : " 'face 'font-lock-type-face)
- (propertize "Please add backend specific headers here. It's easy!"
- 'face 'font-lock-warning-face)))
-
-(defvar vc-dir-filename-mouse-map
- (let ((map (make-sparse-keymap)))
- (define-key map [mouse-2] 'vc-dir-find-file-other-window)
- map)
- "Local keymap for visiting a file.")
-
-(defun vc-default-dir-printer (backend fileentry)
- "Pretty print FILEENTRY."
- ;; If you change the layout here, change vc-dir-move-to-goal-column.
- ;; VC backends can implement backend specific versions of this
- ;; function. Changes here might need to be reflected in the
- ;; vc-BACKEND-dir-printer functions.
- (let* ((isdir (vc-dir-fileinfo->directory fileentry))
- (state (if isdir "" (vc-dir-fileinfo->state fileentry)))
- (filename (vc-dir-fileinfo->name fileentry)))
- (insert
- (propertize
- (format "%c" (if (vc-dir-fileinfo->marked fileentry) ?* ? ))
- 'face 'font-lock-type-face)
- " "
- (propertize
- (format "%-20s" state)
- 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
- ((memq state '(missing conflict)) 'font-lock-warning-face)
- (t 'font-lock-variable-name-face))
- 'mouse-face 'highlight)
- " "
- (propertize
- (format "%s" filename)
- 'face
- (if isdir 'font-lock-comment-delimiter-face 'font-lock-function-name-face)
- 'help-echo
- (if isdir
- "Directory\nVC operations can be applied to it\nmouse-3: Pop-up menu"
- "File\nmouse-3: Pop-up menu")
- 'mouse-face 'highlight
- 'keymap vc-dir-filename-mouse-map))))
-
-(defun vc-default-extra-status-menu (backend)
- nil)
-
-(defun vc-default-status-fileinfo-extra (backend file)
- "Default absence of extra information returned for a file."
- nil)
-
-(provide 'vc-dir)
-
-;; arch-tag: 0274a2e3-e8e9-4b1a-a73c-e8b9129d5d15
-;;; vc-dir.el ends here
+++ /dev/null
-;;; vc-dispatcher.el -- generic command-dispatcher facility.
-
-;; Copyright (C) 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Author: FSF (see below for full credits)
-;; Maintainer: Eric S. Raymond <esr@thyrsus.com>
-;; Keywords: tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Credits:
-
-;; Designed and implemented by Eric S. Raymond, originally as part of VC mode.
-;; Stefan Monnier and Dan Nicolaescu contributed substantial work on the
-;; vc-dir front end.
-
-;;; Commentary:
-
-;; Goals:
-;;
-;; There is a class of front-ending problems that Emacs might be used
-;; to address that involves selecting sets of files, or possibly
-;; directories, and passing the selection set to slave commands. The
-;; prototypical example, from which this code is derived, is talking
-;; to version-control systems.
-;;
-;; vc-dispatcher.el is written to decouple the UI issues in such front
-;; ends from their application-specific logic. It also provides a
-;; service layer for running the slave commands either synchronously
-;; or asynchronously and managing the message/error logs from the
-;; command runs.
-;;
-;; Similar UI problems can be expected to come up in applications
-;; areas other than VCSes; IDEs and document search are two obvious ones.
-;; This mode is intended to ensure that the Emacs interfaces for all such
-;; beasts are consistent and carefully designed. But even if nothing
-;; but VC ever uses it, getting the layer separation right will be
-;; a valuable thing.
-
-;; Dispatcher's universe:
-;;
-;; The universe consists of the file tree rooted at the current
-;; directory. The dispatcher's upper layer deduces some subset
-;; of the file tree from the state of the currently visited buffer
-;; and returns that subset, presumably to a client mode.
-;;
-;; The user may be looking at either of two different views; a buffer
-;; visiting a file, or a directory buffer generated by vc-dispatcher.
-;;
-;; The lower layer of this mode runs commands in subprocesses, either
-;; synchronously or asynchronously. Commands may be launched in one
-;; of two ways: they may be run immediately, or the calling mode can
-;; create a closure associated with a text-entry buffer, to be
-;; executed when the user types C-c to ship the buffer contents. In
-;; either case the command messages and error (if any) will remain
-;; available in a status buffer.
-
-;; Special behavior of dispatcher directory buffers:
-;;
-;; In dispatcher directory buffers, facilities to perform basic
-;; navigation and selection operations are provided by keymap and menu
-;; entries that dispatcher sets up itself, so they'll be uniform
-;; across all dispatcher-using client modes. Client modes are
-;; expected to append to these to provide mode-specific bindings.
-;;
-;; The standard map associates a 'state' slot (that the client mode
-;; may set) with each directory entry. The dispatcher knows nothing
-;; about the semantics of individual states, but mark and unmark commands
-;; treat all entries with the same state as the currently selected one as
-;; a unit.
-
-;; The interface:
-;;
-;; The main interface to the lower level is vc-do-command. This launches a
-;; command, synchronously or asynchronously, making the output available
-;; in a command log buffer. Two other functions, (vc-start-logentry) and
-;; (vc-finish-logentry), allow you to associate a command closure with an
-;; annotation buffer so that when the user confirms the comment the closure
-;; is run (with the comment as part of its context).
-;;
-;; The interface to the upper level has the two main entry points (vc-dir)
-;; and (vc-dispatcher-selection-set) and a couple of convenience functions.
-;; (vc-dir) sets up a dispatcher browsing buffer; (vc-dispatcher-selection-set)
-;; returns a selection set of files, either the marked files in a browsing
-;; buffer or the singleton set consisting of the file visited by the current
-;; buffer (when that is appropriate). It also does what is needed to ensure
-;; that on-disk files and the contents of their visiting Emacs buffers
-;; coincide.
-;;
-;; When the client mode adds a local vc-mode-line-hook to a buffer, it
-;; will be called with the buffer file name as argument whenever the
-;; dispatcher resynchs the buffer.
-
-;; To do:
-;;
-;; - log buffers need font-locking.
-;;
-
-;; General customization
-(defcustom vc-logentry-check-hook nil
- "Normal hook run by `vc-finish-logentry'.
-Use this to impose your own rules on the entry in addition to any the
-dispatcher client mode imposes itself."
- :type 'hook
- :group 'vc)
-
-(defcustom vc-delete-logbuf-window t
- "If non-nil, delete the log buffer and window after each logical action.
-If nil, bury that buffer instead.
-This is most useful if you have multiple windows on a frame and would like to
-preserve the setting."
- :type 'boolean
- :group 'vc)
-
-(defcustom vc-command-messages nil
- "If non-nil, display run messages from back-end commands."
- :type 'boolean
- :group 'vc)
-
-(defcustom vc-suppress-confirm nil
- "If non-nil, treat user as expert; suppress yes-no prompts on some things."
- :type 'boolean
- :group 'vc)
-
-;; Variables the user doesn't need to know about.
-
-(defvar vc-log-operation nil)
-(defvar vc-log-after-operation-hook nil)
-(defvar vc-log-fileset)
-
-;; In a log entry buffer, this is a local variable
-;; that points to the buffer for which it was made
-;; (either a file, or a directory buffer).
-(defvar vc-parent-buffer nil)
-(put 'vc-parent-buffer 'permanent-local t)
-(defvar vc-parent-buffer-name nil)
-(put 'vc-parent-buffer-name 'permanent-local t)
-
-;; Common command execution logic
-
-(defun vc-process-filter (p s)
- "An alternative output filter for async process P.
-One difference with the default filter is that this inserts S after markers.
-Another is that undo information is not kept."
- (let ((buffer (process-buffer p)))
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- (save-excursion
- (let ((buffer-undo-list t)
- (inhibit-read-only t))
- (goto-char (process-mark p))
- (insert s)
- (set-marker (process-mark p) (point))))))))
-
-(defun vc-setup-buffer (buf)
- "Prepare BUF for executing a slave command and make it current."
- (let ((camefrom (current-buffer))
- (olddir default-directory))
- (set-buffer (get-buffer-create buf))
- (kill-all-local-variables)
- (set (make-local-variable 'vc-parent-buffer) camefrom)
- (set (make-local-variable 'vc-parent-buffer-name)
- (concat " from " (buffer-name camefrom)))
- (setq default-directory olddir)
- (let ((buffer-undo-list t)
- (inhibit-read-only t))
- (erase-buffer))))
-
-(defvar vc-sentinel-movepoint) ;Dynamically scoped.
-
-(defun vc-process-sentinel (p s)
- (let ((previous (process-get p 'vc-previous-sentinel))
- (buf (process-buffer p)))
- ;; Impatient users sometime kill "slow" buffers; check liveness
- ;; to avoid "error in process sentinel: Selecting deleted buffer".
- (when (buffer-live-p buf)
- (when previous (funcall previous p s))
- (with-current-buffer buf
- (setq mode-line-process
- (let ((status (process-status p)))
- ;; Leave mode-line uncluttered, normally.
- (unless (eq 'exit status)
- (format " (%s)" status))))
- (let (vc-sentinel-movepoint)
- ;; Normally, we want async code such as sentinels to not move point.
- (save-excursion
- (goto-char (process-mark p))
- (let ((cmds (process-get p 'vc-sentinel-commands)))
- (process-put p 'vc-sentinel-commands nil)
- (dolist (cmd cmds)
- ;; Each sentinel may move point and the next one should be run
- ;; at that new point. We could get the same result by having
- ;; each sentinel read&set process-mark, but since `cmd' needs
- ;; to work both for async and sync processes, this would be
- ;; difficult to achieve.
- (vc-exec-after cmd))))
- ;; But sometimes the sentinels really want to move point.
- (when vc-sentinel-movepoint
- (let ((win (get-buffer-window (current-buffer) 0)))
- (if (not win)
- (goto-char vc-sentinel-movepoint)
- (with-selected-window win
- (goto-char vc-sentinel-movepoint))))))))))
-
-(defun vc-set-mode-line-busy-indicator ()
- (setq mode-line-process
- (concat " " (propertize "[waiting...]"
- 'face 'mode-line-emphasis
- 'help-echo
- "A command is in progress in this buffer"))))
-
-(defun vc-exec-after (code)
- "Eval CODE when the current buffer's process is done.
-If the current buffer has no process, just evaluate CODE.
-Else, add CODE to the process' sentinel."
- (let ((proc (get-buffer-process (current-buffer))))
- (cond
- ;; If there's no background process, just execute the code.
- ;; We used to explicitly call delete-process on exited processes,
- ;; but this led to timing problems causing process output to be
- ;; lost. Terminated processes get deleted automatically
- ;; anyway. -- cyd
- ((or (null proc) (eq (process-status proc) 'exit))
- ;; Make sure we've read the process's output before going further.
- (when proc (accept-process-output proc))
- (eval code))
- ;; If a process is running, add CODE to the sentinel
- ((eq (process-status proc) 'run)
- (vc-set-mode-line-busy-indicator)
- (let ((previous (process-sentinel proc)))
- (unless (eq previous 'vc-process-sentinel)
- (process-put proc 'vc-previous-sentinel previous))
- (set-process-sentinel proc 'vc-process-sentinel))
- (process-put proc 'vc-sentinel-commands
- ;; We keep the code fragments in the order given
- ;; so that vc-diff-finish's message shows up in
- ;; the presence of non-nil vc-command-messages.
- (append (process-get proc 'vc-sentinel-commands)
- (list code))))
- (t (error "Unexpected process state"))))
- nil)
-
-(defvar vc-post-command-functions nil
- "Hook run at the end of `vc-do-command'.
-Each function is called inside the buffer in which the command was run
-and is passed 3 arguments: the COMMAND, the FILES and the FLAGS.")
-
-(defvar w32-quote-process-args)
-
-(defun vc-delistify (filelist)
- "Smash a FILELIST into a file list string suitable for info messages."
- ;; FIXME what about file names with spaces?
- (if (not filelist) "." (mapconcat 'identity filelist " ")))
-
-;;;###autoload
-(defun vc-do-command (buffer okstatus command file-or-list &rest flags)
- "Execute a slave command, notifying user and checking for errors.
-Output from COMMAND goes to BUFFER, or the current buffer if
-BUFFER is t. If the destination buffer is not already current,
-set it up properly and erase it. The command is considered
-successful if its exit status does not exceed OKSTATUS (if
-OKSTATUS is nil, that means to ignore error status, if it is
-`async', that means not to wait for termination of the
-subprocess; if it is t it means to ignore all execution errors).
-FILE-OR-LIST is the name of a working file; it may be a list of
-files or be nil (to execute commands that don't expect a file
-name or set of files). If an optional list of FLAGS is present,
-that is inserted into the command line before the filename.
-Return the return value of the slave command in the synchronous
-case, and the process object in the asynchronous case."
- ;; FIXME: file-relative-name can return a bogus result because
- ;; it doesn't look at the actual file-system to see if symlinks
- ;; come into play.
- (let* ((files
- (mapcar (lambda (f) (file-relative-name (expand-file-name f)))
- (if (listp file-or-list) file-or-list (list file-or-list))))
- (full-command
- ;; What we're doing here is preparing a version of the command
- ;; for display in a debug-progress message. If it's fewer than
- ;; 20 characters display the entire command (without trailing
- ;; newline). Otherwise display the first 20 followed by an ellipsis.
- (concat (if (string= (substring command -1) "\n")
- (substring command 0 -1)
- command)
- " "
- (vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags))
- " " (vc-delistify files))))
- (save-current-buffer
- (unless (or (eq buffer t)
- (and (stringp buffer)
- (string= (buffer-name) buffer))
- (eq buffer (current-buffer)))
- (vc-setup-buffer buffer))
- ;; If there's some previous async process still running, just kill it.
- (let ((oldproc (get-buffer-process (current-buffer))))
- ;; If we wanted to wait for oldproc to finish before doing
- ;; something, we'd have used vc-eval-after.
- ;; Use `delete-process' rather than `kill-process' because we don't
- ;; want any of its output to appear from now on.
- (when oldproc (delete-process oldproc)))
- (let ((squeezed (remq nil flags))
- (inhibit-read-only t)
- (status 0))
- (when files
- (setq squeezed (nconc squeezed files)))
- (let (;; Since some functions need to parse the output
- ;; from external commands, set LC_MESSAGES to C.
- (process-environment (cons "LC_MESSAGES=C" process-environment))
- (w32-quote-process-args t))
- (if (eq okstatus 'async)
- ;; Run asynchronously.
- (let ((proc
- (let ((process-connection-type nil))
- (apply 'start-file-process command (current-buffer)
- command squeezed))))
- (when vc-command-messages
- (message "Running %s in background..." full-command))
- ;;(set-process-sentinel proc (lambda (p msg) (delete-process p)))
- (set-process-filter proc 'vc-process-filter)
- (setq status proc)
- (when vc-command-messages
- (vc-exec-after
- `(message "Running %s in background... done" ',full-command))))
- ;; Run synchronously
- (when vc-command-messages
- (message "Running %s in foreground..." full-command))
- (let ((buffer-undo-list t))
- (setq status (apply 'process-file command nil t nil squeezed)))
- (when (and (not (eq t okstatus))
- (or (not (integerp status))
- (and okstatus (< okstatus status))))
- (unless (eq ?\s (aref (buffer-name (current-buffer)) 0))
- (pop-to-buffer (current-buffer))
- (goto-char (point-min))
- (shrink-window-if-larger-than-buffer))
- (error "Running %s...FAILED (%s)" full-command
- (if (integerp status) (format "status %d" status) status)))
- (when vc-command-messages
- (message "Running %s...OK = %d" full-command status))))
- (vc-exec-after
- `(run-hook-with-args 'vc-post-command-functions
- ',command ',file-or-list ',flags))
- status))))
-
-;; These functions are used to ensure that the view the user sees is up to date
-;; even if the dispatcher client mode has messed with file contents (as in,
-;; for example, VCS keyword expansion).
-
-(declare-function view-mode-exit "view" (&optional return-to-alist exit-action all-win))
-
-(defun vc-position-context (posn)
- "Save a bit of the text around POSN in the current buffer.
-Used to help us find the corresponding position again later
-if markers are destroyed or corrupted."
- ;; A lot of this was shamelessly lifted from Sebastian Kremer's
- ;; rcs.el mode.
- (list posn
- (buffer-size)
- (buffer-substring posn
- (min (point-max) (+ posn 100)))))
-
-(defun vc-find-position-by-context (context)
- "Return the position of CONTEXT in the current buffer.
-If CONTEXT cannot be found, return nil."
- (let ((context-string (nth 2 context)))
- (if (equal "" context-string)
- (point-max)
- (save-excursion
- (let ((diff (- (nth 1 context) (buffer-size))))
- (when (< diff 0) (setq diff (- diff)))
- (goto-char (nth 0 context))
- (if (or (search-forward context-string nil t)
- ;; Can't use search-backward since the match may continue
- ;; after point.
- (progn (goto-char (- (point) diff (length context-string)))
- ;; goto-char doesn't signal an error at
- ;; beginning of buffer like backward-char would
- (search-forward context-string nil t)))
- ;; to beginning of OSTRING
- (- (point) (length context-string))))))))
-
-(defun vc-context-matches-p (posn context)
- "Return t if POSN matches CONTEXT, nil otherwise."
- (let* ((context-string (nth 2 context))
- (len (length context-string))
- (end (+ posn len)))
- (if (> end (1+ (buffer-size)))
- nil
- (string= context-string (buffer-substring posn end)))))
-
-(defun vc-buffer-context ()
- "Return a list (POINT-CONTEXT MARK-CONTEXT REPARSE).
-Used by `vc-restore-buffer-context' to later restore the context."
- (let ((point-context (vc-position-context (point)))
- ;; Use mark-marker to avoid confusion in transient-mark-mode.
- (mark-context (when (eq (marker-buffer (mark-marker)) (current-buffer))
- (vc-position-context (mark-marker))))
- ;; Make the right thing happen in transient-mark-mode.
- (mark-active nil))
- (list point-context mark-context nil)))
-
-(defun vc-restore-buffer-context (context)
- "Restore point/mark, and reparse any affected compilation buffers.
-CONTEXT is that which `vc-buffer-context' returns."
- (let ((point-context (nth 0 context))
- (mark-context (nth 1 context)))
- ;; if necessary, restore point and mark
- (if (not (vc-context-matches-p (point) point-context))
- (let ((new-point (vc-find-position-by-context point-context)))
- (when new-point (goto-char new-point))))
- (and mark-active
- mark-context
- (not (vc-context-matches-p (mark) mark-context))
- (let ((new-mark (vc-find-position-by-context mark-context)))
- (when new-mark (set-mark new-mark))))))
-
-(defun vc-revert-buffer-internal (&optional arg no-confirm)
- "Revert buffer, keeping point and mark where user expects them.
-Try to be clever in the face of changes due to expanded version-control
-key words. This is important for typeahead to work as expected.
-ARG and NO-CONFIRM are passed on to `revert-buffer'."
- (interactive "P")
- (widen)
- (let ((context (vc-buffer-context)))
- ;; Use save-excursion here, because it may be able to restore point
- ;; and mark properly even in cases where vc-restore-buffer-context
- ;; would fail. However, save-excursion might also get it wrong --
- ;; in this case, vc-restore-buffer-context gives it a second try.
- (save-excursion
- ;; t means don't call normal-mode;
- ;; that's to preserve various minor modes.
- (revert-buffer arg no-confirm t))
- (vc-restore-buffer-context context)))
-
-(defvar vc-mode-line-hook nil)
-(make-variable-buffer-local 'vc-mode-line-hook)
-(put 'vc-mode-line-hook 'permanent-local t)
-
-(defun vc-resynch-window (file &optional keep noquery reset-vc-info)
- "If FILE is in the current buffer, either revert or unvisit it.
-The choice between revert (to see expanded keywords) and unvisit
-depends on KEEP. NOQUERY if non-nil inhibits confirmation for
-reverting. NOQUERY should be t *only* if it is known the only
-difference between the buffer and the file is due to
-modifications by the dispatcher client code, rather than user
-editing!"
- (and (string= buffer-file-name file)
- (if keep
- (when (file-exists-p file)
- (when reset-vc-info
- (vc-file-clearprops file))
- (vc-revert-buffer-internal t noquery)
-
- ;; VC operations might toggle the read-only state. In
- ;; that case we need to adjust the `view-mode' status
- ;; when `view-read-only' is non-nil.
- (and view-read-only
- (if (file-writable-p file)
- (and view-mode
- (let ((view-old-buffer-read-only nil))
- (view-mode-exit)))
- (and (not view-mode)
- (not (eq (get major-mode 'mode-class) 'special))
- (view-mode-enter))))
-
- ;; FIXME: Why use a hook? Why pass it buffer-file-name?
- (run-hook-with-args 'vc-mode-line-hook buffer-file-name))
- (kill-buffer (current-buffer)))))
-
-(declare-function vc-dir-resynch-file "vc-dir" (&optional fname))
-(declare-function vc-string-prefix-p "vc" (prefix string))
-
-(defun vc-resynch-buffers-in-directory (directory &optional keep noquery reset-vc-info)
- "Resync all buffers that visit files in DIRECTORY."
- (dolist (buffer (buffer-list))
- (let ((fname (buffer-file-name buffer)))
- (when (and fname (vc-string-prefix-p directory fname))
- (with-current-buffer buffer
- (vc-resynch-buffer fname keep noquery reset-vc-info))))))
-
-(defun vc-resynch-buffer (file &optional keep noquery reset-vc-info)
- "If FILE is currently visited, resynch its buffer."
- (if (string= buffer-file-name file)
- (vc-resynch-window file keep noquery reset-vc-info)
- (if (file-directory-p file)
- (vc-resynch-buffers-in-directory file keep noquery reset-vc-info)
- (let ((buffer (get-file-buffer file)))
- (when buffer
- (with-current-buffer buffer
- (vc-resynch-window file keep noquery reset-vc-info))))))
- ;; Try to avoid unnecessary work, a *vc-dir* buffer is only present
- ;; if this is true.
- (when vc-dir-buffers
- (vc-dir-resynch-file file)))
-
-(defun vc-buffer-sync (&optional not-urgent)
- "Make sure the current buffer and its working file are in sync.
-NOT-URGENT means it is ok to continue if the user says not to save."
- (when (buffer-modified-p)
- (if (or vc-suppress-confirm
- (y-or-n-p (format "Buffer %s modified; save it? " (buffer-name))))
- (save-buffer)
- (unless not-urgent
- (error "Aborted")))))
-
-;; Command closures
-
-;; Set up key bindings for use while editing log messages
-
-(defun vc-log-edit (fileset mode)
- "Set up `log-edit' for use on FILE."
- (setq default-directory
- (with-current-buffer vc-parent-buffer default-directory))
- (log-edit 'vc-finish-logentry
- nil
- `((log-edit-listfun . (lambda ()
- ;; FIXME: Should expand the list
- ;; for directories.
- (mapcar 'file-relative-name
- ',fileset)))
- (log-edit-diff-function . (lambda () (vc-diff nil))))
- nil
- mode)
- (set (make-local-variable 'vc-log-fileset) fileset)
- (set-buffer-modified-p nil)
- (setq buffer-file-name nil))
-
-(defun vc-start-logentry (files comment initial-contents msg logbuf mode action &optional after-hook)
- "Accept a comment for an operation on FILES.
-If COMMENT is nil, pop up a LOGBUF buffer, emit MSG, and set the
-action on close to ACTION. If COMMENT is a string and
-INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial
-contents of the log entry buffer. If COMMENT is a string and
-INITIAL-CONTENTS is nil, do action immediately as if the user had
-entered COMMENT. If COMMENT is t, also do action immediately with an
-empty comment. Remember the file's buffer in `vc-parent-buffer'
-\(current one if no file). Puts the log-entry buffer in major-mode
-MODE, defaulting to `log-edit-mode' if MODE is nil.
-AFTER-HOOK specifies the local value for `vc-log-after-operation-hook'."
- (let ((parent
- (if (vc-dispatcher-browsing)
- ;; If we are called from a directory browser, the parent buffer is
- ;; the current buffer.
- (current-buffer)
- (if (and files (equal (length files) 1))
- (get-file-buffer (car files))
- (current-buffer)))))
- (if (and comment (not initial-contents))
- (set-buffer (get-buffer-create logbuf))
- (pop-to-buffer (get-buffer-create logbuf)))
- (set (make-local-variable 'vc-parent-buffer) parent)
- (set (make-local-variable 'vc-parent-buffer-name)
- (concat " from " (buffer-name vc-parent-buffer)))
- (vc-log-edit files mode)
- (make-local-variable 'vc-log-after-operation-hook)
- (when after-hook
- (setq vc-log-after-operation-hook after-hook))
- (setq vc-log-operation action)
- (when comment
- (erase-buffer)
- (when (stringp comment) (insert comment)))
- (if (or (not comment) initial-contents)
- (message "%s Type C-c C-c when done" msg)
- (vc-finish-logentry (eq comment t)))))
-
-(declare-function vc-dir-move-to-goal-column "vc-dir" ())
-;; vc-finish-logentry is typically called from a log-edit buffer (see
-;; vc-start-logentry).
-(defun vc-finish-logentry (&optional nocomment)
- "Complete the operation implied by the current log entry.
-Use the contents of the current buffer as a check-in or registration
-comment. If the optional arg NOCOMMENT is non-nil, then don't check
-the buffer contents as a comment."
- (interactive)
- ;; Check and record the comment, if any.
- (unless nocomment
- (run-hooks 'vc-logentry-check-hook))
- ;; Sync parent buffer in case the user modified it while editing the comment.
- ;; But not if it is a vc-dir buffer.
- (with-current-buffer vc-parent-buffer
- (or (vc-dispatcher-browsing) (vc-buffer-sync)))
- (unless vc-log-operation
- (error "No log operation is pending"))
-
- ;; save the parameters held in buffer-local variables
- (let ((logbuf (current-buffer))
- (log-operation vc-log-operation)
- ;; FIXME: When coming from VC-Dir, we should check that the
- ;; set of selected files is still equal to vc-log-fileset,
- ;; to avoid surprises.
- (log-fileset vc-log-fileset)
- (log-entry (buffer-string))
- (after-hook vc-log-after-operation-hook))
- (pop-to-buffer vc-parent-buffer)
- ;; OK, do it to it
- (save-excursion
- (funcall log-operation
- log-fileset
- log-entry))
- ;; Remove checkin window (after the checkin so that if that fails
- ;; we don't zap the log buffer and the typing therein).
- ;; -- IMO this should be replaced with quit-window
- (cond ((and logbuf vc-delete-logbuf-window)
- (delete-windows-on logbuf (selected-frame))
- ;; Kill buffer and delete any other dedicated windows/frames.
- (kill-buffer logbuf))
- (logbuf
- (with-selected-window (or (get-buffer-window logbuf 0)
- (selected-window))
- (with-current-buffer logbuf
- (bury-buffer)))))
- ;; Now make sure we see the expanded headers
- (when log-fileset
- (mapc
- (lambda (file) (vc-resynch-buffer file vc-keep-workfiles t))
- log-fileset))
- (when (vc-dispatcher-browsing)
- (vc-dir-move-to-goal-column))
- (run-hooks after-hook 'vc-finish-logentry-hook)))
-
-(defun vc-dispatcher-browsing ()
- "Are we in a directory browser buffer?"
- (derived-mode-p 'vc-dir-mode))
-
-;; These are unused.
-;; (defun vc-dispatcher-in-fileset-p (fileset)
-;; (let ((member nil))
-;; (while (and (not member) fileset)
-;; (let ((elem (pop fileset)))
-;; (if (if (file-directory-p elem)
-;; (eq t (compare-strings buffer-file-name nil (length elem)
-;; elem nil nil))
-;; (eq (current-buffer) (get-file-buffer elem)))
-;; (setq member t))))
-;; member))
-
-;; (defun vc-dispatcher-selection-set (&optional observer)
-;; "Deduce a set of files to which to apply an operation. Return a cons
-;; cell (SELECTION . FILESET), where SELECTION is what the user chose
-;; and FILES is the flist with any directories replaced by the listed files
-;; within them.
-
-;; If we're in a directory display, the fileset is the list of marked files (if
-;; there is one) else the file on the current line. If not in a directory
-;; display, but the current buffer visits a file, the fileset is a singleton
-;; containing that file. Otherwise, throw an error."
-;; (let ((selection
-;; (cond
-;; ;; Browsing with vc-dir
-;; ((vc-dispatcher-browsing)
-;; ;; If no files are marked, temporarily mark current file
-;; ;; and choose on that basis (so we get subordinate files)
-;; (if (not (vc-dir-marked-files))
-;; (prog2
-;; (vc-dir-mark-file)
-;; (cons (vc-dir-marked-files) (vc-dir-marked-only-files))
-;; (vc-dir-unmark-all-files t))
-;; (cons (vc-dir-marked-files) (vc-dir-marked-only-files))))
-;; ;; Visiting an eligible file
-;; ((buffer-file-name)
-;; (cons (list buffer-file-name) (list buffer-file-name)))
-;; ;; No eligible file -- if there's a parent buffer, deduce from there
-;; ((and vc-parent-buffer (or (buffer-file-name vc-parent-buffer)
-;; (with-current-buffer vc-parent-buffer
-;; (vc-dispatcher-browsing))))
-;; (with-current-buffer vc-parent-buffer
-;; (vc-dispatcher-selection-set)))
-;; ;; No good set here, throw error
-;; (t (error "No fileset is available here")))))
-;; ;; We assume, in order to avoid unpleasant surprises to the user,
-;; ;; that a fileset is not in good shape to be handed to the user if the
-;; ;; buffers visiting the fileset don't match the on-disk contents.
-;; (unless observer
-;; (save-some-buffers
-;; nil (lambda () (vc-dispatcher-in-fileset-p (cdr selection)))))
-;; selection))
-
-(provide 'vc-dispatcher)
-
-;; arch-tag: 7d08b17f-5470-4799-914b-bfb9fcf6a246
-;;; vc-dispatcher.el ends here
+++ /dev/null
-;;; vc-git.el --- VC backend for the git version control system
-
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Alexandre Julliard <julliard@winehq.org>
-;; Keywords: tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file contains a VC backend for the git version control
-;; system.
-;;
-
-;;; Installation:
-
-;; To install: put this file on the load-path and add Git to the list
-;; of supported backends in `vc-handled-backends'; the following line,
-;; placed in your ~/.emacs, will accomplish this:
-;;
-;; (add-to-list 'vc-handled-backends 'Git)
-
-;;; Todo:
-;; - check if more functions could use vc-git-command instead
-;; of start-process.
-;; - changelog generation
-
-;; Implement the rest of the vc interface. See the comment at the
-;; beginning of vc.el. The current status is:
-;; ("??" means: "figure out what to do about it")
-;;
-;; FUNCTION NAME STATUS
-;; BACKEND PROPERTIES
-;; * revision-granularity OK
-;; STATE-QUERYING FUNCTIONS
-;; * registered (file) OK
-;; * state (file) OK
-;; - state-heuristic (file) NOT NEEDED
-;; * working-revision (file) OK
-;; - latest-on-branch-p (file) NOT NEEDED
-;; * checkout-model (files) OK
-;; - workfile-unchanged-p (file) OK
-;; - mode-line-string (file) OK
-;; STATE-CHANGING FUNCTIONS
-;; * create-repo () OK
-;; * register (files &optional rev comment) OK
-;; - init-revision (file) NOT NEEDED
-;; - responsible-p (file) OK
-;; - could-register (file) NOT NEEDED, DEFAULT IS GOOD
-;; - receive-file (file rev) NOT NEEDED
-;; - unregister (file) OK
-;; * checkin (files rev comment) OK
-;; * find-revision (file rev buffer) OK
-;; * checkout (file &optional editable rev) OK
-;; * revert (file &optional contents-done) OK
-;; - rollback (files) COULD BE SUPPORTED
-;; - merge (file rev1 rev2) It would be possible to merge
-;; changes into a single file, but
-;; when committing they wouldn't
-;; be identified as a merge
-;; by git, so it's probably
-;; not a good idea.
-;; - merge-news (file) see `merge'
-;; - steal-lock (file &optional revision) NOT NEEDED
-;; HISTORY FUNCTIONS
-;; * print-log (files buffer &optional shortlog start-revision limit) OK
-;; - log-view-mode () OK
-;; - show-log-entry (revision) OK
-;; - comment-history (file) ??
-;; - update-changelog (files) COULD BE SUPPORTED
-;; * diff (file &optional rev1 rev2 buffer) OK
-;; - revision-completion-table (files) OK
-;; - annotate-command (file buf &optional rev) OK
-;; - annotate-time () OK
-;; - annotate-current-time () NOT NEEDED
-;; - annotate-extract-revision-at-line () OK
-;; TAG SYSTEM
-;; - create-tag (dir name branchp) OK
-;; - retrieve-tag (dir name update) OK
-;; MISCELLANEOUS
-;; - make-version-backups-p (file) NOT NEEDED
-;; - repository-hostname (dirname) NOT NEEDED
-;; - previous-revision (file rev) OK
-;; - next-revision (file rev) OK
-;; - check-headers () COULD BE SUPPORTED
-;; - clear-headers () NOT NEEDED
-;; - delete-file (file) OK
-;; - rename-file (old new) OK
-;; - find-file-hook () NOT NEEDED
-
-(eval-when-compile
- (require 'cl)
- (require 'vc)
- (require 'vc-dir)
- (require 'grep))
-
-(defcustom vc-git-diff-switches t
- "String or list of strings specifying switches for Git diff under VC.
-If nil, use the value of `vc-diff-switches'. If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "23.1"
- :group 'vc)
-
-(defvar vc-git-commits-coding-system 'utf-8
- "Default coding system for git commits.")
-
-;;; BACKEND PROPERTIES
-
-(defun vc-git-revision-granularity () 'repository)
-(defun vc-git-checkout-model (files) 'implicit)
-
-;;; STATE-QUERYING FUNCTIONS
-
-;;;###autoload (defun vc-git-registered (file)
-;;;###autoload "Return non-nil if FILE is registered with git."
-;;;###autoload (if (vc-find-root file ".git") ; Short cut.
-;;;###autoload (progn
-;;;###autoload (load "vc-git")
-;;;###autoload (vc-git-registered file))))
-
-(defun vc-git-registered (file)
- "Check whether FILE is registered with git."
- (let ((dir (vc-git-root file)))
- (when dir
- (with-temp-buffer
- (let* (process-file-side-effects
- ;; Do not use the `file-name-directory' here: git-ls-files
- ;; sometimes fails to return the correct status for relative
- ;; path specs.
- ;; See also: http://marc.info/?l=git&m=125787684318129&w=2
- (name (file-relative-name file dir))
- (str (ignore-errors
- (cd dir)
- (vc-git--out-ok "ls-files" "-c" "-z" "--" name)
- ;; If result is empty, use ls-tree to check for deleted
- ;; file.
- (when (eq (point-min) (point-max))
- (vc-git--out-ok "ls-tree" "--name-only" "-z" "HEAD"
- "--" name))
- (buffer-string))))
- (and str
- (> (length str) (length name))
- (string= (substring str 0 (1+ (length name)))
- (concat name "\0"))))))))
-
-(defun vc-git--state-code (code)
- "Convert from a string to a added/deleted/modified state."
- (case (string-to-char code)
- (?M 'edited)
- (?A 'added)
- (?D 'removed)
- (?U 'edited) ;; FIXME
- (?T 'edited))) ;; FIXME
-
-(defun vc-git-state (file)
- "Git-specific version of `vc-state'."
- ;; FIXME: This can't set 'ignored or 'conflict yet
- ;; The 'ignored state could be detected with `git ls-files -i -o
- ;; --exclude-standard` It also can't set 'needs-update or
- ;; 'needs-merge. The rough equivalent would be that upstream branch
- ;; for current branch is in fast-forward state i.e. current branch
- ;; is direct ancestor of corresponding upstream branch, and the file
- ;; was modified upstream. But we can't check that without a network
- ;; operation.
- (if (not (vc-git-registered file))
- 'unregistered
- (vc-git--call nil "add" "--refresh" "--" (file-relative-name file))
- (let ((diff (vc-git--run-command-string
- file "diff-index" "-z" "HEAD" "--")))
- (if (and diff (string-match ":[0-7]\\{6\\} [0-7]\\{6\\} [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\([ADMUT]\\)\0[^\0]+\0"
- diff))
- (vc-git--state-code (match-string 1 diff))
- (if (vc-git--empty-db-p) 'added 'up-to-date)))))
-
-(defun vc-git-working-revision (file)
- "Git-specific version of `vc-working-revision'."
- (let* (process-file-side-effects
- (str (with-output-to-string
- (with-current-buffer standard-output
- (vc-git--out-ok "symbolic-ref" "HEAD")))))
- (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
- (match-string 2 str)
- str)))
-
-(defun vc-git-workfile-unchanged-p (file)
- (eq 'up-to-date (vc-git-state file)))
-
-(defun vc-git-mode-line-string (file)
- "Return string for placement into the modeline for FILE."
- (let* ((branch (vc-git-working-revision file))
- (def-ml (vc-default-mode-line-string 'Git file))
- (help-echo (get-text-property 0 'help-echo def-ml)))
- (if (zerop (length branch))
- (propertize
- (concat def-ml "!")
- 'help-echo (concat help-echo "\nNo current branch (detached HEAD)"))
- (propertize def-ml
- 'help-echo (concat help-echo "\nCurrent branch: " branch)))))
-
-(defstruct (vc-git-extra-fileinfo
- (:copier nil)
- (:constructor vc-git-create-extra-fileinfo
- (old-perm new-perm &optional rename-state orig-name))
- (:conc-name vc-git-extra-fileinfo->))
- old-perm new-perm ;; Permission flags.
- rename-state ;; Rename or copy state.
- orig-name) ;; Original name for renames or copies.
-
-(defun vc-git-escape-file-name (name)
- "Escape a file name if necessary."
- (if (string-match "[\n\t\"\\]" name)
- (concat "\""
- (mapconcat (lambda (c)
- (case c
- (?\n "\\n")
- (?\t "\\t")
- (?\\ "\\\\")
- (?\" "\\\"")
- (t (char-to-string c))))
- name "")
- "\"")
- name))
-
-(defun vc-git-file-type-as-string (old-perm new-perm)
- "Return a string describing the file type based on its permissions."
- (let* ((old-type (lsh (or old-perm 0) -9))
- (new-type (lsh (or new-perm 0) -9))
- (str (case new-type
- (?\100 ;; File.
- (case old-type
- (?\100 nil)
- (?\120 " (type change symlink -> file)")
- (?\160 " (type change subproject -> file)")))
- (?\120 ;; Symlink.
- (case old-type
- (?\100 " (type change file -> symlink)")
- (?\160 " (type change subproject -> symlink)")
- (t " (symlink)")))
- (?\160 ;; Subproject.
- (case old-type
- (?\100 " (type change file -> subproject)")
- (?\120 " (type change symlink -> subproject)")
- (t " (subproject)")))
- (?\110 nil) ;; Directory (internal, not a real git state).
- (?\000 ;; Deleted or unknown.
- (case old-type
- (?\120 " (symlink)")
- (?\160 " (subproject)")))
- (t (format " (unknown type %o)" new-type)))))
- (cond (str (propertize str 'face 'font-lock-comment-face))
- ((eq new-type ?\110) "/")
- (t ""))))
-
-(defun vc-git-rename-as-string (state extra)
- "Return a string describing the copy or rename associated with INFO,
-or an empty string if none."
- (let ((rename-state (when extra
- (vc-git-extra-fileinfo->rename-state extra))))
- (if rename-state
- (propertize
- (concat " ("
- (if (eq rename-state 'copy) "copied from "
- (if (eq state 'added) "renamed from "
- "renamed to "))
- (vc-git-escape-file-name
- (vc-git-extra-fileinfo->orig-name extra))
- ")")
- 'face 'font-lock-comment-face)
- "")))
-
-(defun vc-git-permissions-as-string (old-perm new-perm)
- "Format a permission change as string."
- (propertize
- (if (or (not old-perm)
- (not new-perm)
- (eq 0 (logand ?\111 (logxor old-perm new-perm))))
- " "
- (if (eq 0 (logand ?\111 old-perm)) "+x" "-x"))
- 'face 'font-lock-type-face))
-
-(defun vc-git-dir-printer (info)
- "Pretty-printer for the vc-dir-fileinfo structure."
- (let* ((isdir (vc-dir-fileinfo->directory info))
- (state (if isdir "" (vc-dir-fileinfo->state info)))
- (extra (vc-dir-fileinfo->extra info))
- (old-perm (when extra (vc-git-extra-fileinfo->old-perm extra)))
- (new-perm (when extra (vc-git-extra-fileinfo->new-perm extra))))
- (insert
- " "
- (propertize (format "%c" (if (vc-dir-fileinfo->marked info) ?* ? ))
- 'face 'font-lock-type-face)
- " "
- (propertize
- (format "%-12s" state)
- 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
- ((eq state 'missing) 'font-lock-warning-face)
- (t 'font-lock-variable-name-face))
- 'mouse-face 'highlight)
- " " (vc-git-permissions-as-string old-perm new-perm)
- " "
- (propertize (vc-git-escape-file-name (vc-dir-fileinfo->name info))
- 'face (if isdir 'font-lock-comment-delimiter-face
- 'font-lock-function-name-face)
- 'help-echo
- (if isdir
- "Directory\nVC operations can be applied to it\nmouse-3: Pop-up menu"
- "File\nmouse-3: Pop-up menu")
- 'keymap vc-dir-filename-mouse-map
- 'mouse-face 'highlight)
- (vc-git-file-type-as-string old-perm new-perm)
- (vc-git-rename-as-string state extra))))
-
-(defun vc-git-after-dir-status-stage (stage files update-function)
- "Process sentinel for the various dir-status stages."
- (let (next-stage result)
- (goto-char (point-min))
- (case stage
- (update-index
- (setq next-stage (if (vc-git--empty-db-p) 'ls-files-added
- (if files 'ls-files-up-to-date 'diff-index))))
- (ls-files-added
- (setq next-stage 'ls-files-unknown)
- (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t)
- (let ((new-perm (string-to-number (match-string 1) 8))
- (name (match-string 2)))
- (push (list name 'added (vc-git-create-extra-fileinfo 0 new-perm))
- result))))
- (ls-files-up-to-date
- (setq next-stage 'diff-index)
- (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t)
- (let ((perm (string-to-number (match-string 1) 8))
- (name (match-string 2)))
- (push (list name 'up-to-date
- (vc-git-create-extra-fileinfo perm perm))
- result))))
- (ls-files-unknown
- (when files (setq next-stage 'ls-files-ignored))
- (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
- (push (list (match-string 1) 'unregistered
- (vc-git-create-extra-fileinfo 0 0))
- result)))
- (ls-files-ignored
- (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
- (push (list (match-string 1) 'ignored
- (vc-git-create-extra-fileinfo 0 0))
- result)))
- (diff-index
- (setq next-stage 'ls-files-unknown)
- (while (re-search-forward
- ":\\([0-7]\\{6\\}\\) \\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\(\\([ADMUT]\\)\0\\([^\0]+\\)\\|\\([CR]\\)[0-9]*\0\\([^\0]+\\)\0\\([^\0]+\\)\\)\0"
- nil t 1)
- (let ((old-perm (string-to-number (match-string 1) 8))
- (new-perm (string-to-number (match-string 2) 8))
- (state (or (match-string 4) (match-string 6)))
- (name (or (match-string 5) (match-string 7)))
- (new-name (match-string 8)))
- (if new-name ; Copy or rename.
- (if (eq ?C (string-to-char state))
- (push (list new-name 'added
- (vc-git-create-extra-fileinfo old-perm new-perm
- 'copy name))
- result)
- (push (list name 'removed
- (vc-git-create-extra-fileinfo 0 0
- 'rename new-name))
- result)
- (push (list new-name 'added
- (vc-git-create-extra-fileinfo old-perm new-perm
- 'rename name))
- result))
- (push (list name (vc-git--state-code state)
- (vc-git-create-extra-fileinfo old-perm new-perm))
- result))))))
- (when result
- (setq result (nreverse result))
- (when files
- (dolist (entry result) (setq files (delete (car entry) files)))
- (unless files (setq next-stage nil))))
- (when (or result (not next-stage))
- (funcall update-function result next-stage))
- (when next-stage
- (vc-git-dir-status-goto-stage next-stage files update-function))))
-
-(defun vc-git-dir-status-goto-stage (stage files update-function)
- (erase-buffer)
- (case stage
- (update-index
- (if files
- (vc-git-command (current-buffer) 'async files "add" "--refresh" "--")
- (vc-git-command (current-buffer) 'async nil
- "update-index" "--refresh")))
- (ls-files-added
- (vc-git-command (current-buffer) 'async files
- "ls-files" "-z" "-c" "-s" "--"))
- (ls-files-up-to-date
- (vc-git-command (current-buffer) 'async files
- "ls-files" "-z" "-c" "-s" "--"))
- (ls-files-unknown
- (vc-git-command (current-buffer) 'async files
- "ls-files" "-z" "-o" "--directory"
- "--no-empty-directory" "--exclude-standard" "--"))
- (ls-files-ignored
- (vc-git-command (current-buffer) 'async files
- "ls-files" "-z" "-o" "-i" "--directory"
- "--no-empty-directory" "--exclude-standard" "--"))
- ;; --relative added in Git 1.5.5.
- (diff-index
- (vc-git-command (current-buffer) 'async files
- "diff-index" "--relative" "-z" "-M" "HEAD" "--")))
- (vc-exec-after
- `(vc-git-after-dir-status-stage ',stage ',files ',update-function)))
-
-(defun vc-git-dir-status (dir update-function)
- "Return a list of (FILE STATE EXTRA) entries for DIR."
- ;; Further things that would have to be fixed later:
- ;; - how to handle unregistered directories
- ;; - how to support vc-dir on a subdir of the project tree
- (vc-git-dir-status-goto-stage 'update-index nil update-function))
-
-(defun vc-git-dir-status-files (dir files default-state update-function)
- "Return a list of (FILE STATE EXTRA) entries for FILES in DIR."
- (vc-git-dir-status-goto-stage 'update-index files update-function))
-
-(defvar vc-git-stash-map
- (let ((map (make-sparse-keymap)))
- ;; Turn off vc-dir marking
- (define-key map [mouse-2] 'ignore)
-
- (define-key map [down-mouse-3] 'vc-git-stash-menu)
- (define-key map "\C-k" 'vc-git-stash-delete-at-point)
- (define-key map "=" 'vc-git-stash-show-at-point)
- (define-key map "\C-m" 'vc-git-stash-show-at-point)
- (define-key map "A" 'vc-git-stash-apply-at-point)
- (define-key map "P" 'vc-git-stash-pop-at-point)
- (define-key map "S" 'vc-git-stash-snapshot)
- map))
-
-(defvar vc-git-stash-menu-map
- (let ((map (make-sparse-keymap "Git Stash")))
- (define-key map [de]
- '(menu-item "Delete stash" vc-git-stash-delete-at-point
- :help "Delete the current stash"))
- (define-key map [ap]
- '(menu-item "Apply stash" vc-git-stash-apply-at-point
- :help "Apply the current stash and keep it in the stash list"))
- (define-key map [po]
- '(menu-item "Apply and remove stash (pop)" vc-git-stash-pop-at-point
- :help "Apply the current stash and remove it"))
- (define-key map [sh]
- '(menu-item "Show stash" vc-git-stash-show-at-point
- :help "Show the contents of the current stash"))
- map))
-
-(defun vc-git-dir-extra-headers (dir)
- (let ((str (with-output-to-string
- (with-current-buffer standard-output
- (vc-git--out-ok "symbolic-ref" "HEAD"))))
- (stash (vc-git-stash-list))
- (stash-help-echo "Use M-x vc-git-stash to create stashes.")
- branch remote remote-url)
- (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
- (progn
- (setq branch (match-string 2 str))
- (setq remote
- (with-output-to-string
- (with-current-buffer standard-output
- (vc-git--out-ok "config"
- (concat "branch." branch ".remote")))))
- (when (string-match "\\([^\n]+\\)" remote)
- (setq remote (match-string 1 remote)))
- (when remote
- (setq remote-url
- (with-output-to-string
- (with-current-buffer standard-output
- (vc-git--out-ok "config"
- (concat "remote." remote ".url"))))))
- (when (string-match "\\([^\n]+\\)" remote-url)
- (setq remote-url (match-string 1 remote-url))))
- (setq branch "not (detached HEAD)"))
- ;; FIXME: maybe use a different face when nothing is stashed.
- (concat
- (propertize "Branch : " 'face 'font-lock-type-face)
- (propertize branch
- 'face 'font-lock-variable-name-face)
- (when remote
- (concat
- "\n"
- (propertize "Remote : " 'face 'font-lock-type-face)
- (propertize remote-url
- 'face 'font-lock-variable-name-face)))
- "\n"
- (if stash
- (concat
- (propertize "Stash :\n" 'face 'font-lock-type-face
- 'help-echo stash-help-echo)
- (mapconcat
- (lambda (x)
- (propertize x
- 'face 'font-lock-variable-name-face
- 'mouse-face 'highlight
- 'help-echo "mouse-3: Show stash menu\nRET: Show stash\nA: Apply stash\nP: Apply and remove stash (pop)\nC-k: Delete stash"
- 'keymap vc-git-stash-map))
- stash "\n"))
- (concat
- (propertize "Stash : " 'face 'font-lock-type-face
- 'help-echo stash-help-echo)
- (propertize "Nothing stashed"
- 'help-echo stash-help-echo
- 'face 'font-lock-variable-name-face))))))
-
-;;; STATE-CHANGING FUNCTIONS
-
-(defun vc-git-create-repo ()
- "Create a new Git repository."
- (vc-git-command nil 0 nil "init"))
-
-(defun vc-git-register (files &optional rev comment)
- "Register FILES into the git version-control system."
- (let (flist dlist)
- (dolist (crt files)
- (if (file-directory-p crt)
- (push crt dlist)
- (push crt flist)))
- (when flist
- (vc-git-command nil 0 flist "update-index" "--add" "--"))
- (when dlist
- (vc-git-command nil 0 dlist "add"))))
-
-(defalias 'vc-git-responsible-p 'vc-git-root)
-
-(defun vc-git-unregister (file)
- (vc-git-command nil 0 file "rm" "-f" "--cached" "--"))
-
-(declare-function log-edit-extract-headers "log-edit" (headers string))
-
-(defun vc-git-checkin (files rev comment)
- (let ((coding-system-for-write vc-git-commits-coding-system))
- (apply 'vc-git-command nil 0 files
- (nconc (list "commit" "-m")
- (log-edit-extract-headers '(("Author" . "--author")
- ("Date" . "--date"))
- comment)
- (list "--only" "--")))))
-
-(defun vc-git-find-revision (file rev buffer)
- (let* (process-file-side-effects
- (coding-system-for-read 'binary)
- (coding-system-for-write 'binary)
- (fullname (substring
- (vc-git--run-command-string
- file "ls-files" "-z" "--full-name" "--")
- 0 -1)))
- (vc-git-command
- buffer 0
- (concat (if rev rev "HEAD") ":" fullname) "cat-file" "blob")))
-
-(defun vc-git-checkout (file &optional editable rev)
- (vc-git-command nil 0 file "checkout" (or rev "HEAD")))
-
-(defun vc-git-revert (file &optional contents-done)
- "Revert FILE to the version stored in the git repository."
- (if contents-done
- (vc-git-command nil 0 file "update-index" "--")
- (vc-git-command nil 0 file "reset" "-q" "--")
- (vc-git-command nil nil file "checkout" "-q" "--")))
-
-;;; HISTORY FUNCTIONS
-
-(defun vc-git-print-log (files buffer &optional shortlog start-revision limit)
- "Get change log associated with FILES.
-Note that using SHORTLOG requires at least Git version 1.5.6,
-for the --graph option."
- (let ((coding-system-for-read vc-git-commits-coding-system))
- ;; `vc-do-command' creates the buffer, but we need it before running
- ;; the command.
- (vc-setup-buffer buffer)
- ;; If the buffer exists from a previous invocation it might be
- ;; read-only.
- (let ((inhibit-read-only t))
- (with-current-buffer
- buffer
- (apply 'vc-git-command buffer
- 'async files
- (append
- '("log" "--no-color")
- (when shortlog
- '("--graph" "--decorate" "--date=short"
- "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"))
- (when limit (list "-n" (format "%s" limit)))
- (when start-revision (list start-revision))
- '("--")))))))
-
-(defun vc-git-log-outgoing (buffer remote-location)
- (interactive)
- (vc-git-command
- buffer 0 nil
- "log"
- "--no-color" "--graph" "--decorate" "--date=short"
- "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"
- (concat (if (string= remote-location "")
- "@{upstream}"
- remote-location)
- "..HEAD")))
-
-(defun vc-git-log-incoming (buffer remote-location)
- (interactive)
- (vc-git-command nil 0 nil "fetch")
- (vc-git-command
- buffer 0 nil
- "log"
- "--no-color" "--graph" "--decorate" "--date=short"
- "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"
- (concat "HEAD.." (if (string= remote-location "")
- "@{upstream}"
- remote-location))))
-
-(defvar log-view-message-re)
-(defvar log-view-file-re)
-(defvar log-view-font-lock-keywords)
-(defvar log-view-per-file-logs)
-
-(define-derived-mode vc-git-log-view-mode log-view-mode "Git-Log-View"
- (require 'add-log) ;; We need the faces add-log.
- ;; Don't have file markers, so use impossible regexp.
- (set (make-local-variable 'log-view-file-re) "\\`a\\`")
- (set (make-local-variable 'log-view-per-file-logs) nil)
- (set (make-local-variable 'log-view-message-re)
- (if (not (eq vc-log-view-type 'long))
- "^\\(?:[*/\\| ]+ \\)?\\(?: ([^)]+)\\)?\\([0-9a-z]+\\) \\([-a-z0-9]+\\) \\(.*\\)"
- "^commit *\\([0-9a-z]+\\)"))
- (set (make-local-variable 'log-view-font-lock-keywords)
- (if (not (eq vc-log-view-type 'long))
- '(
- ;; Same as log-view-message-re, except that we don't
- ;; want the shy group for the tag name.
- ("^\\(?:[*/\\| ]+ \\)?\\( ([^)]+)\\)?\\([0-9a-z]+\\) \\([-a-z0-9]+\\) \\(.*\\)"
- (1 'highlight nil lax)
- (2 'change-log-acknowledgement)
- (3 'change-log-date)))
- (append
- `((,log-view-message-re (1 'change-log-acknowledgement)))
- ;; Handle the case:
- ;; user: foo@bar
- '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
- (1 'change-log-email))
- ;; Handle the case:
- ;; user: FirstName LastName <foo@bar>
- ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
- (1 'change-log-name)
- (2 'change-log-email))
- ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
- (1 'change-log-name))
- ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
- (1 'change-log-name)
- (2 'change-log-email))
- ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)"
- (1 'change-log-acknowledgement)
- (2 'change-log-acknowledgement))
- ("^Date: \\(.+\\)" (1 'change-log-date))
- ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
-
-
-(defun vc-git-show-log-entry (revision)
- "Move to the log entry for REVISION.
-REVISION may have the form BRANCH, BRANCH~N,
-or BRANCH^ (where \"^\" can be repeated)."
- (goto-char (point-min))
- (prog1
- (when revision
- (search-forward
- (format "\ncommit %s" revision) nil t
- (cond ((string-match "~\\([0-9]\\)\\'" revision)
- (1+ (string-to-number (match-string 1 revision))))
- ((string-match "\\^+\\'" revision)
- (1+ (length (match-string 0 revision))))
- (t nil))))
- (beginning-of-line)))
-
-(defun vc-git-diff (files &optional rev1 rev2 buffer)
- "Get a difference report using Git between two revisions of FILES."
- (let (process-file-side-effects)
- (apply #'vc-git-command (or buffer "*vc-diff*") 1 files
- (if (and rev1 rev2) "diff-tree" "diff-index")
- "--exit-code"
- (append (vc-switches 'git 'diff)
- (list "-p" (or rev1 "HEAD") rev2 "--")))))
-
-(defun vc-git-revision-table (files)
- ;; What about `files'?!? --Stef
- (let (process-file-side-effects
- (table (list "HEAD")))
- (with-temp-buffer
- (vc-git-command t nil nil "for-each-ref" "--format=%(refname)")
- (goto-char (point-min))
- (while (re-search-forward "^refs/\\(heads\\|tags\\|remotes\\)/\\(.*\\)$"
- nil t)
- (push (match-string 2) table)))
- table))
-
-(defun vc-git-revision-completion-table (files)
- (lexical-let ((files files)
- table)
- (setq table (lazy-completion-table
- table (lambda () (vc-git-revision-table files))))
- table))
-
-(defun vc-git-annotate-command (file buf &optional rev)
- (let ((name (file-relative-name file)))
- (vc-git-command buf 'async name "blame" "--date=iso" "-C" "-C" rev)))
-
-(declare-function vc-annotate-convert-time "vc-annotate" (time))
-
-(defun vc-git-annotate-time ()
- (and (re-search-forward "[0-9a-f]+[^()]+(.* \\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) \\([-+0-9]+\\) +[0-9]+) " nil t)
- (vc-annotate-convert-time
- (apply #'encode-time (mapcar (lambda (match)
- (string-to-number (match-string match)))
- '(6 5 4 3 2 1 7))))))
-
-(defun vc-git-annotate-extract-revision-at-line ()
- (save-excursion
- (move-beginning-of-line 1)
- (when (looking-at "\\([0-9a-f^][0-9a-f]+\\) \\(\\([^(]+\\) \\)?")
- (let ((revision (match-string-no-properties 1)))
- (if (match-beginning 2)
- (cons revision (expand-file-name (match-string-no-properties 3)
- (vc-git-root default-directory)))
- revision)))))
-
-;;; TAG SYSTEM
-
-(defun vc-git-create-tag (dir name branchp)
- (let ((default-directory dir))
- (and (vc-git-command nil 0 nil "update-index" "--refresh")
- (if branchp
- (vc-git-command nil 0 nil "checkout" "-b" name)
- (vc-git-command nil 0 nil "tag" name)))))
-
-(defun vc-git-retrieve-tag (dir name update)
- (let ((default-directory dir))
- (vc-git-command nil 0 nil "checkout" name)
- ;; FIXME: update buffers if `update' is true
- ))
-
-
-;;; MISCELLANEOUS
-
-(defun vc-git-previous-revision (file rev)
- "Git-specific version of `vc-previous-revision'."
- (if file
- (let* ((default-directory (file-name-directory (expand-file-name file)))
- (file (file-name-nondirectory file))
- (prev-rev (with-temp-buffer
- (and
- (vc-git--out-ok "rev-list" "-2" rev "--" file)
- (goto-char (point-max))
- (bolp)
- (zerop (forward-line -1))
- (not (bobp))
- (buffer-substring-no-properties
- (point)
- (1- (point-max)))))))
- (or (vc-git-symbolic-commit prev-rev) prev-rev))
- (with-temp-buffer
- (and
- (vc-git--out-ok "rev-parse" (concat rev "^"))
- (buffer-substring-no-properties (point-min) (+ (point-min) 40))))))
-
-(defun vc-git-next-revision (file rev)
- "Git-specific version of `vc-next-revision'."
- (let* ((default-directory (file-name-directory
- (expand-file-name file)))
- (file (file-name-nondirectory file))
- (current-rev
- (with-temp-buffer
- (and
- (vc-git--out-ok "rev-list" "-1" rev "--" file)
- (goto-char (point-max))
- (bolp)
- (zerop (forward-line -1))
- (bobp)
- (buffer-substring-no-properties
- (point)
- (1- (point-max))))))
- (next-rev
- (and current-rev
- (with-temp-buffer
- (and
- (vc-git--out-ok "rev-list" "HEAD" "--" file)
- (goto-char (point-min))
- (search-forward current-rev nil t)
- (zerop (forward-line -1))
- (buffer-substring-no-properties
- (point)
- (progn (forward-line 1) (1- (point)))))))))
- (or (vc-git-symbolic-commit next-rev) next-rev)))
-
-(defun vc-git-delete-file (file)
- (vc-git-command nil 0 file "rm" "-f" "--"))
-
-(defun vc-git-rename-file (old new)
- (vc-git-command nil 0 (list old new) "mv" "-f" "--"))
-
-(defvar vc-git-extra-menu-map
- (let ((map (make-sparse-keymap)))
- (define-key map [git-grep]
- '(menu-item "Git grep..." vc-git-grep
- :help "Run the `git grep' command"))
- (define-key map [git-sn]
- '(menu-item "Stash a snapshot" vc-git-stash-snapshot
- :help "Stash the current state of the tree and keep the current state"))
- (define-key map [git-st]
- '(menu-item "Create Stash..." vc-git-stash
- :help "Stash away changes"))
- (define-key map [git-ss]
- '(menu-item "Show Stash..." vc-git-stash-show
- :help "Show stash contents"))
- map))
-
-(defun vc-git-extra-menu () vc-git-extra-menu-map)
-
-(defun vc-git-extra-status-menu () vc-git-extra-menu-map)
-
-(defun vc-git-root (file)
- (vc-find-root file ".git"))
-
-;; Derived from `lgrep'.
-(defun vc-git-grep (regexp &optional files dir)
- "Run git grep, searching for REGEXP in FILES in directory DIR.
-The search is limited to file names matching shell pattern FILES.
-FILES may use abbreviations defined in `grep-files-aliases', e.g.
-entering `ch' is equivalent to `*.[ch]'.
-
-With \\[universal-argument] prefix, you can edit the constructed shell command line
-before it is executed.
-With two \\[universal-argument] prefixes, directly edit and run `grep-command'.
-
-Collect output in a buffer. While git grep runs asynchronously, you
-can use \\[next-error] (M-x next-error), or \\<grep-mode-map>\\[compile-goto-error] \
-in the grep output buffer,
-to go to the lines where grep found matches.
-
-This command shares argument histories with \\[rgrep] and \\[grep]."
- (interactive
- (progn
- (grep-compute-defaults)
- (cond
- ((equal current-prefix-arg '(16))
- (list (read-from-minibuffer "Run: " "git grep"
- nil nil 'grep-history)
- nil))
- (t (let* ((regexp (grep-read-regexp))
- (files (grep-read-files regexp))
- (dir (read-directory-name "In directory: "
- nil default-directory t)))
- (list regexp files dir))))))
- (require 'grep)
- (when (and (stringp regexp) (> (length regexp) 0))
- (let ((command regexp))
- (if (null files)
- (if (string= command "git grep")
- (setq command nil))
- (setq dir (file-name-as-directory (expand-file-name dir)))
- (setq command
- (grep-expand-template "git grep -n -e <R> -- <F>" regexp files))
- (when command
- (if (equal current-prefix-arg '(4))
- (setq command
- (read-from-minibuffer "Confirm: "
- command nil nil 'grep-history))
- (add-to-history 'grep-history command))))
- (when command
- (let ((default-directory dir)
- (compilation-environment '("PAGER=")))
- ;; Setting process-setup-function makes exit-message-function work
- ;; even when async processes aren't supported.
- (compilation-start command 'grep-mode))
- (if (eq next-error-last-buffer (current-buffer))
- (setq default-directory dir))))))
-
-(defun vc-git-stash (name)
- "Create a stash."
- (interactive "sStash name: ")
- (let ((root (vc-git-root default-directory)))
- (when root
- (vc-git--call nil "stash" "save" name)
- (vc-resynch-buffer root t t))))
-
-(defun vc-git-stash-show (name)
- "Show the contents of stash NAME."
- (interactive "sStash name: ")
- (vc-setup-buffer "*vc-git-stash*")
- (vc-git-command "*vc-git-stash*" 'async nil "stash" "show" "-p" name)
- (set-buffer "*vc-git-stash*")
- (diff-mode)
- (setq buffer-read-only t)
- (pop-to-buffer (current-buffer)))
-
-(defun vc-git-stash-apply (name)
- "Apply stash NAME."
- (interactive "sApply stash: ")
- (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" name)
- (vc-resynch-buffer (vc-git-root default-directory) t t))
-
-(defun vc-git-stash-pop (name)
- "Pop stash NAME."
- (interactive "sPop stash: ")
- (vc-git-command "*vc-git-stash*" 0 nil "stash" "pop" "-q" name)
- (vc-resynch-buffer (vc-git-root default-directory) t t))
-
-(defun vc-git-stash-snapshot ()
- "Create a stash with the current tree state."
- (interactive)
- (vc-git--call nil "stash" "save"
- (let ((ct (current-time)))
- (concat
- (format-time-string "Snapshot on %Y-%m-%d" ct)
- (format-time-string " at %H:%M" ct))))
- (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" "stash@{0}")
- (vc-resynch-buffer (vc-git-root default-directory) t t))
-
-(defun vc-git-stash-list ()
- (delete
- ""
- (split-string
- (replace-regexp-in-string
- "^stash@" " " (vc-git--run-command-string nil "stash" "list"))
- "\n")))
-
-(defun vc-git-stash-get-at-point (point)
- (save-excursion
- (goto-char point)
- (beginning-of-line)
- (if (looking-at "^ +\\({[0-9]+}\\):")
- (match-string 1)
- (error "Cannot find stash at point"))))
-
-(defun vc-git-stash-delete-at-point ()
- (interactive)
- (let ((stash (vc-git-stash-get-at-point (point))))
- (when (y-or-n-p (format "Remove stash %s ? " stash))
- (vc-git--run-command-string nil "stash" "drop" (format "stash@%s" stash))
- (vc-dir-refresh))))
-
-(defun vc-git-stash-show-at-point ()
- (interactive)
- (vc-git-stash-show (format "stash@%s" (vc-git-stash-get-at-point (point)))))
-
-(defun vc-git-stash-apply-at-point ()
- (interactive)
- (vc-git-stash-apply (format "stash@%s" (vc-git-stash-get-at-point (point)))))
-
-(defun vc-git-stash-pop-at-point ()
- (interactive)
- (vc-git-stash-pop (format "stash@%s" (vc-git-stash-get-at-point (point)))))
-
-(defun vc-git-stash-menu (e)
- (interactive "e")
- (vc-dir-at-event e (popup-menu vc-git-stash-menu-map e)))
-
-\f
-;;; Internal commands
-
-(defun vc-git-command (buffer okstatus file-or-list &rest flags)
- "A wrapper around `vc-do-command' for use in vc-git.el.
-The difference to vc-do-command is that this function always invokes `git'."
- (apply 'vc-do-command (or buffer "*vc*") okstatus "git" file-or-list flags))
-
-(defun vc-git--empty-db-p ()
- "Check if the git db is empty (no commit done yet)."
- (let (process-file-side-effects)
- (not (eq 0 (vc-git--call nil "rev-parse" "--verify" "HEAD")))))
-
-(defun vc-git--call (buffer command &rest args)
- ;; We don't need to care the arguments. If there is a file name, it
- ;; is always a relative one. This works also for remote
- ;; directories.
- (apply 'process-file "git" nil buffer nil command args))
-
-(defun vc-git--out-ok (command &rest args)
- (zerop (apply 'vc-git--call '(t nil) command args)))
-
-(defun vc-git--run-command-string (file &rest args)
- "Run a git command on FILE and return its output as string.
-FILE can be nil."
- (let* ((ok t)
- (str (with-output-to-string
- (with-current-buffer standard-output
- (unless (apply 'vc-git--out-ok
- (if file
- (append args (list (file-relative-name
- file)))
- args))
- (setq ok nil))))))
- (and ok str)))
-
-(defun vc-git-symbolic-commit (commit)
- "Translate COMMIT string into symbolic form.
-Returns nil if not possible."
- (and commit
- (let ((name (with-temp-buffer
- (and
- (vc-git--out-ok "name-rev" "--name-only" commit)
- (goto-char (point-min))
- (= (forward-line 2) 1)
- (bolp)
- (buffer-substring-no-properties (point-min)
- (1- (point-max)))))))
- (and name (not (string= name "undefined")) name))))
-
-(provide 'vc-git)
-
-;; arch-tag: bd10664a-0e5b-48f5-a877-6c17b135be12
-;;; vc-git.el ends here
+++ /dev/null
-;;; vc-hg.el --- VC backend for the mercurial version control system
-
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Ivan Kanis
-;; Keywords: tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This is a mercurial version control backend
-
-;;; Thanks:
-
-;;; Bugs:
-
-;;; Installation:
-
-;;; Todo:
-
-;; 1) Implement the rest of the vc interface. See the comment at the
-;; beginning of vc.el. The current status is:
-
-;; FUNCTION NAME STATUS
-;; BACKEND PROPERTIES
-;; * revision-granularity OK
-;; STATE-QUERYING FUNCTIONS
-;; * registered (file) OK
-;; * state (file) OK
-;; - state-heuristic (file) NOT NEEDED
-;; - dir-status (dir update-function) OK
-;; - dir-status-files (dir files ds uf) OK
-;; - dir-extra-headers (dir) OK
-;; - dir-printer (fileinfo) OK
-;; * working-revision (file) OK
-;; - latest-on-branch-p (file) ??
-;; * checkout-model (files) OK
-;; - workfile-unchanged-p (file) OK
-;; - mode-line-string (file) NOT NEEDED
-;; STATE-CHANGING FUNCTIONS
-;; * register (files &optional rev comment) OK
-;; * create-repo () OK
-;; - init-revision () NOT NEEDED
-;; - responsible-p (file) OK
-;; - could-register (file) OK
-;; - receive-file (file rev) ?? PROBABLY NOT NEEDED
-;; - unregister (file) COMMENTED OUT, MAY BE INCORRECT
-;; * checkin (files rev comment) OK
-;; * find-revision (file rev buffer) OK
-;; * checkout (file &optional editable rev) OK
-;; * revert (file &optional contents-done) OK
-;; - rollback (files) ?? PROBABLY NOT NEEDED
-;; - merge (file rev1 rev2) NEEDED
-;; - merge-news (file) NEEDED
-;; - steal-lock (file &optional revision) NOT NEEDED
-;; HISTORY FUNCTIONS
-;; * print-log (files buffer &optional shortlog start-revision limit) OK
-;; - log-view-mode () OK
-;; - show-log-entry (revision) NOT NEEDED, DEFAULT IS GOOD
-;; - comment-history (file) NOT NEEDED
-;; - update-changelog (files) NOT NEEDED
-;; * diff (files &optional rev1 rev2 buffer) OK
-;; - revision-completion-table (files) OK?
-;; - annotate-command (file buf &optional rev) OK
-;; - annotate-time () OK
-;; - annotate-current-time () NOT NEEDED
-;; - annotate-extract-revision-at-line () OK
-;; TAG SYSTEM
-;; - create-tag (dir name branchp) NEEDED
-;; - retrieve-tag (dir name update) NEEDED
-;; MISCELLANEOUS
-;; - make-version-backups-p (file) ??
-;; - repository-hostname (dirname) ??
-;; - previous-revision (file rev) OK
-;; - next-revision (file rev) OK
-;; - check-headers () ??
-;; - clear-headers () ??
-;; - delete-file (file) TEST IT
-;; - rename-file (old new) OK
-;; - find-file-hook () PROBABLY NOT NEEDED
-
-;; 2) Implement Stefan Monnier's advice:
-;; vc-hg-registered and vc-hg-state
-;; Both of those functions should be super extra careful to fail gracefully in
-;; unexpected circumstances. The reason this is important is that any error
-;; there will prevent the user from even looking at the file :-(
-;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
-;; mercurial's control and extracting the current revision should be done
-;; without even using `hg' (this way even if you don't have `hg' installed,
-;; Emacs is able to tell you this file is under mercurial's control).
-
-;;; History:
-;;
-
-;;; Code:
-
-(eval-when-compile
- (require 'cl)
- (require 'vc)
- (require 'vc-dir))
-
-;;; Customization options
-
-(defcustom vc-hg-global-switches nil
- "Global switches to pass to any Hg command."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "22.2"
- :group 'vc)
-
-(defcustom vc-hg-diff-switches t ; Hg doesn't support common args like -u
- "String or list of strings specifying switches for Hg diff under VC.
-If nil, use the value of `vc-diff-switches'. If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "23.1"
- :group 'vc)
-
-\f
-;;; Properties of the backend
-
-(defun vc-hg-revision-granularity () 'repository)
-(defun vc-hg-checkout-model (files) 'implicit)
-
-;;; State querying functions
-
-;;;###autoload (defun vc-hg-registered (file)
-;;;###autoload "Return non-nil if FILE is registered with hg."
-;;;###autoload (if (vc-find-root file ".hg") ; short cut
-;;;###autoload (progn
-;;;###autoload (load "vc-hg")
-;;;###autoload (vc-hg-registered file))))
-
-;; Modeled after the similar function in vc-bzr.el
-(defun vc-hg-registered (file)
- "Return non-nil if FILE is registered with hg."
- (when (vc-hg-root file) ; short cut
- (let ((state (vc-hg-state file))) ; expensive
- (and state (not (memq state '(ignored unregistered)))))))
-
-(defun vc-hg-state (file)
- "Hg-specific version of `vc-state'."
- (let*
- ((status nil)
- (default-directory (file-name-directory file))
- (out
- (with-output-to-string
- (with-current-buffer
- standard-output
- (setq status
- (condition-case nil
- ;; Ignore all errors.
- (let ((process-environment
- ;; Avoid localization of messages so we
- ;; can parse the output.
- (append (list "TERM=dumb" "LANGUAGE=C" "HGRCPATH=")
- process-environment)))
- (process-file
- "hg" nil t nil
- "status" "-A" (file-relative-name file)))
- ;; Some problem happened. E.g. We can't find an `hg'
- ;; executable.
- (error nil)))))))
- (when (eq 0 status)
- (when (null (string-match ".*: No such file or directory$" out))
- (let ((state (aref out 0)))
- (cond
- ((eq state ?=) 'up-to-date)
- ((eq state ?A) 'added)
- ((eq state ?M) 'edited)
- ((eq state ?I) 'ignored)
- ((eq state ?R) 'removed)
- ((eq state ?!) 'missing)
- ((eq state ??) 'unregistered)
- ((eq state ?C) 'up-to-date) ;; Older mercurials use this
- (t 'up-to-date)))))))
-
-(defun vc-hg-working-revision (file)
- "Hg-specific version of `vc-working-revision'."
- (let*
- ((status nil)
- (default-directory (file-name-directory file))
- ;; Avoid localization of messages so we can parse the output.
- (avoid-local-env (append (list "TERM=dumb" "LANGUAGE=C" "HGRCPATH=")
- process-environment))
- (out
- (with-output-to-string
- (with-current-buffer
- standard-output
- (setq status
- (condition-case nil
- (let ((process-environment avoid-local-env))
- ;; Ignore all errors.
- (process-file
- "hg" nil t nil
- "parents" "--template" "{rev}" (file-relative-name file)))
- ;; Some problem happened. E.g. We can't find an `hg'
- ;; executable.
- (error nil)))))))
- (if (eq 0 status)
- out
- ;; Check if the file is in the 'added state, the above hg
- ;; command does not distinguish between 'added and 'unregistered.
- (setq status
- (condition-case nil
- (let ((process-environment avoid-local-env))
- (process-file
- "hg" nil nil nil
- ;; We use "log" here, if there's a faster command
- ;; that returns true for an 'added file and false
- ;; for an 'unregistered one, we could use that.
- "log" "-l1" (file-relative-name file)))
- ;; Some problem happened. E.g. We can't find an `hg'
- ;; executable.
- (error nil)))
- (when (eq 0 status) "0"))))
-
-;;; History functions
-
-(defcustom vc-hg-log-switches nil
- "String or list of strings specifying switches for hg log under VC."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :group 'vc-hg)
-
-(defun vc-hg-print-log (files buffer &optional shortlog start-revision limit)
- "Get change log associated with FILES."
- ;; `vc-do-command' creates the buffer, but we need it before running
- ;; the command.
- (vc-setup-buffer buffer)
- ;; If the buffer exists from a previous invocation it might be
- ;; read-only.
- (let ((inhibit-read-only t))
- (with-current-buffer
- buffer
- (apply 'vc-hg-command buffer 0 files "log"
- (nconc
- (when start-revision (list (format "-r%s:" start-revision)))
- (when limit (list "-l" (format "%s" limit)))
- (when shortlog (list "--style" "compact"))
- vc-hg-log-switches)))))
-
-(defvar log-view-message-re)
-(defvar log-view-file-re)
-(defvar log-view-font-lock-keywords)
-(defvar log-view-per-file-logs)
-
-(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
- (require 'add-log) ;; we need the add-log faces
- (set (make-local-variable 'log-view-file-re) "\\`a\\`")
- (set (make-local-variable 'log-view-per-file-logs) nil)
- (set (make-local-variable 'log-view-message-re)
- (if (eq vc-log-view-type 'short)
- "^\\([0-9]+\\)\\(\\[.*\\]\\)? +\\([0-9a-z]\\{12\\}\\) +\\(\\(?:[0-9]+\\)-\\(?:[0-9]+\\)-\\(?:[0-9]+\\) \\(?:[0-9]+\\):\\(?:[0-9]+\\) \\(?:[-+0-9]+\\)\\) +\\(.*\\)$"
- "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
- (set (make-local-variable 'log-view-font-lock-keywords)
- (if (eq vc-log-view-type 'short)
- (append `((,log-view-message-re
- (1 'log-view-message-face)
- (2 'highlight nil lax)
- (3 'log-view-message-face)
- (4 'change-log-date)
- (5 'change-log-name))))
- (append
- log-view-font-lock-keywords
- '(
- ;; Handle the case:
- ;; user: FirstName LastName <foo@bar>
- ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
- (1 'change-log-name)
- (2 'change-log-email))
- ;; Handle the cases:
- ;; user: foo@bar
- ;; and
- ;; user: foo
- ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
- (1 'change-log-email))
- ("^date: \\(.+\\)" (1 'change-log-date))
- ("^tag: +\\([^ ]+\\)$" (1 'highlight))
- ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
-
-(defun vc-hg-diff (files &optional oldvers newvers buffer)
- "Get a difference report using hg between two revisions of FILES."
- (let* ((firstfile (car files))
- (working (and firstfile (vc-working-revision firstfile))))
- (when (and (equal oldvers working) (not newvers))
- (setq oldvers nil))
- (when (and (not oldvers) newvers)
- (setq oldvers working))
- (apply #'vc-hg-command (or buffer "*vc-diff*") nil files "diff"
- (append
- (vc-switches 'hg 'diff)
- (when oldvers
- (if newvers
- (list "-r" oldvers "-r" newvers)
- (list "-r" oldvers)))))))
-
-(defun vc-hg-revision-table (files)
- (let ((default-directory (file-name-directory (car files))))
- (with-temp-buffer
- (vc-hg-command t nil files "log" "--template" "{rev} ")
- (split-string
- (buffer-substring-no-properties (point-min) (point-max))))))
-
-;; Modeled after the similar function in vc-cvs.el
-(defun vc-hg-revision-completion-table (files)
- (lexical-let ((files files)
- table)
- (setq table (lazy-completion-table
- table (lambda () (vc-hg-revision-table files))))
- table))
-
-(defun vc-hg-annotate-command (file buffer &optional revision)
- "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
-Optional arg REVISION is a revision to annotate from."
- (vc-hg-command buffer 0 file "annotate" "-d" "-n" "--follow"
- (when revision (concat "-r" revision))))
-
-(declare-function vc-annotate-convert-time "vc-annotate" (time))
-
-;; The format for one line output by "hg annotate -d -n" looks like this:
-;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
-;; i.e: VERSION_NUMBER DATE: CONTENTS
-;; If the user has set the "--follow" option, the output looks like:
-;;215 Wed Jun 20 21:22:58 2007 -0700 foo.c: CONTENTS
-;; i.e. VERSION_NUMBER DATE FILENAME: CONTENTS
-(defconst vc-hg-annotate-re
- "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\)\\(?:\\(: \\)\\|\\(?: +\\(.+\\): \\)\\)")
-
-(defun vc-hg-annotate-time ()
- (when (looking-at vc-hg-annotate-re)
- (goto-char (match-end 0))
- (vc-annotate-convert-time
- (date-to-time (match-string-no-properties 2)))))
-
-(defun vc-hg-annotate-extract-revision-at-line ()
- (save-excursion
- (beginning-of-line)
- (when (looking-at vc-hg-annotate-re)
- (if (match-beginning 3)
- (match-string-no-properties 1)
- (cons (match-string-no-properties 1)
- (expand-file-name (match-string-no-properties 4)
- (vc-hg-root default-directory)))))))
-
-(defun vc-hg-previous-revision (file rev)
- (let ((newrev (1- (string-to-number rev))))
- (when (>= newrev 0)
- (number-to-string newrev))))
-
-(defun vc-hg-next-revision (file rev)
- (let ((newrev (1+ (string-to-number rev)))
- (tip-revision
- (with-temp-buffer
- (vc-hg-command t 0 nil "tip")
- (goto-char (point-min))
- (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
- (string-to-number (match-string-no-properties 1)))))
- ;; We don't want to exceed the maximum possible revision number, ie
- ;; the tip revision.
- (when (<= newrev tip-revision)
- (number-to-string newrev))))
-
-;; Modeled after the similar function in vc-bzr.el
-(defun vc-hg-delete-file (file)
- "Delete FILE and delete it in the hg repository."
- (condition-case ()
- (delete-file file)
- (file-error nil))
- (vc-hg-command nil 0 file "remove" "--after" "--force"))
-
-;; Modeled after the similar function in vc-bzr.el
-(defun vc-hg-rename-file (old new)
- "Rename file from OLD to NEW using `hg mv'."
- (vc-hg-command nil 0 new "mv" old))
-
-(defun vc-hg-register (files &optional rev comment)
- "Register FILES under hg.
-REV is ignored.
-COMMENT is ignored."
- (vc-hg-command nil 0 files "add"))
-
-(defun vc-hg-create-repo ()
- "Create a new Mercurial repository."
- (vc-hg-command nil 0 nil "init"))
-
-(defalias 'vc-hg-responsible-p 'vc-hg-root)
-
-;; Modeled after the similar function in vc-bzr.el
-(defun vc-hg-could-register (file)
- "Return non-nil if FILE could be registered under hg."
- (and (vc-hg-responsible-p file) ; shortcut
- (condition-case ()
- (with-temp-buffer
- (vc-hg-command t nil file "add" "--dry-run"))
- ;; The command succeeds with no output if file is
- ;; registered.
- (error))))
-
-;; FIXME: This would remove the file. Is that correct?
-;; (defun vc-hg-unregister (file)
-;; "Unregister FILE from hg."
-;; (vc-hg-command nil nil file "remove"))
-
-(declare-function log-edit-extract-headers "log-edit" (headers string))
-
-(defun vc-hg-checkin (files rev comment)
- "Hg-specific version of `vc-backend-checkin'.
-REV is ignored."
- (apply 'vc-hg-command nil 0 files
- (nconc (list "commit" "-m")
- (log-edit-extract-headers '(("Author" . "--user")
- ("Date" . "--date"))
- comment))))
-
-(defun vc-hg-find-revision (file rev buffer)
- (let ((coding-system-for-read 'binary)
- (coding-system-for-write 'binary))
- (if rev
- (vc-hg-command buffer 0 file "cat" "-r" rev)
- (vc-hg-command buffer 0 file "cat"))))
-
-;; Modeled after the similar function in vc-bzr.el
-(defun vc-hg-checkout (file &optional editable rev)
- "Retrieve a revision of FILE.
-EDITABLE is ignored.
-REV is the revision to check out into WORKFILE."
- (let ((coding-system-for-read 'binary)
- (coding-system-for-write 'binary))
- (with-current-buffer (or (get-file-buffer file) (current-buffer))
- (if rev
- (vc-hg-command t 0 file "cat" "-r" rev)
- (vc-hg-command t 0 file "cat")))))
-
-;; Modeled after the similar function in vc-bzr.el
-(defun vc-hg-workfile-unchanged-p (file)
- (eq 'up-to-date (vc-hg-state file)))
-
-;; Modeled after the similar function in vc-bzr.el
-(defun vc-hg-revert (file &optional contents-done)
- (unless contents-done
- (with-temp-buffer (vc-hg-command t 0 file "revert"))))
-
-;;; Hg specific functionality.
-
-(defvar vc-hg-extra-menu-map
- (let ((map (make-sparse-keymap)))
- map))
-
-(defun vc-hg-extra-menu () vc-hg-extra-menu-map)
-
-(defun vc-hg-extra-status-menu () vc-hg-extra-menu-map)
-
-(defvar log-view-vc-backend)
-
-(defstruct (vc-hg-extra-fileinfo
- (:copier nil)
- (:constructor vc-hg-create-extra-fileinfo (rename-state extra-name))
- (:conc-name vc-hg-extra-fileinfo->))
- rename-state ;; rename or copy state
- extra-name) ;; original name for copies and rename targets, new name for
-
-(declare-function vc-default-dir-printer "vc-dir" (backend fileentry))
-
-(defun vc-hg-dir-printer (info)
- "Pretty-printer for the vc-dir-fileinfo structure."
- (let ((extra (vc-dir-fileinfo->extra info)))
- (vc-default-dir-printer 'Hg info)
- (when extra
- (insert (propertize
- (format " (%s %s)"
- (case (vc-hg-extra-fileinfo->rename-state extra)
- ('copied "copied from")
- ('renamed-from "renamed from")
- ('renamed-to "renamed to"))
- (vc-hg-extra-fileinfo->extra-name extra))
- 'face 'font-lock-comment-face)))))
-
-(defun vc-hg-after-dir-status (update-function)
- (let ((status-char nil)
- (file nil)
- (translation '((?= . up-to-date)
- (?C . up-to-date)
- (?A . added)
- (?R . removed)
- (?M . edited)
- (?I . ignored)
- (?! . missing)
- (? . copy-rename-line)
- (?? . unregistered)))
- (translated nil)
- (result nil)
- (last-added nil)
- (last-line-copy nil))
- (goto-char (point-min))
- (while (not (eobp))
- (setq translated (cdr (assoc (char-after) translation)))
- (setq file
- (buffer-substring-no-properties (+ (point) 2)
- (line-end-position)))
- (cond ((not translated)
- (setq last-line-copy nil))
- ((eq translated 'up-to-date)
- (setq last-line-copy nil))
- ((eq translated 'copy-rename-line)
- ;; For copied files the output looks like this:
- ;; A COPIED_FILE_NAME
- ;; ORIGINAL_FILE_NAME
- (setf (nth 2 last-added)
- (vc-hg-create-extra-fileinfo 'copied file))
- (setq last-line-copy t))
- ((and last-line-copy (eq translated 'removed))
- ;; For renamed files the output looks like this:
- ;; A NEW_FILE_NAME
- ;; ORIGINAL_FILE_NAME
- ;; R ORIGINAL_FILE_NAME
- ;; We need to adjust the previous entry to not think it is a copy.
- (setf (vc-hg-extra-fileinfo->rename-state (nth 2 last-added))
- 'renamed-from)
- (push (list file translated
- (vc-hg-create-extra-fileinfo
- 'renamed-to (nth 0 last-added))) result)
- (setq last-line-copy nil))
- (t
- (setq last-added (list file translated nil))
- (push last-added result)
- (setq last-line-copy nil)))
- (forward-line))
- (funcall update-function result)))
-
-(defun vc-hg-dir-status (dir update-function)
- (vc-hg-command (current-buffer) 'async dir "status" "-C")
- (vc-exec-after
- `(vc-hg-after-dir-status (quote ,update-function))))
-
-(defun vc-hg-dir-status-files (dir files default-state update-function)
- (apply 'vc-hg-command (current-buffer) 'async dir "status" "-C" files)
- (vc-exec-after
- `(vc-hg-after-dir-status (quote ,update-function))))
-
-(defun vc-hg-dir-extra-header (name &rest commands)
- (concat (propertize name 'face 'font-lock-type-face)
- (propertize
- (with-temp-buffer
- (apply 'vc-hg-command (current-buffer) 0 nil commands)
- (buffer-substring-no-properties (point-min) (1- (point-max))))
- 'face 'font-lock-variable-name-face)))
-
-(defun vc-hg-dir-extra-headers (dir)
- "Generate extra status headers for a Mercurial tree."
- (let ((default-directory dir))
- (concat
- (vc-hg-dir-extra-header "Root : " "root") "\n"
- (vc-hg-dir-extra-header "Branch : " "id" "-b") "\n"
- (vc-hg-dir-extra-header "Tags : " "id" "-t") ; "\n"
- ;; these change after each commit
- ;; (vc-hg-dir-extra-header "Local num : " "id" "-n") "\n"
- ;; (vc-hg-dir-extra-header "Global id : " "id" "-i")
- )))
-
-(defun vc-hg-log-incoming (buffer remote-location)
- (vc-hg-command buffer 1 nil "incoming" "-n" (unless (string= remote-location "")
- remote-location)))
-
-(defun vc-hg-log-outgoing (buffer remote-location)
- (vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "")
- remote-location)))
-
-(declare-function log-view-get-marked "log-view" ())
-
-;; XXX maybe also add key bindings for these functions.
-(defun vc-hg-push ()
- (interactive)
- (let ((marked-list (log-view-get-marked)))
- (if marked-list
- (apply #'vc-hg-command
- nil 0 nil
- "push"
- (apply 'nconc
- (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
- (error "No log entries selected for push"))))
-
-(defun vc-hg-pull ()
- (interactive)
- (let ((marked-list (log-view-get-marked)))
- (if marked-list
- (apply #'vc-hg-command
- nil 0 nil
- "pull"
- (apply 'nconc
- (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
- (error "No log entries selected for pull"))))
-
-;;; Internal functions
-
-(defun vc-hg-command (buffer okstatus file-or-list &rest flags)
- "A wrapper around `vc-do-command' for use in vc-hg.el.
-The difference to vc-do-command is that this function always invokes `hg',
-and that it passes `vc-hg-global-switches' to it before FLAGS."
- (apply 'vc-do-command (or buffer "*vc*") okstatus "hg" file-or-list
- (if (stringp vc-hg-global-switches)
- (cons vc-hg-global-switches flags)
- (append vc-hg-global-switches
- flags))))
-
-(defun vc-hg-root (file)
- (vc-find-root file ".hg"))
-
-(provide 'vc-hg)
-
-;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
-;;; vc-hg.el ends here
+++ /dev/null
-;;; vc-hooks.el --- resident support for version-control
-
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Author: FSF (see vc.el for full credits)
-;; Maintainer: Andre Spiegel <spiegel@gnu.org>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This is the always-loaded portion of VC. It takes care of
-;; VC-related activities that are done when you visit a file, so that
-;; vc.el itself is loaded only when you use a VC command. See the
-;; commentary of vc.el.
-
-;;; Code:
-
-(eval-when-compile
- (require 'cl))
-
-;; Customization Variables (the rest is in vc.el)
-
-(defvar vc-ignore-vc-files nil)
-(make-obsolete-variable 'vc-ignore-vc-files
- "set `vc-handled-backends' to nil to disable VC."
- "21.1")
-
-(defvar vc-master-templates ())
-(make-obsolete-variable 'vc-master-templates
- "to define master templates for a given BACKEND, use
-vc-BACKEND-master-templates. To enable or disable VC for a given
-BACKEND, use `vc-handled-backends'."
- "21.1")
-
-(defvar vc-header-alist ())
-(make-obsolete-variable 'vc-header-alist 'vc-BACKEND-header "21.1")
-
-(defcustom vc-ignore-dir-regexp
- ;; Stop SMB, automounter, AFS, and DFS host lookups.
- locate-dominating-stop-dir-regexp
- "Regexp matching directory names that are not under VC's control.
-The default regexp prevents fruitless and time-consuming attempts
-to determine the VC status in directories in which filenames are
-interpreted as hostnames."
- :type 'regexp
- :group 'vc)
-
-(defcustom vc-handled-backends '(RCS CVS SVN SCCS Bzr Git Hg Mtn Arch)
- ;; RCS, CVS, SVN and SCCS come first because they are per-dir
- ;; rather than per-tree. RCS comes first because of the multibackend
- ;; support intended to use RCS for local commits (with a remote CVS server).
- "List of version control backends for which VC will be used.
-Entries in this list will be tried in order to determine whether a
-file is under that sort of version control.
-Removing an entry from the list prevents VC from being activated
-when visiting a file managed by that backend.
-An empty list disables VC altogether."
- :type '(repeat symbol)
- :version "23.1"
- :group 'vc)
-
-;; Note: we don't actually have a darcs back end yet.
-;; Also, Meta-CVS (corresponsding to MCVS) is unsupported.
-(defcustom vc-directory-exclusion-list (purecopy '("SCCS" "RCS" "CVS" "MCVS"
- ".svn" ".git" ".hg" ".bzr"
- "_MTN" "_darcs" "{arch}"))
- "List of directory names to be ignored when walking directory trees."
- :type '(repeat string)
- :group 'vc)
-
-(defcustom vc-make-backup-files nil
- "If non-nil, backups of registered files are made as with other files.
-If nil (the default), files covered by version control don't get backups."
- :type 'boolean
- :group 'vc
- :group 'backup)
-
-(defcustom vc-follow-symlinks 'ask
- "What to do if visiting a symbolic link to a file under version control.
-Editing such a file through the link bypasses the version control system,
-which is dangerous and probably not what you want.
-
-If this variable is t, VC follows the link and visits the real file,
-telling you about it in the echo area. If it is `ask', VC asks for
-confirmation whether it should follow the link. If nil, the link is
-visited and a warning displayed."
- :type '(choice (const :tag "Ask for confirmation" ask)
- (const :tag "Visit link and warn" nil)
- (const :tag "Follow link" t))
- :group 'vc)
-
-(defcustom vc-display-status t
- "If non-nil, display revision number and lock status in modeline.
-Otherwise, not displayed."
- :type 'boolean
- :group 'vc)
-
-
-(defcustom vc-consult-headers t
- "If non-nil, identify work files by searching for version headers."
- :type 'boolean
- :group 'vc)
-
-(defcustom vc-keep-workfiles t
- "If non-nil, don't delete working files after registering changes.
-If the back-end is CVS, workfiles are always kept, regardless of the
-value of this flag."
- :type 'boolean
- :group 'vc)
-
-(defcustom vc-mistrust-permissions nil
- "If non-nil, don't assume permissions/ownership track version-control status.
-If nil, do rely on the permissions.
-See also variable `vc-consult-headers'."
- :type 'boolean
- :group 'vc)
-
-(defun vc-mistrust-permissions (file)
- "Internal access function to variable `vc-mistrust-permissions' for FILE."
- (or (eq vc-mistrust-permissions 't)
- (and vc-mistrust-permissions
- (funcall vc-mistrust-permissions
- (vc-backend-subdirectory-name file)))))
-
-(defcustom vc-stay-local 'only-file
- "Non-nil means use local operations when possible for remote repositories.
-This avoids slow queries over the network and instead uses heuristics
-and past information to determine the current status of a file.
-
-If value is the symbol `only-file' `vc-dir' will connect to the
-server, but heuristics will be used to determine the status for
-all other VC operations.
-
-The value can also be a regular expression or list of regular
-expressions to match against the host name of a repository; then VC
-only stays local for hosts that match it. Alternatively, the value
-can be a list of regular expressions where the first element is the
-symbol `except'; then VC always stays local except for hosts matched
-by these regular expressions."
- :type '(choice
- (const :tag "Always stay local" t)
- (const :tag "Only for file operations" only-file)
- (const :tag "Don't stay local" nil)
- (list :format "\nExamine hostname and %v" :tag "Examine hostname ..."
- (set :format "%v" :inline t (const :format "%t" :tag "don't" except))
- (regexp :format " stay local,\n%t: %v" :tag "if it matches")
- (repeat :format "%v%i\n" :inline t (regexp :tag "or"))))
- :version "23.1"
- :group 'vc)
-
-(defun vc-stay-local-p (file &optional backend)
- "Return non-nil if VC should stay local when handling FILE.
-This uses the `repository-hostname' backend operation.
-If FILE is a list of files, return non-nil if any of them
-individually should stay local."
- (if (listp file)
- (delq nil (mapcar (lambda (arg) (vc-stay-local-p arg backend)) file))
- (setq backend (or backend (vc-backend file)))
- (let* ((sym (vc-make-backend-sym backend 'stay-local))
- (stay-local (if (boundp sym) (symbol-value sym) vc-stay-local)))
- (if (symbolp stay-local) stay-local
- (let ((dirname (if (file-directory-p file)
- (directory-file-name file)
- (file-name-directory file))))
- (eq 'yes
- (or (vc-file-getprop dirname 'vc-stay-local-p)
- (vc-file-setprop
- dirname 'vc-stay-local-p
- (let ((hostname (vc-call-backend
- backend 'repository-hostname dirname)))
- (if (not hostname)
- 'no
- (let ((default t))
- (if (eq (car-safe stay-local) 'except)
- (setq default nil stay-local (cdr stay-local)))
- (when (consp stay-local)
- (setq stay-local
- (mapconcat 'identity stay-local "\\|")))
- (if (if (string-match stay-local hostname)
- default (not default))
- 'yes 'no))))))))))))
-
-;;; This is handled specially now.
-;; Tell Emacs about this new kind of minor mode
-;; (add-to-list 'minor-mode-alist '(vc-mode vc-mode))
-
-;;;###autoload
-(put 'vc-mode 'risky-local-variable t)
-(make-variable-buffer-local 'vc-mode)
-(put 'vc-mode 'permanent-local t)
-
-(defun vc-mode (&optional arg)
- ;; Dummy function for C-h m
- "Version Control minor mode.
-This minor mode is automatically activated whenever you visit a file under
-control of one of the revision control systems in `vc-handled-backends'.
-VC commands are globally reachable under the prefix `\\[vc-prefix-map]':
-\\{vc-prefix-map}")
-
-(defmacro vc-error-occurred (&rest body)
- `(condition-case nil (progn ,@body nil) (error t)))
-
-;; We need a notion of per-file properties because the version
-;; control state of a file is expensive to derive --- we compute
-;; them when the file is initially found, keep them up to date
-;; during any subsequent VC operations, and forget them when
-;; the buffer is killed.
-
-(defvar vc-file-prop-obarray (make-vector 17 0)
- "Obarray for per-file properties.")
-
-(defvar vc-touched-properties nil)
-
-(defun vc-file-setprop (file property value)
- "Set per-file VC PROPERTY for FILE to VALUE."
- (if (and vc-touched-properties
- (not (memq property vc-touched-properties)))
- (setq vc-touched-properties (append (list property)
- vc-touched-properties)))
- (put (intern file vc-file-prop-obarray) property value))
-
-(defun vc-file-getprop (file property)
- "Get per-file VC PROPERTY for FILE."
- (get (intern file vc-file-prop-obarray) property))
-
-(defun vc-file-clearprops (file)
- "Clear all VC properties of FILE."
- (setplist (intern file vc-file-prop-obarray) nil))
-
-\f
-;; We keep properties on each symbol naming a backend as follows:
-;; * `vc-functions': an alist mapping vc-FUNCTION to vc-BACKEND-FUNCTION.
-
-(defun vc-make-backend-sym (backend sym)
- "Return BACKEND-specific version of VC symbol SYM."
- (intern (concat "vc-" (downcase (symbol-name backend))
- "-" (symbol-name sym))))
-
-(defun vc-find-backend-function (backend fun)
- "Return BACKEND-specific implementation of FUN.
-If there is no such implementation, return the default implementation;
-if that doesn't exist either, return nil."
- (let ((f (vc-make-backend-sym backend fun)))
- (if (fboundp f) f
- ;; Load vc-BACKEND.el if needed.
- (require (intern (concat "vc-" (downcase (symbol-name backend)))))
- (if (fboundp f) f
- (let ((def (vc-make-backend-sym 'default fun)))
- (if (fboundp def) (cons def backend) nil))))))
-
-(defun vc-call-backend (backend function-name &rest args)
- "Call for BACKEND the implementation of FUNCTION-NAME with the given ARGS.
-Calls
-
- (apply 'vc-BACKEND-FUN ARGS)
-
-if vc-BACKEND-FUN exists (after trying to find it in vc-BACKEND.el)
-and else calls
-
- (apply 'vc-default-FUN BACKEND ARGS)
-
-It is usually called via the `vc-call' macro."
- (let ((f (assoc function-name (get backend 'vc-functions))))
- (if f (setq f (cdr f))
- (setq f (vc-find-backend-function backend function-name))
- (push (cons function-name f) (get backend 'vc-functions)))
- (cond
- ((null f)
- (error "Sorry, %s is not implemented for %s" function-name backend))
- ((consp f) (apply (car f) (cdr f) args))
- (t (apply f args)))))
-
-(defmacro vc-call (fun file &rest args)
- "A convenience macro for calling VC backend functions.
-Functions called by this macro must accept FILE as the first argument.
-ARGS specifies any additional arguments. FUN should be unquoted.
-BEWARE!! FILE is evaluated twice!!"
- `(vc-call-backend (vc-backend ,file) ',fun ,file ,@args))
-\f
-(defsubst vc-parse-buffer (pattern i)
- "Find PATTERN in the current buffer and return its Ith submatch."
- (goto-char (point-min))
- (if (re-search-forward pattern nil t)
- (match-string i)))
-
-(defun vc-insert-file (file &optional limit blocksize)
- "Insert the contents of FILE into the current buffer.
-
-Optional argument LIMIT is a regexp. If present, the file is inserted
-in chunks of size BLOCKSIZE (default 8 kByte), until the first
-occurrence of LIMIT is found. Anything from the start of that occurrence
-to the end of the buffer is then deleted. The function returns
-non-nil if FILE exists and its contents were successfully inserted."
- (erase-buffer)
- (when (file-exists-p file)
- (if (not limit)
- (insert-file-contents file)
- (unless blocksize (setq blocksize 8192))
- (let ((filepos 0))
- (while
- (and (< 0 (cadr (insert-file-contents
- file nil filepos (incf filepos blocksize))))
- (progn (beginning-of-line)
- (let ((pos (re-search-forward limit nil 'move)))
- (when pos (delete-region (match-beginning 0)
- (point-max)))
- (not pos)))))))
- (set-buffer-modified-p nil)
- t))
-
-(defun vc-find-root (file witness)
- "Find the root of a checked out project.
-The function walks up the directory tree from FILE looking for WITNESS.
-If WITNESS if not found, return nil, otherwise return the root."
- (let ((locate-dominating-stop-dir-regexp
- (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp)))
- (locate-dominating-file file witness)))
-
-;; Access functions to file properties
-;; (Properties should be _set_ using vc-file-setprop, but
-;; _retrieved_ only through these functions, which decide
-;; if the property is already known or not. A property should
-;; only be retrieved by vc-file-getprop if there is no
-;; access function.)
-
-;; properties indicating the backend being used for FILE
-
-(defun vc-registered (file)
- "Return non-nil if FILE is registered in a version control system.
-
-This function performs the check each time it is called. To rely
-on the result of a previous call, use `vc-backend' instead. If the
-file was previously registered under a certain backend, then that
-backend is tried first."
- (let (handler)
- (cond
- ((and (file-name-directory file)
- (string-match vc-ignore-dir-regexp (file-name-directory file)))
- nil)
- ((and (boundp 'file-name-handler-alist)
- (setq handler (find-file-name-handler file 'vc-registered)))
- ;; handler should set vc-backend and return t if registered
- (funcall handler 'vc-registered file))
- (t
- ;; There is no file name handler.
- ;; Try vc-BACKEND-registered for each handled BACKEND.
- (catch 'found
- (let ((backend (vc-file-getprop file 'vc-backend)))
- (mapc
- (lambda (b)
- (and (vc-call-backend b 'registered file)
- (vc-file-setprop file 'vc-backend b)
- (throw 'found t)))
- (if (or (not backend) (eq backend 'none))
- vc-handled-backends
- (cons backend vc-handled-backends))))
- ;; File is not registered.
- (vc-file-setprop file 'vc-backend 'none)
- nil)))))
-
-(defun vc-backend (file-or-list)
- "Return the version control type of FILE-OR-LIST, nil if it's not registered.
-If the argument is a list, the files must all have the same back end."
- ;; `file' can be nil in several places (typically due to the use of
- ;; code like (vc-backend buffer-file-name)).
- (cond ((stringp file-or-list)
- (let ((property (vc-file-getprop file-or-list 'vc-backend)))
- ;; Note that internally, Emacs remembers unregistered
- ;; files by setting the property to `none'.
- (cond ((eq property 'none) nil)
- (property)
- ;; vc-registered sets the vc-backend property
- (t (if (vc-registered file-or-list)
- (vc-file-getprop file-or-list 'vc-backend)
- nil)))))
- ((and file-or-list (listp file-or-list))
- (vc-backend (car file-or-list)))
- (t
- nil)))
-
-
-(defun vc-backend-subdirectory-name (file)
- "Return where the repository for the current directory is kept."
- (symbol-name (vc-backend file)))
-
-(defun vc-name (file)
- "Return the master name of FILE.
-If the file is not registered, or the master name is not known, return nil."
- ;; TODO: This should ultimately become obsolete, at least up here
- ;; in vc-hooks.
- (or (vc-file-getprop file 'vc-name)
- ;; force computation of the property by calling
- ;; vc-BACKEND-registered explicitly
- (let ((backend (vc-backend file)))
- (if (and backend
- (vc-call-backend backend 'registered file))
- (vc-file-getprop file 'vc-name)))))
-
-(defun vc-checkout-model (backend files)
- "Indicate how FILES are checked out.
-
-If FILES are not registered, this function always returns nil.
-For registered files, the possible values are:
-
- 'implicit FILES are always writable, and checked out `implicitly'
- when the user saves the first changes to the file.
-
- 'locking FILES are read-only if up-to-date; user must type
- \\[vc-next-action] before editing. Strict locking
- is assumed.
-
- 'announce FILES are read-only if up-to-date; user must type
- \\[vc-next-action] before editing. But other users
- may be editing at the same time."
- (vc-call-backend backend 'checkout-model files))
-
-(defun vc-user-login-name (file)
- "Return the name under which the user accesses the given FILE."
- (or (and (eq (string-match tramp-file-name-regexp file) 0)
- ;; tramp case: execute "whoami" via tramp
- (let ((default-directory (file-name-directory file))
- process-file-side-effects)
- (with-temp-buffer
- (if (not (zerop (process-file "whoami" nil t)))
- ;; fall through if "whoami" didn't work
- nil
- ;; remove trailing newline
- (delete-region (1- (point-max)) (point-max))
- (buffer-string)))))
- ;; normal case
- (user-login-name)
- ;; if user-login-name is nil, return the UID as a string
- (number-to-string (user-uid))))
-
-(defun vc-state (file &optional backend)
- "Return the version control state of FILE.
-
-If FILE is not registered, this function always returns nil.
-For registered files, the value returned is one of:
-
- 'up-to-date The working file is unmodified with respect to the
- latest version on the current branch, and not locked.
-
- 'edited The working file has been edited by the user. If
- locking is used for the file, this state means that
- the current version is locked by the calling user.
- This status should *not* be reported for files
- which have a changed mtime but the same content
- as the repo copy.
-
- USER The current version of the working file is locked by
- some other USER (a string).
-
- 'needs-update The file has not been edited by the user, but there is
- a more recent version on the current branch stored
- in the repository.
-
- 'needs-merge The file has been edited by the user, and there is also
- a more recent version on the current branch stored in
- the repository. This state can only occur if locking
- is not used for the file.
-
- 'unlocked-changes The working version of the file is not locked,
- but the working file has been changed with respect
- to that version. This state can only occur for files
- with locking; it represents an erroneous condition that
- should be resolved by the user (vc-next-action will
- prompt the user to do it).
-
- 'added Scheduled to go into the repository on the next commit.
- Often represented by vc-working-revision = \"0\" in VCSes
- with monotonic IDs like Subversion and Mercurial.
-
- 'removed Scheduled to be deleted from the repository on next commit.
-
- 'conflict The file contains conflicts as the result of a merge.
- For now the conflicts are text conflicts. In the
- future this might be extended to deal with metadata
- conflicts too.
-
- 'missing The file is not present in the file system, but the VC
- system still tracks it.
-
- 'ignored The file showed up in a dir-status listing with a flag
- indicating the version-control system is ignoring it,
- Note: This property is not set reliably (some VCSes
- don't have useful directory-status commands) so assume
- that any file with vc-state nil might be ignorable
- without VC knowing it.
-
- 'unregistered The file is not under version control.
-
-A return of nil from this function means we have no information on the
-status of this file."
- ;; Note: in Emacs 22 and older, return of nil meant the file was
- ;; unregistered. This is potentially a source of
- ;; backward-compatibility bugs.
-
- ;; FIXME: New (sub)states needed (?):
- ;; - `copied' and `moved' (might be handled by `removed' and `added')
- (or (vc-file-getprop file 'vc-state)
- (when (> (length file) 0) ;Why?? --Stef
- (setq backend (or backend (vc-backend file)))
- (when backend
- (vc-state-refresh file backend)))))
-
-(defun vc-state-refresh (file backend)
- "Quickly recompute the `state' of FILE."
- (vc-file-setprop
- file 'vc-state
- (vc-call-backend backend 'state-heuristic file)))
-
-(defsubst vc-up-to-date-p (file)
- "Convenience function that checks whether `vc-state' of FILE is `up-to-date'."
- (eq (vc-state file) 'up-to-date))
-
-(defun vc-default-state-heuristic (backend file)
- "Default implementation of vc-BACKEND-state-heuristic.
-It simply calls the real state computation function `vc-BACKEND-state'
-and does not employ any heuristic at all."
- (vc-call-backend backend 'state file))
-
-(defun vc-workfile-unchanged-p (file)
- "Return non-nil if FILE has not changed since the last checkout."
- (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
- (lastmod (nth 5 (file-attributes file))))
- ;; This is a shortcut for determining when the workfile is
- ;; unchanged. It can fail under some circumstances; see the
- ;; discussion in bug#694.
- (if (and checkout-time
- ;; Tramp and Ange-FTP return this when they don't know the time.
- (not (equal lastmod '(0 0))))
- (equal checkout-time lastmod)
- (let ((unchanged (vc-call workfile-unchanged-p file)))
- (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0))
- unchanged))))
-
-(defun vc-default-workfile-unchanged-p (backend file)
- "Check if FILE is unchanged by diffing against the repository version.
-Return non-nil if FILE is unchanged."
- (zerop (condition-case err
- ;; If the implementation supports it, let the output
- ;; go to *vc*, not *vc-diff*, since this is an internal call.
- (vc-call-backend backend 'diff (list file) nil nil "*vc*")
- (wrong-number-of-arguments
- ;; If this error came from the above call to vc-BACKEND-diff,
- ;; try again without the optional buffer argument (for
- ;; backward compatibility). Otherwise, resignal.
- (if (or (not (eq (cadr err)
- (indirect-function
- (vc-find-backend-function backend 'diff))))
- (not (eq (caddr err) 4)))
- (signal (car err) (cdr err))
- (vc-call-backend backend 'diff (list file)))))))
-
-(defun vc-working-revision (file &optional backend)
- "Return the repository version from which FILE was checked out.
-If FILE is not registered, this function always returns nil."
- (or (vc-file-getprop file 'vc-working-revision)
- (progn
- (setq backend (or backend (vc-backend file)))
- (when backend
- (vc-file-setprop file 'vc-working-revision
- (vc-call-backend backend 'working-revision file))))))
-
-;; Backward compatibility.
-(define-obsolete-function-alias
- 'vc-workfile-version 'vc-working-revision "23.1")
-(defun vc-default-working-revision (backend file)
- (message
- "`working-revision' not found: using the old `workfile-version' instead")
- (vc-call-backend backend 'workfile-version file))
-
-(defun vc-default-registered (backend file)
- "Check if FILE is registered in BACKEND using vc-BACKEND-master-templates."
- (let ((sym (vc-make-backend-sym backend 'master-templates)))
- (unless (get backend 'vc-templates-grabbed)
- (put backend 'vc-templates-grabbed t)
- (set sym (append (delq nil
- (mapcar
- (lambda (template)
- (and (consp template)
- (eq (cdr template) backend)
- (car template)))
- (with-no-warnings
- vc-master-templates)))
- (symbol-value sym))))
- (let ((result (vc-check-master-templates file (symbol-value sym))))
- (if (stringp result)
- (vc-file-setprop file 'vc-name result)
- nil)))) ; Not registered
-
-(defun vc-possible-master (s dirname basename)
- (cond
- ((stringp s) (format s dirname basename))
- ((functionp s)
- ;; The template is a function to invoke. If the
- ;; function returns non-nil, that means it has found a
- ;; master. For backward compatibility, we also handle
- ;; the case that the function throws a 'found atom
- ;; and a pair (cons MASTER-FILE BACKEND).
- (let ((result (catch 'found (funcall s dirname basename))))
- (if (consp result) (car result) result)))))
-
-(defun vc-check-master-templates (file templates)
- "Return non-nil if there is a master corresponding to FILE.
-
-TEMPLATES is a list of strings or functions. If an element is a
-string, it must be a control string as required by `format', with two
-string placeholders, such as \"%sRCS/%s,v\". The directory part of
-FILE is substituted for the first placeholder, the basename of FILE
-for the second. If a file with the resulting name exists, it is taken
-as the master of FILE, and returned.
-
-If an element of TEMPLATES is a function, it is called with the
-directory part and the basename of FILE as arguments. It should
-return non-nil if it finds a master; that value is then returned by
-this function."
- (let ((dirname (or (file-name-directory file) ""))
- (basename (file-name-nondirectory file)))
- (catch 'found
- (mapcar
- (lambda (s)
- (let ((trial (vc-possible-master s dirname basename)))
- (when (and trial (file-exists-p trial)
- ;; Make sure the file we found with name
- ;; TRIAL is not the source file itself.
- ;; That can happen with RCS-style names if
- ;; the file name is truncated (e.g. to 14
- ;; chars). See if either directory or
- ;; attributes differ.
- (or (not (string= dirname
- (file-name-directory trial)))
- (not (equal (file-attributes file)
- (file-attributes trial)))))
- (throw 'found trial))))
- templates))))
-
-(defun vc-toggle-read-only (&optional verbose)
- "Change read-only status of current buffer, perhaps via version control.
-
-If the buffer is visiting a file registered with version control,
-throw an error, because this is not a safe or really meaningful operation
-on any version-control system newer than RCS.
-
-Otherwise, just change the read-only flag of the buffer.
-
-If you bind this function to \\[toggle-read-only], then Emacs
-will properly intercept all attempts to toggle the read-only flag
-on version-controlled buffer."
- (interactive "P")
- (if (vc-backend buffer-file-name)
- (error "Toggling the readability of a version controlled file is likely to wreak havoc")
- (toggle-read-only)))
-
-(defun vc-default-make-version-backups-p (backend file)
- "Return non-nil if unmodified versions should be backed up locally.
-The default is to switch off this feature."
- nil)
-
-(defun vc-version-backup-file-name (file &optional rev manual regexp)
- "Return a backup file name for REV or the current version of FILE.
-If MANUAL is non-nil it means that a name for backups created by
-the user should be returned; if REGEXP is non-nil that means to return
-a regexp for matching all such backup files, regardless of the version."
- (if regexp
- (concat (regexp-quote (file-name-nondirectory file))
- "\\.~.+" (unless manual "\\.") "~")
- (expand-file-name (concat (file-name-nondirectory file)
- ".~" (subst-char-in-string
- ?/ ?_ (or rev (vc-working-revision file)))
- (unless manual ".") "~")
- (file-name-directory file))))
-
-(defun vc-delete-automatic-version-backups (file)
- "Delete all existing automatic version backups for FILE."
- (condition-case nil
- (mapc
- 'delete-file
- (directory-files (or (file-name-directory file) default-directory) t
- (vc-version-backup-file-name file nil nil t)))
- ;; Don't fail when the directory doesn't exist.
- (file-error nil)))
-
-(defun vc-make-version-backup (file)
- "Make a backup copy of FILE, which is assumed in sync with the repository.
-Before doing that, check if there are any old backups and get rid of them."
- (unless (and (fboundp 'msdos-long-file-names)
- (not (with-no-warnings (msdos-long-file-names))))
- (vc-delete-automatic-version-backups file)
- (condition-case nil
- (copy-file file (vc-version-backup-file-name file)
- nil 'keep-date)
- ;; It's ok if it doesn't work (e.g. directory not writable),
- ;; since this is just for efficiency.
- (file-error
- (message
- (concat "Warning: Cannot make version backup; "
- "diff/revert therefore not local"))))))
-
-(defun vc-before-save ()
- "Function to be called by `basic-save-buffer' (in files.el)."
- ;; If the file on disk is still in sync with the repository,
- ;; and version backups should be made, copy the file to
- ;; another name. This enables local diffs and local reverting.
- (let ((file buffer-file-name)
- backend)
- (ignore-errors ;Be careful not to prevent saving the file.
- (and (setq backend (vc-backend file))
- (vc-up-to-date-p file)
- (eq (vc-checkout-model backend (list file)) 'implicit)
- (vc-call-backend backend 'make-version-backups-p file)
- (vc-make-version-backup file)))))
-
-(declare-function vc-dir-resynch-file "vc-dir" (&optional fname))
-
-(defvar vc-dir-buffers nil "List of vc-dir buffers.")
-
-(defun vc-after-save ()
- "Function to be called by `basic-save-buffer' (in files.el)."
- ;; If the file in the current buffer is under version control,
- ;; up-to-date, and locking is not used for the file, set
- ;; the state to 'edited and redisplay the mode line.
- (let* ((file buffer-file-name)
- (backend (vc-backend file)))
- (and backend
- (or (and (equal (vc-file-getprop file 'vc-checkout-time)
- (nth 5 (file-attributes file)))
- ;; File has been saved in the same second in which
- ;; it was checked out. Clear the checkout-time
- ;; to avoid confusion.
- (vc-file-setprop file 'vc-checkout-time nil))
- t)
- (eq (vc-checkout-model backend (list file)) 'implicit)
- (vc-state-refresh file backend)
- (vc-mode-line file backend))
- ;; Try to avoid unnecessary work, a *vc-dir* buffer is
- ;; present if this is true.
- (when vc-dir-buffers
- (vc-dir-resynch-file file))))
-
-(defvar vc-menu-entry
- `(menu-item ,(purecopy "Version Control") vc-menu-map
- :filter vc-menu-map-filter))
-
-(when (boundp 'menu-bar-tools-menu)
- ;; We do not need to worry here about the placement of this entry
- ;; because menu-bar.el has already created the proper spot for us
- ;; and this will simply use it.
- (define-key menu-bar-tools-menu [vc] vc-menu-entry))
-
-(defconst vc-mode-line-map
- (let ((map (make-sparse-keymap)))
- (define-key map [mode-line down-mouse-1] vc-menu-entry)
- map))
-
-(defun vc-mode-line (file &optional backend)
- "Set `vc-mode' to display type of version control for FILE.
-The value is set in the current buffer, which should be the buffer
-visiting FILE.
-If BACKEND is passed use it as the VC backend when computing the result."
- (interactive (list buffer-file-name))
- (setq backend (or backend (vc-backend file)))
- (if (not backend)
- (setq vc-mode nil)
- (let* ((ml-string (vc-call-backend backend 'mode-line-string file))
- (ml-echo (get-text-property 0 'help-echo ml-string)))
- (setq vc-mode
- (concat
- " "
- (if (null vc-display-status)
- (symbol-name backend)
- (propertize
- ml-string
- 'mouse-face 'mode-line-highlight
- 'help-echo
- (concat (or ml-echo
- (format "File under the %s version control system"
- backend))
- "\nmouse-1: Version Control menu")
- 'local-map vc-mode-line-map)))))
- ;; If the user is root, and the file is not owner-writable,
- ;; then pretend that we can't write it
- ;; even though we can (because root can write anything).
- ;; This way, even root cannot modify a file that isn't locked.
- (and (equal file buffer-file-name)
- (not buffer-read-only)
- (zerop (user-real-uid))
- (zerop (logand (file-modes buffer-file-name) 128))
- (setq buffer-read-only t)))
- (force-mode-line-update)
- backend)
-
-(defun vc-default-mode-line-string (backend file)
- "Return string for placement in modeline by `vc-mode-line' for FILE.
-Format:
-
- \"BACKEND-REV\" if the file is up-to-date
- \"BACKEND:REV\" if the file is edited (or locked by the calling user)
- \"BACKEND:LOCKER:REV\" if the file is locked by somebody else
-
-This function assumes that the file is registered."
- (let* ((backend-name (symbol-name backend))
- (state (vc-state file backend))
- (state-echo nil)
- (rev (vc-working-revision file backend)))
- (propertize
- (cond ((or (eq state 'up-to-date)
- (eq state 'needs-update))
- (setq state-echo "Up to date file")
- (concat backend-name "-" rev))
- ((stringp state)
- (setq state-echo (concat "File locked by" state))
- (concat backend-name ":" state ":" rev))
- ((eq state 'added)
- (setq state-echo "Locally added file")
- (concat backend-name "@" rev))
- ((eq state 'conflict)
- (setq state-echo "File contains conflicts after the last merge")
- (concat backend-name "!" rev))
- ((eq state 'removed)
- (setq state-echo "File removed from the VC system")
- (concat backend-name "!" rev))
- ((eq state 'missing)
- (setq state-echo "File tracked by the VC system, but missing from the file system")
- (concat backend-name "?" rev))
- (t
- ;; Not just for the 'edited state, but also a fallback
- ;; for all other states. Think about different symbols
- ;; for 'needs-update and 'needs-merge.
- (setq state-echo "Locally modified file")
- (concat backend-name ":" rev)))
- 'help-echo (concat state-echo " under the " backend-name
- " version control system"))))
-
-(defun vc-follow-link ()
- "If current buffer visits a symbolic link, visit the real file.
-If the real file is already visited in another buffer, make that buffer
-current, and kill the buffer that visits the link."
- (let* ((true-buffer (find-buffer-visiting buffer-file-truename))
- (this-buffer (current-buffer)))
- (if (eq true-buffer this-buffer)
- (let ((truename buffer-file-truename))
- (kill-buffer this-buffer)
- ;; In principle, we could do something like set-visited-file-name.
- ;; However, it can't be exactly the same as set-visited-file-name.
- ;; I'm not going to work out the details right now. -- rms.
- (set-buffer (find-file-noselect truename)))
- (set-buffer true-buffer)
- (kill-buffer this-buffer))))
-
-(defun vc-default-find-file-hook (backend)
- nil)
-
-(defun vc-find-file-hook ()
- "Function for `find-file-hook' activating VC mode if appropriate."
- ;; Recompute whether file is version controlled,
- ;; if user has killed the buffer and revisited.
- (when vc-mode
- (setq vc-mode nil))
- (when buffer-file-name
- (vc-file-clearprops buffer-file-name)
- ;; FIXME: Why use a hook? Why pass it buffer-file-name?
- (add-hook 'vc-mode-line-hook 'vc-mode-line nil t)
- (let (backend)
- (cond
- ((setq backend (with-demoted-errors (vc-backend buffer-file-name)))
- ;; Compute the state and put it in the modeline.
- (vc-mode-line buffer-file-name backend)
- (unless vc-make-backup-files
- ;; Use this variable, not make-backup-files,
- ;; because this is for things that depend on the file name.
- (set (make-local-variable 'backup-inhibited) t))
- ;; Let the backend setup any buffer-local things he needs.
- (vc-call-backend backend 'find-file-hook))
- ((let ((link-type (and (not (equal buffer-file-name buffer-file-truename))
- (vc-backend buffer-file-truename))))
- (cond ((not link-type) nil) ;Nothing to do.
- ((eq vc-follow-symlinks nil)
- (message
- "Warning: symbolic link to %s-controlled source file" link-type))
- ((or (not (eq vc-follow-symlinks 'ask))
- ;; If we already visited this file by following
- ;; the link, don't ask again if we try to visit
- ;; it again. GUD does that, and repeated questions
- ;; are painful.
- (get-file-buffer
- (abbreviate-file-name
- (file-chase-links buffer-file-name))))
-
- (vc-follow-link)
- (message "Followed link to %s" buffer-file-name)
- (vc-find-file-hook))
- (t
- (if (yes-or-no-p (format
- "Symbolic link to %s-controlled source file; follow link? " link-type))
- (progn (vc-follow-link)
- (message "Followed link to %s" buffer-file-name)
- (vc-find-file-hook))
- (message
- "Warning: editing through the link bypasses version control")
- )))))))))
-
-(add-hook 'find-file-hook 'vc-find-file-hook)
-
-(defun vc-kill-buffer-hook ()
- "Discard VC info about a file when we kill its buffer."
- (when buffer-file-name (vc-file-clearprops buffer-file-name)))
-
-(add-hook 'kill-buffer-hook 'vc-kill-buffer-hook)
-
-;; Now arrange for (autoloaded) bindings of the main package.
-;; Bindings for this have to go in the global map, as we'll often
-;; want to call them from random buffers.
-
-;; Autoloading works fine, but it prevents shortcuts from appearing
-;; in the menu because they don't exist yet when the menu is built.
-;; (autoload 'vc-prefix-map "vc" nil nil 'keymap)
-(defvar vc-prefix-map
- (let ((map (make-sparse-keymap)))
- (define-key map "a" 'vc-update-change-log)
- (define-key map "b" 'vc-switch-backend)
- (define-key map "c" 'vc-rollback)
- (define-key map "d" 'vc-dir)
- (define-key map "g" 'vc-annotate)
- (define-key map "h" 'vc-insert-headers)
- (define-key map "i" 'vc-register)
- (define-key map "l" 'vc-print-log)
- (define-key map "L" 'vc-print-root-log)
- (define-key map "I" 'vc-log-incoming)
- (define-key map "O" 'vc-log-outgoing)
- (define-key map "m" 'vc-merge)
- (define-key map "r" 'vc-retrieve-tag)
- (define-key map "s" 'vc-create-tag)
- (define-key map "u" 'vc-revert)
- (define-key map "v" 'vc-next-action)
- (define-key map "+" 'vc-update)
- (define-key map "=" 'vc-diff)
- (define-key map "D" 'vc-root-diff)
- (define-key map "~" 'vc-revision-other-window)
- map))
-(fset 'vc-prefix-map vc-prefix-map)
-(define-key global-map "\C-xv" 'vc-prefix-map)
-
-(defvar vc-menu-map
- (let ((map (make-sparse-keymap "Version Control")))
- ;;(define-key map [show-files]
- ;; '("Show Files under VC" . (vc-directory t)))
- (define-key map [vc-retrieve-tag]
- `(menu-item ,(purecopy "Retrieve Tag") vc-retrieve-tag
- :help ,(purecopy "Retrieve tagged version or branch")))
- (define-key map [vc-create-tag]
- `(menu-item ,(purecopy "Create Tag") vc-create-tag
- :help ,(purecopy "Create version tag")))
- (define-key map [separator1] menu-bar-separator)
- (define-key map [vc-annotate]
- `(menu-item ,(purecopy "Annotate") vc-annotate
- :help ,(purecopy "Display the edit history of the current file using colors")))
- (define-key map [vc-rename-file]
- `(menu-item ,(purecopy "Rename File") vc-rename-file
- :help ,(purecopy "Rename file")))
- (define-key map [vc-revision-other-window]
- `(menu-item ,(purecopy "Show Other Version") vc-revision-other-window
- :help ,(purecopy "Visit another version of the current file in another window")))
- (define-key map [vc-diff]
- `(menu-item ,(purecopy "Compare with Base Version") vc-diff
- :help ,(purecopy "Compare file set with the base version")))
- (define-key map [vc-root-diff]
- `(menu-item ,(purecopy "Compare Tree with Base Version") vc-root-diff
- :help ,(purecopy "Compare current tree with the base version")))
- (define-key map [vc-update-change-log]
- `(menu-item ,(purecopy "Update ChangeLog") vc-update-change-log
- :help ,(purecopy "Find change log file and add entries from recent version control logs")))
- (define-key map [vc-log-out]
- `(menu-item ,(purecopy "Show Outgoing Log") vc-log-outgoing
- :help ,(purecopy "Show a log of changes that will be sent with a push operation")))
- (define-key map [vc-log-in]
- `(menu-item ,(purecopy "Show Incoming Log") vc-log-incoming
- :help ,(purecopy "Show a log of changes that will be received with a pull operation")))
- (define-key map [vc-print-log]
- `(menu-item ,(purecopy "Show History") vc-print-log
- :help ,(purecopy "List the change log of the current file set in a window")))
- (define-key map [vc-print-root-log]
- `(menu-item ,(purecopy "Show Top of the Tree History ") vc-print-root-log
- :help ,(purecopy "List the change log for the current tree in a window")))
- (define-key map [separator2] menu-bar-separator)
- (define-key map [vc-insert-header]
- `(menu-item ,(purecopy "Insert Header") vc-insert-headers
- :help ,(purecopy "Insert headers into a file for use with a version control system.
-")))
- (define-key map [undo]
- `(menu-item ,(purecopy "Undo Last Check-In") vc-rollback
- :help ,(purecopy "Remove the most recent changeset committed to the repository")))
- (define-key map [vc-revert]
- `(menu-item ,(purecopy "Revert to Base Version") vc-revert
- :help ,(purecopy "Revert working copies of the selected file set to their repository contents")))
- (define-key map [vc-update]
- `(menu-item ,(purecopy "Update to Latest Version") vc-update
- :help ,(purecopy "Update the current fileset's files to their tip revisions")))
- (define-key map [vc-next-action]
- `(menu-item ,(purecopy "Check In/Out") vc-next-action
- :help ,(purecopy "Do the next logical version control operation on the current fileset")))
- (define-key map [vc-register]
- `(menu-item ,(purecopy "Register") vc-register
- :help ,(purecopy "Register file set into a version control system")))
- (define-key map [vc-dir]
- `(menu-item ,(purecopy "VC Dir") vc-dir
- :help ,(purecopy "Show the VC status of files in a directory")))
- map))
-
-(defalias 'vc-menu-map vc-menu-map)
-
-(declare-function vc-responsible-backend "vc" (file))
-
-(defun vc-menu-map-filter (orig-binding)
- (if (and (symbolp orig-binding) (fboundp orig-binding))
- (setq orig-binding (indirect-function orig-binding)))
- (let ((ext-binding
- (when vc-mode
- (vc-call-backend
- (if buffer-file-name
- (vc-backend buffer-file-name)
- (vc-responsible-backend default-directory))
- 'extra-menu))))
- ;; Give the VC backend a chance to add menu entries
- ;; specific for that backend.
- (if (null ext-binding)
- orig-binding
- (append orig-binding
- '((ext-menu-separator "--"))
- ext-binding))))
-
-(defun vc-default-extra-menu (backend)
- nil)
-
-(provide 'vc-hooks)
-
-;; arch-tag: 2e5a6fa7-1d30-48e2-8bd0-e3d335f04f32
-;;; vc-hooks.el ends here
+++ /dev/null
-;;; vc-mtn.el --- VC backend for Monotone
-
-;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords:
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;
-
-;;; TODO:
-
-;; - The `previous-version' VC method needs to be supported, 'D' in
-;; log-view-mode uses it.
-
-;;; Code:
-
-(eval-when-compile (require 'cl) (require 'vc))
-
-(defcustom vc-mtn-diff-switches t
- "String or list of strings specifying switches for monotone diff under VC.
-If nil, use the value of `vc-diff-switches'. If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "23.1"
- :group 'vc)
-
-(define-obsolete-variable-alias 'vc-mtn-command 'vc-mtn-program "23.1")
-(defcustom vc-mtn-program "mtn"
- "Name of the monotone executable."
- :type 'string
- :group 'vc)
-
-;; Clear up the cache to force vc-call to check again and discover
-;; new functions when we reload this file.
-(put 'Mtn 'vc-functions nil)
-
-(unless (executable-find vc-mtn-program)
- ;; vc-mtn.el is 100% non-functional without the `mtn' executable.
- (setq vc-handled-backends (delq 'Mtn vc-handled-backends)))
-
-;;;###autoload
-(defconst vc-mtn-admin-dir "_MTN")
-;;;###autoload
-(defconst vc-mtn-admin-format (concat vc-mtn-admin-dir "/format"))
-
-;;;###autoload (defun vc-mtn-registered (file)
-;;;###autoload (if (vc-find-root file vc-mtn-admin-format)
-;;;###autoload (progn
-;;;###autoload (load "vc-mtn")
-;;;###autoload (vc-mtn-registered file))))
-
-(defun vc-mtn-revision-granularity () 'repository)
-(defun vc-mtn-checkout-model (files) 'implicit)
-
-(defun vc-mtn-root (file)
- (setq file (if (file-directory-p file)
- (file-name-as-directory file)
- (file-name-directory file)))
- (or (vc-file-getprop file 'vc-mtn-root)
- (vc-file-setprop file 'vc-mtn-root
- (vc-find-root file vc-mtn-admin-format))))
-
-
-(defun vc-mtn-registered (file)
- (let ((root (vc-mtn-root file)))
- (when root
- (vc-mtn-state file))))
-
-(defun vc-mtn-command (buffer okstatus files &rest flags)
- "A wrapper around `vc-do-command' for use in vc-mtn.el."
- (let ((process-environment
- ;; Avoid localization of messages so we can parse the output.
- (cons "LC_MESSAGES=C" process-environment)))
- (apply 'vc-do-command (or buffer "*vc*") okstatus vc-mtn-program
- files flags)))
-
-(defun vc-mtn-state (file)
- ;; If `mtn' fails or returns status>0, or if the search files, just
- ;; return nil.
- (ignore-errors
- (with-temp-buffer
- (vc-mtn-command t 0 file "status")
- (goto-char (point-min))
- (re-search-forward
- "^ \\(?:\\(patched\\)\\|\\(added\\) \\(?:.*\\)\\)\\|no changes$")
- (cond ((match-end 1) 'edited)
- ((match-end 2) 'added)
- (t 'up-to-date)))))
-
-(defun vc-mtn-after-dir-status (update-function)
- (let (result)
- (goto-char (point-min))
- (re-search-forward "Current branch: \\(.*\\)\nChanges against parent \\(.*\\)" nil t)
- (while (re-search-forward
- "^ \\(?:\\(patched \\)\\|\\(added \\)\\)\\(.*\\)$" nil t)
- (cond ((match-end 1) (push (list (match-string 3) 'edited) result))
- ((match-end 2) (push (list (match-string 3) 'added) result))))
- (funcall update-function result)))
-
-(defun vc-mtn-dir-status (dir update-function)
- (vc-mtn-command (current-buffer) 'async dir "status")
- (vc-exec-after
- `(vc-mtn-after-dir-status (quote ,update-function))))
-
-(defun vc-mtn-working-revision (file)
- ;; If `mtn' fails or returns status>0, or if the search fails, just
- ;; return nil.
- (ignore-errors
- (with-temp-buffer
- (vc-mtn-command t 0 file "status")
- (goto-char (point-min))
- (re-search-forward "Current branch: \\(.*\\)\nChanges against parent \\(.*\\)")
- (match-string 2))))
-
-(defun vc-mtn-workfile-branch (file)
- ;; If `mtn' fails or returns status>0, or if the search files, just
- ;; return nil.
- (ignore-errors
- (with-temp-buffer
- (vc-mtn-command t 0 file "status")
- (goto-char (point-min))
- (re-search-forward "Current branch: \\(.*\\)\nChanges against parent \\(.*\\)")
- (match-string 1))))
-
-(defun vc-mtn-workfile-unchanged-p (file)
- (not (eq (vc-mtn-state file) 'edited)))
-
-;; Mode-line rewrite code copied from vc-arch.el.
-
-(defcustom vc-mtn-mode-line-rewrite
- '(("\\`[^:/#]*[:/#]" . "")) ;Drop the host part.
- "Rewrite rules to shorten Mtn's revision names on the mode-line."
- :type '(repeat (cons regexp string))
- :version "22.2"
- :group 'vc)
-
-(defun vc-mtn-mode-line-string (file)
- "Return string for placement in modeline by `vc-mode-line' for FILE."
- (let ((branch (vc-mtn-workfile-branch file)))
- (dolist (rule vc-mtn-mode-line-rewrite)
- (if (string-match (car rule) branch)
- (setq branch (replace-match (cdr rule) t nil branch))))
- (format "Mtn%c%s"
- (case (vc-state file)
- ((up-to-date needs-update) ?-)
- (added ?@)
- (t ?:))
- branch)))
-
-(defun vc-mtn-register (files &optional rev comment)
- (vc-mtn-command nil 0 files "add"))
-
-(defun vc-mtn-responsible-p (file) (vc-mtn-root file))
-(defun vc-mtn-could-register (file) (vc-mtn-root file))
-
-(declare-function log-edit-extract-headers "log-edit" (headers string))
-
-(defun vc-mtn-checkin (files rev comment &optional extra-args-ignored)
- (apply 'vc-mtn-command nil 0 files
- (nconc (list "commit" "-m")
- (log-edit-extract-headers '(("Author" . "--author")
- ("Date" . "--date"))
- comment))))
-
-(defun vc-mtn-find-revision (file rev buffer)
- (vc-mtn-command buffer 0 file "cat" "-r" rev))
-
-;; (defun vc-mtn-checkout (file &optional editable rev)
-;; )
-
-(defun vc-mtn-revert (file &optional contents-done)
- (unless contents-done
- (vc-mtn-command nil 0 file "revert")))
-
-;; (defun vc-mtn-roolback (files)
-;; )
-
-(defun vc-mtn-print-log (files buffer &optional shortlog start-revision limit)
- (apply 'vc-mtn-command buffer 0 files "log"
- (append
- (when start-revision (list "--from" (format "%s" start-revision)))
- (when limit (list "--last" (format "%s" limit))))))
-
-(defvar log-view-message-re)
-(defvar log-view-file-re)
-(defvar log-view-font-lock-keywords)
-(defvar log-view-per-file-logs)
-
-(define-derived-mode vc-mtn-log-view-mode log-view-mode "Mtn-Log-View"
- ;; Don't match anything.
- (set (make-local-variable 'log-view-file-re) "\\`a\\`")
- (set (make-local-variable 'log-view-per-file-logs) nil)
- ;; TODO: Use a more precise regexp than "[ |/]+" to avoid false positives
- ;; in the ChangeLog text.
- (set (make-local-variable 'log-view-message-re)
- "^[ |/]+Revision: \\([0-9a-f]+\\)")
- (require 'add-log) ;For change-log faces.
- (set (make-local-variable 'log-view-font-lock-keywords)
- (append log-view-font-lock-keywords
- '(("^[ |]+Author: \\(.*\\)" (1 'change-log-email))
- ("^[ |]+Date: \\(.*\\)" (1 'change-log-date-face))))))
-
-;; (defun vc-mtn-show-log-entry (revision)
-;; )
-
-(defun vc-mtn-diff (files &optional rev1 rev2 buffer)
- "Get a difference report using monotone between two revisions of FILES."
- (apply 'vc-mtn-command (or buffer "*vc-diff*") 1 files "diff"
- (append
- (vc-switches 'mtn 'diff)
- (if rev1 (list "-r" rev1)) (if rev2 (list "-r" rev2)))))
-
-(defun vc-mtn-annotate-command (file buf &optional rev)
- (apply 'vc-mtn-command buf 'async file "annotate"
- (if rev (list "-r" rev))))
-
-(declare-function vc-annotate-convert-time "vc-annotate" (time))
-
-(defconst vc-mtn-annotate-full-re
- "^ *\\([0-9a-f]+\\)\\.* by [^ ]+ \\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\): ")
-(defconst vc-mtn-annotate-any-re
- (concat "^\\(?: +: \\|" vc-mtn-annotate-full-re "\\)"))
-
-(defun vc-mtn-annotate-time ()
- (when (looking-at vc-mtn-annotate-any-re)
- (goto-char (match-end 0))
- (let ((year (match-string 2)))
- (if (not year)
- ;; Look for the date on a previous line.
- (save-excursion
- (get-text-property (1- (previous-single-property-change
- (point) 'vc-mtn-time nil (point-min)))
- 'vc-mtn-time))
- (let ((time (vc-annotate-convert-time
- (encode-time 0 0 0
- (string-to-number (match-string 4))
- (string-to-number (match-string 3))
- (string-to-number year)
- t))))
- (let ((inhibit-read-only t)
- (inhibit-modification-hooks t))
- (put-text-property (match-beginning 0) (match-end 0)
- 'vc-mtn-time time))
- time)))))
-
-(defun vc-mtn-annotate-extract-revision-at-line ()
- (save-excursion
- (when (or (looking-at vc-mtn-annotate-full-re)
- (re-search-backward vc-mtn-annotate-full-re nil t))
- (match-string 1))))
-
-;;; Revision completion.
-
-(defun vc-mtn-list-tags ()
- (with-temp-buffer
- (vc-mtn-command t 0 nil "list" "tags")
- (goto-char (point-min))
- (let ((tags ()))
- (while (re-search-forward "^[^ ]+" nil t)
- (push (match-string 0) tags))
- tags)))
-
-(defun vc-mtn-list-branches ()
- (with-temp-buffer
- (vc-mtn-command t 0 nil "list" "branches")
- (goto-char (point-min))
- (let ((branches ()))
- (while (re-search-forward "^.+" nil t)
- (push (match-string 0) branches))
- branches)))
-
-(defun vc-mtn-list-revision-ids (prefix)
- (with-temp-buffer
- (vc-mtn-command t 0 nil "complete" "revision" prefix)
- (goto-char (point-min))
- (let ((ids ()))
- (while (re-search-forward "^.+" nil t)
- (push (match-string 0) ids))
- ids)))
-
-(defun vc-mtn-revision-completion-table (files)
- ;; TODO: Implement completion for for selectors
- ;; TODO: Implement completion for composite selectors.
- (lexical-let ((files files))
- ;; What about using `files'?!? --Stef
- (lambda (string pred action)
- (cond
- ;; "Tag" selectors.
- ((string-match "\\`t:" string)
- (complete-with-action action
- (mapcar (lambda (tag) (concat "t:" tag))
- (vc-mtn-list-tags))
- string pred))
- ;; "Branch" selectors.
- ((string-match "\\`b:" string)
- (complete-with-action action
- (mapcar (lambda (tag) (concat "b:" tag))
- (vc-mtn-list-branches))
- string pred))
- ;; "Head" selectors. Not sure how they differ from "branch" selectors.
- ((string-match "\\`h:" string)
- (complete-with-action action
- (mapcar (lambda (tag) (concat "h:" tag))
- (vc-mtn-list-branches))
- string pred))
- ;; "ID" selectors.
- ((string-match "\\`i:" string)
- (complete-with-action action
- (mapcar (lambda (tag) (concat "i:" tag))
- (vc-mtn-list-revision-ids
- (substring string (match-end 0))))
- string pred))
- (t
- (complete-with-action action
- '("t:" "b:" "h:" "i:"
- ;; Completion not implemented for these.
- "a:" "c:" "d:" "e:" "l:")
- string pred))))))
-
-
-
-(provide 'vc-mtn)
-
-;; arch-tag: 2b89ffbc-cbb8-405a-9080-2eafd4becb70
-;;; vc-mtn.el ends here
+++ /dev/null
-;;; vc-rcs.el --- support for RCS version-control
-
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Author: FSF (see vc.el for full credits)
-;; Maintainer: Andre Spiegel <spiegel@gnu.org>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; See vc.el
-
-;; Some features will not work with old RCS versions. Where
-;; appropriate, VC finds out which version you have, and allows or
-;; disallows those features (stealing locks, for example, works only
-;; from 5.6.2 onwards).
-;; Even initial checkins will fail if your RCS version is so old that ci
-;; doesn't understand -t-; this has been known to happen to people running
-;; NExTSTEP 3.0.
-;;
-;; You can support the RCS -x option by customizing vc-rcs-master-templates.
-
-;;; Code:
-
-;;;
-;;; Customization options
-;;;
-
-(eval-when-compile
- (require 'cl)
- (require 'vc))
-
-(defcustom vc-rcs-release nil
- "The release number of your RCS installation, as a string.
-If nil, VC itself computes this value when it is first needed."
- :type '(choice (const :tag "Auto" nil)
- (string :tag "Specified")
- (const :tag "Unknown" unknown))
- :group 'vc)
-
-(defcustom vc-rcs-register-switches nil
- "Switches for registering a file in RCS.
-A string or list of strings passed to the checkin program by
-\\[vc-register]. If nil, use the value of `vc-register-switches'.
-If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc)
-
-(defcustom vc-rcs-diff-switches nil
- "String or list of strings specifying switches for RCS diff under VC.
-If nil, use the value of `vc-diff-switches'. If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc)
-
-(defcustom vc-rcs-header (or (cdr (assoc 'RCS vc-header-alist)) '("\$Id\$"))
- "Header keywords to be inserted by `vc-insert-headers'."
- :type '(repeat string)
- :version "21.1"
- :group 'vc)
-
-(defcustom vc-rcsdiff-knows-brief nil
- "Indicates whether rcsdiff understands the --brief option.
-The value is either `yes', `no', or nil. If it is nil, VC tries
-to use --brief and sets this variable to remember whether it worked."
- :type '(choice (const :tag "Work out" nil) (const yes) (const no))
- :group 'vc)
-
-;;;###autoload
-(defcustom vc-rcs-master-templates
- (purecopy '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s"))
- "Where to look for RCS master files.
-For a description of possible values, see `vc-check-master-templates'."
- :type '(choice (const :tag "Use standard RCS file names"
- '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s"))
- (repeat :tag "User-specified"
- (choice string
- function)))
- :version "21.1"
- :group 'vc)
-
-\f
-;;; Properties of the backend
-
-(defun vc-rcs-revision-granularity () 'file)
-
-(defun vc-rcs-checkout-model (files)
- "RCS-specific version of `vc-checkout-model'."
- (let ((file (if (consp files) (car files) files))
- result)
- (when vc-consult-headers
- (vc-file-setprop file 'vc-checkout-model nil)
- (vc-rcs-consult-headers file)
- (setq result (vc-file-getprop file 'vc-checkout-model)))
- (or result
- (progn (vc-rcs-fetch-master-state file)
- (vc-file-getprop file 'vc-checkout-model)))))
-
-;;;
-;;; State-querying functions
-;;;
-
-;; The autoload cookie below places vc-rcs-registered directly into
-;; loaddefs.el, so that vc-rcs.el does not need to be loaded for
-;; every file that is visited.
-;;;###autoload
-(progn
-(defun vc-rcs-registered (f) (vc-default-registered 'RCS f)))
-
-(defun vc-rcs-state (file)
- "Implementation of `vc-state' for RCS."
- (if (not (vc-rcs-registered file))
- 'unregistered
- (or (boundp 'vc-rcs-headers-result)
- (and vc-consult-headers
- (vc-rcs-consult-headers file)))
- (let ((state
- ;; vc-working-revision might not be known; in that case the
- ;; property is nil. vc-rcs-fetch-master-state knows how to
- ;; handle that.
- (vc-rcs-fetch-master-state file
- (vc-file-getprop file
- 'vc-working-revision))))
- (if (not (eq state 'up-to-date))
- state
- (if (vc-workfile-unchanged-p file)
- 'up-to-date
- (if (eq (vc-rcs-checkout-model (list file)) 'locking)
- 'unlocked-changes
- 'edited))))))
-
-(defun vc-rcs-state-heuristic (file)
- "State heuristic for RCS."
- (let (vc-rcs-headers-result)
- (if (and vc-consult-headers
- (setq vc-rcs-headers-result
- (vc-rcs-consult-headers file))
- (eq vc-rcs-headers-result 'rev-and-lock))
- (let ((state (vc-file-getprop file 'vc-state)))
- ;; If the headers say that the file is not locked, the
- ;; permissions can tell us whether locking is used for
- ;; the file or not.
- (if (and (eq state 'up-to-date)
- (not (vc-mistrust-permissions file))
- (file-exists-p file))
- (cond
- ((string-match ".rw..-..-." (nth 8 (file-attributes file)))
- (vc-file-setprop file 'vc-checkout-model 'implicit)
- (setq state
- (if (vc-rcs-workfile-is-newer file)
- 'edited
- 'up-to-date)))
- ((string-match ".r-..-..-." (nth 8 (file-attributes file)))
- (vc-file-setprop file 'vc-checkout-model 'locking))))
- state)
- (if (not (vc-mistrust-permissions file))
- (let* ((attributes (file-attributes file 'string))
- (owner-name (nth 2 attributes))
- (permissions (nth 8 attributes)))
- (cond ((and permissions (string-match ".r-..-..-." permissions))
- (vc-file-setprop file 'vc-checkout-model 'locking)
- 'up-to-date)
- ((and permissions (string-match ".rw..-..-." permissions))
- (if (eq (vc-rcs-checkout-model file) 'locking)
- (if (file-ownership-preserved-p file)
- 'edited
- owner-name)
- (if (vc-rcs-workfile-is-newer file)
- 'edited
- 'up-to-date)))
- (t
- ;; Strange permissions. Fall through to
- ;; expensive state computation.
- (vc-rcs-state file))))
- (vc-rcs-state file)))))
-
-(defun vc-rcs-dir-status (dir update-function)
- ;; FIXME: this function should be rewritten or `vc-expand-dirs'
- ;; should be changed to take a backend parameter. Using
- ;; `vc-expand-dirs' is not TRTD because it returns files from
- ;; multiple backends. It should also return 'unregistered files.
-
- ;; Doing individual vc-state calls is painful but there
- ;; is no better way in RCS-land.
- (let ((flist (vc-expand-dirs (list dir)))
- (result nil))
- (dolist (file flist)
- (let ((state (vc-state file))
- (frel (file-relative-name file)))
- (when (and (eq (vc-backend file) 'RCS)
- (not (eq state 'up-to-date)))
- (push (list frel state) result))))
- (funcall update-function result)))
-
-(defun vc-rcs-working-revision (file)
- "RCS-specific version of `vc-working-revision'."
- (or (and vc-consult-headers
- (vc-rcs-consult-headers file)
- (vc-file-getprop file 'vc-working-revision))
- (progn
- (vc-rcs-fetch-master-state file)
- (vc-file-getprop file 'vc-working-revision))))
-
-(defun vc-rcs-latest-on-branch-p (file &optional version)
- "Return non-nil if workfile version of FILE is the latest on its branch.
-When VERSION is given, perform check for that version."
- (unless version (setq version (vc-working-revision file)))
- (with-temp-buffer
- (string= version
- (if (vc-rcs-trunk-p version)
- (progn
- ;; Compare VERSION to the head version number.
- (vc-insert-file (vc-name file) "^[0-9]")
- (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
- ;; If we are not on the trunk, we need to examine the
- ;; whole current branch.
- (vc-insert-file (vc-name file) "^desc")
- (vc-rcs-find-most-recent-rev (vc-branch-part version))))))
-
-(defun vc-rcs-workfile-unchanged-p (file)
- "RCS-specific implementation of `vc-workfile-unchanged-p'."
- ;; Try to use rcsdiff --brief. If rcsdiff does not understand that,
- ;; do a double take and remember the fact for the future
- (let* ((version (concat "-r" (vc-working-revision file)))
- (status (if (eq vc-rcsdiff-knows-brief 'no)
- (vc-do-command "*vc*" 1 "rcsdiff" file version)
- (vc-do-command "*vc*" 2 "rcsdiff" file "--brief" version))))
- (if (eq status 2)
- (if (not vc-rcsdiff-knows-brief)
- (setq vc-rcsdiff-knows-brief 'no
- status (vc-do-command "*vc*" 1 "rcsdiff" file version))
- (error "rcsdiff failed"))
- (if (not vc-rcsdiff-knows-brief) (setq vc-rcsdiff-knows-brief 'yes)))
- ;; The workfile is unchanged if rcsdiff found no differences.
- (zerop status)))
-
-\f
-;;;
-;;; State-changing functions
-;;;
-
-(defun vc-rcs-create-repo ()
- "Create a new RCS repository."
- ;; RCS is totally file-oriented, so all we have to do is make the directory.
- (make-directory "RCS"))
-
-(defun vc-rcs-register (files &optional rev comment)
- "Register FILES into the RCS version-control system.
-REV is the optional revision number for the files. COMMENT can be used
-to provide an initial description for each FILES.
-Passes either `vc-rcs-register-switches' or `vc-register-switches'
-to the RCS command.
-
-Automatically retrieve a read-only version of the file with keywords
-expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
- (let (subdir name)
- ;; When REV is specified, we need to force using "-t-".
- (when rev (unless comment (setq comment "")))
- (dolist (file files)
- (and (not (file-exists-p
- (setq subdir (expand-file-name "RCS"
- (file-name-directory file)))))
- (not (directory-files (file-name-directory file)
- nil ".*,v$" t))
- (yes-or-no-p "Create RCS subdirectory? ")
- (make-directory subdir))
- (apply 'vc-do-command "*vc*" 0 "ci" file
- ;; if available, use the secure registering option
- (and (vc-rcs-release-p "5.6.4") "-i")
- (concat (if vc-keep-workfiles "-u" "-r") rev)
- (and comment (concat "-t-" comment))
- (vc-switches 'RCS 'register))
- ;; parse output to find master file name and workfile version
- (with-current-buffer "*vc*"
- (goto-char (point-min))
- (if (not (setq name
- (if (looking-at (concat "^\\(.*\\) <-- "
- (file-name-nondirectory file)))
- (match-string 1))))
- ;; if we couldn't find the master name,
- ;; run vc-rcs-registered to get it
- ;; (will be stored into the vc-name property)
- (vc-rcs-registered file)
- (vc-file-setprop file 'vc-name
- (if (file-name-absolute-p name)
- name
- (expand-file-name
- name
- (file-name-directory file))))))
- (vc-file-setprop file 'vc-working-revision
- (if (re-search-forward
- "^initial revision: \\([0-9.]+\\).*\n"
- nil t)
- (match-string 1))))))
-
-(defun vc-rcs-responsible-p (file)
- "Return non-nil if RCS thinks it would be responsible for registering FILE."
- ;; TODO: check for all the patterns in vc-rcs-master-templates
- (file-directory-p (expand-file-name "RCS" (file-name-directory file))))
-
-(defun vc-rcs-receive-file (file rev)
- "Implementation of receive-file for RCS."
- (let ((checkout-model (vc-rcs-checkout-model (list file))))
- (vc-rcs-register file rev "")
- (when (eq checkout-model 'implicit)
- (vc-rcs-set-non-strict-locking file))
- (vc-rcs-set-default-branch file (concat rev ".1"))))
-
-(defun vc-rcs-unregister (file)
- "Unregister FILE from RCS.
-If this leaves the RCS subdirectory empty, ask the user
-whether to remove it."
- (let* ((master (vc-name file))
- (dir (file-name-directory master))
- (backup-info (find-backup-file-name master)))
- (if (not backup-info)
- (delete-file master)
- (rename-file master (car backup-info) 'ok-if-already-exists)
- (dolist (f (cdr backup-info)) (ignore-errors (delete-file f))))
- (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS")
- ;; check whether RCS dir is empty, i.e. it does not
- ;; contain any files except "." and ".."
- (not (directory-files dir nil
- "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*"))
- (yes-or-no-p (format "Directory %s is empty; remove it? " dir))
- (delete-directory dir))))
-
-(defun vc-rcs-checkin (files rev comment &optional extra-args-ignored)
- "RCS-specific version of `vc-backend-checkin'."
- (let ((switches (vc-switches 'RCS 'checkin)))
- ;; Now operate on the files
- (dolist (file (vc-expand-dirs files))
- (let ((old-version (vc-working-revision file)) new-version
- (default-branch (vc-file-getprop file 'vc-rcs-default-branch)))
- ;; Force branch creation if an appropriate
- ;; default branch has been set.
- (and (not rev)
- default-branch
- (string-match (concat "^" (regexp-quote old-version) "\\.")
- default-branch)
- (setq rev default-branch)
- (setq switches (cons "-f" switches)))
- (if (and (not rev) old-version)
- (setq rev (vc-branch-part old-version)))
- (apply 'vc-do-command "*vc*" 0 "ci" (vc-name file)
- ;; if available, use the secure check-in option
- (and (vc-rcs-release-p "5.6.4") "-j")
- (concat (if vc-keep-workfiles "-u" "-r") rev)
- (concat "-m" comment)
- switches)
- (vc-file-setprop file 'vc-working-revision nil)
-
- ;; determine the new workfile version
- (set-buffer "*vc*")
- (goto-char (point-min))
- (when (or (re-search-forward
- "new revision: \\([0-9.]+\\);" nil t)
- (re-search-forward
- "reverting to previous revision \\([0-9.]+\\)" nil t))
- (setq new-version (match-string 1))
- (vc-file-setprop file 'vc-working-revision new-version))
-
- ;; if we got to a different branch, adjust the default
- ;; branch accordingly
- (cond
- ((and old-version new-version
- (not (string= (vc-branch-part old-version)
- (vc-branch-part new-version))))
- (vc-rcs-set-default-branch file
- (if (vc-rcs-trunk-p new-version) nil
- (vc-branch-part new-version)))
- ;; If this is an old RCS release, we might have
- ;; to remove a remaining lock.
- (if (not (vc-rcs-release-p "5.6.2"))
- ;; exit status of 1 is also accepted.
- ;; It means that the lock was removed before.
- (vc-do-command "*vc*" 1 "rcs" (vc-name file)
- (concat "-u" old-version)))))))))
-
-(defun vc-rcs-find-revision (file rev buffer)
- (apply 'vc-do-command
- (or buffer "*vc*") 0 "co" (vc-name file)
- "-q" ;; suppress diagnostic output
- (concat "-p" rev)
- (vc-switches 'RCS 'checkout)))
-
-(defun vc-rcs-checkout (file &optional editable rev)
- "Retrieve a copy of a saved version of FILE. If FILE is a directory,
-attempt the checkout for all registered files beneath it."
- (if (file-directory-p file)
- (mapc 'vc-rcs-checkout (vc-expand-dirs (list file)))
- (let ((file-buffer (get-file-buffer file))
- switches)
- (message "Checking out %s..." file)
- (save-excursion
- ;; Change buffers to get local value of vc-checkout-switches.
- (if file-buffer (set-buffer file-buffer))
- (setq switches (vc-switches 'RCS 'checkout))
- ;; Save this buffer's default-directory
- ;; and use save-excursion to make sure it is restored
- ;; in the same buffer it was saved in.
- (let ((default-directory default-directory))
- (save-excursion
- ;; Adjust the default-directory so that the check-out creates
- ;; the file in the right place.
- (setq default-directory (file-name-directory file))
- (let (new-version)
- ;; if we should go to the head of the trunk,
- ;; clear the default branch first
- (and rev (string= rev "")
- (vc-rcs-set-default-branch file nil))
- ;; now do the checkout
- (apply 'vc-do-command
- "*vc*" 0 "co" (vc-name file)
- ;; If locking is not strict, force to overwrite
- ;; the writable workfile.
- (if (eq (vc-rcs-checkout-model (list file)) 'implicit) "-f")
- (if editable "-l")
- (if (stringp rev)
- ;; a literal revision was specified
- (concat "-r" rev)
- (let ((workrev (vc-working-revision file)))
- (if workrev
- (concat "-r"
- (if (not rev)
- ;; no revision specified:
- ;; use current workfile version
- workrev
- ;; REV is t ...
- (if (not (vc-rcs-trunk-p workrev))
- ;; ... go to head of current branch
- (vc-branch-part workrev)
- ;; ... go to head of trunk
- (vc-rcs-set-default-branch file
- nil)
- ""))))))
- switches)
- ;; determine the new workfile version
- (with-current-buffer "*vc*"
- (setq new-version
- (vc-parse-buffer "^revision \\([0-9.]+\\).*\n" 1)))
- (vc-file-setprop file 'vc-working-revision new-version)
- ;; if necessary, adjust the default branch
- (and rev (not (string= rev ""))
- (vc-rcs-set-default-branch
- file
- (if (vc-rcs-latest-on-branch-p file new-version)
- (if (vc-rcs-trunk-p new-version) nil
- (vc-branch-part new-version))
- new-version)))))
- (message "Checking out %s...done" file))))))
-
-(defun vc-rcs-rollback (files)
- "Roll back, undoing the most recent checkins of FILES. Directories are
-expanded to all registered subfiles in them."
- (if (not files)
- (error "RCS backend doesn't support directory-level rollback"))
- (dolist (file (vc-expand-dirs files))
- (let* ((discard (vc-working-revision file))
- (previous (if (vc-rcs-trunk-p discard) "" (vc-branch-part discard)))
- (config (current-window-configuration))
- (done nil))
- (if (null (yes-or-no-p (format "Remove version %s from %s history? "
- discard file)))
- (error "Aborted"))
- (message "Removing revision %s from %s." discard file)
- (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-o" discard))
- ;; Check out the most recent remaining version. If it
- ;; fails, because the whole branch got deleted, do a
- ;; double-take and check out the version where the branch
- ;; started.
- (while (not done)
- (condition-case err
- (progn
- (vc-do-command "*vc*" 0 "co" (vc-name file) "-f"
- (concat "-u" previous))
- (setq done t))
- (error (set-buffer "*vc*")
- (goto-char (point-min))
- (if (search-forward "no side branches present for" nil t)
- (progn (setq previous (vc-branch-part previous))
- (vc-rcs-set-default-branch file previous)
- ;; vc-do-command popped up a window with
- ;; the error message. Get rid of it, by
- ;; restoring the old window configuration.
- (set-window-configuration config))
- ;; No, it was some other error: re-signal it.
- (signal (car err) (cdr err)))))))))
-
-(defun vc-rcs-revert (file &optional contents-done)
- "Revert FILE to the version it was based on. If FILE is a directory,
-revert all registered files beneath it."
- (if (file-directory-p file)
- (mapc 'vc-rcs-revert (vc-expand-dirs (list file)))
- (vc-do-command "*vc*" 0 "co" (vc-name file) "-f"
- (concat (if (eq (vc-state file) 'edited) "-u" "-r")
- (vc-working-revision file)))))
-
-(defun vc-rcs-merge (file first-version &optional second-version)
- "Merge changes into current working copy of FILE.
-The changes are between FIRST-VERSION and SECOND-VERSION."
- (vc-do-command "*vc*" 1 "rcsmerge" (vc-name file)
- "-kk" ; ignore keyword conflicts
- (concat "-r" first-version)
- (if second-version (concat "-r" second-version))))
-
-(defun vc-rcs-steal-lock (file &optional rev)
- "Steal the lock on the current workfile for FILE and revision REV.
-If FILE is a directory, steal the lock on all registered files beneath it.
-Needs RCS 5.6.2 or later for -M."
- (if (file-directory-p file)
- (mapc 'vc-rcs-steal-lock (vc-expand-dirs (list file)))
- (vc-do-command "*vc*" 0 "rcs" (vc-name file) "-M" (concat "-u" rev))
- ;; Do a real checkout after stealing the lock, so that we see
- ;; expanded headers.
- (vc-do-command "*vc*" 0 "co" (vc-name file) "-f" (concat "-l" rev))))
-
-(defun vc-rcs-modify-change-comment (files rev comment)
- "Modify the change comments change on FILES on a specified REV. If FILE is a
-directory the operation is applied to all registered files beneath it."
- (dolist (file (vc-expand-dirs files))
- (vc-do-command "*vc*" 0 "rcs" (vc-name file)
- (concat "-m" rev ":" comment))))
-
-\f
-;;;
-;;; History functions
-;;;
-
-(defun vc-rcs-print-log-cleanup ()
- (let ((inhibit-read-only t))
- (goto-char (point-max))
- (forward-line -1)
- (while (looking-at "=*\n")
- (delete-char (- (match-end 0) (match-beginning 0)))
- (forward-line -1))
- (goto-char (point-min))
- (when (looking-at "[\b\t\n\v\f\r ]+")
- (delete-char (- (match-end 0) (match-beginning 0))))))
-
-(defun vc-rcs-print-log (files buffer &optional shortlog start-revision-ignored limit)
- "Get change log associated with FILE. If FILE is a
-directory the operation is applied to all registered files beneath it."
- (vc-do-command (or buffer "*vc*") 0 "rlog" (mapcar 'vc-name (vc-expand-dirs files)))
- (with-current-buffer (or buffer "*vc*")
- (vc-rcs-print-log-cleanup))
- (when limit 'limit-unsupported))
-
-(defun vc-rcs-diff (files &optional oldvers newvers buffer)
- "Get a difference report using RCS between two sets of files."
- (apply 'vc-do-command (or buffer "*vc-diff*")
- 1 ;; Always go synchronous, the repo is local
- "rcsdiff" (vc-expand-dirs files)
- (append (list "-q"
- (and oldvers (concat "-r" oldvers))
- (and newvers (concat "-r" newvers)))
- (vc-switches 'RCS 'diff))))
-
-(defun vc-rcs-comment-history (file)
- "Return a string with all log entries stored in BACKEND for FILE."
- (with-current-buffer "*vc*"
- ;; Has to be written this way, this function is used by the CVS backend too
- (vc-call-backend (vc-backend file) 'print-log (list file))
- ;; Remove cruft
- (let ((separator (concat "^-+\nrevision [0-9.]+\ndate: .*\n"
- "\\(branches: .*;\n\\)?"
- "\\(\\*\\*\\* empty log message \\*\\*\\*\n\\)?")))
- (goto-char (point-max)) (forward-line -1)
- (while (looking-at "=*\n")
- (delete-char (- (match-end 0) (match-beginning 0)))
- (forward-line -1))
- (goto-char (point-min))
- (if (looking-at "[\b\t\n\v\f\r ]+")
- (delete-char (- (match-end 0) (match-beginning 0))))
- (goto-char (point-min))
- (re-search-forward separator nil t)
- (delete-region (point-min) (point))
- (while (re-search-forward separator nil t)
- (delete-region (match-beginning 0) (match-end 0))))
- ;; Return the de-crufted comment list
- (buffer-string)))
-
-(defun vc-rcs-annotate-command (file buffer &optional revision)
- "Annotate FILE, inserting the results in BUFFER.
-Optional arg REVISION is a revision to annotate from."
- (vc-setup-buffer buffer)
- ;; Aside from the "head revision on the trunk", the instructions for
- ;; each revision on the trunk are an ordered list of kill and insert
- ;; commands necessary to go from the chronologically-following
- ;; revision to this one. That is, associated with revision N are
- ;; edits that applied to revision N+1 would result in revision N.
- ;;
- ;; On a branch, however, (some) things are inverted: the commands
- ;; listed are those necessary to go from the chronologically-preceding
- ;; revision to this one. That is, associated with revision N are
- ;; edits that applied to revision N-1 would result in revision N.
- ;;
- ;; So, to get per-line history info, we apply reverse-chronological
- ;; edits, starting with the head revision on the trunk, all the way
- ;; back through the initial revision (typically "1.1" or similar),
- ;; then apply forward-chronological edits -- keeping track of which
- ;; revision is associated with each inserted line -- until we reach
- ;; the desired revision for display (which may be either on the trunk
- ;; or on a branch).
- (let* ((tree (with-temp-buffer
- (insert-file-contents (vc-rcs-registered file))
- (vc-rcs-parse)))
- (revisions (cdr (assq 'revisions tree)))
- ;; The revision N whose instructions we currently are processing.
- (cur (cdr (assq 'head (cdr (assq 'headers tree)))))
- ;; Alist from the parse tree for N.
- (meta (cdr (assoc cur revisions)))
- ;; Point and temporary string, respectively.
- p s
- ;; "Next-branch list". Nil means the desired revision to
- ;; display lives on the trunk. Non-nil means it lives on a
- ;; branch, in which case the value is a list of revision pairs
- ;; (PARENT . CHILD), the first PARENT being on the trunk, that
- ;; links each series of revisions in the path from the initial
- ;; revision to the desired revision to display.
- nbls
- ;; "Path-accumulate-predicate plus revision/date/author".
- ;; Until set, forward-chronological edits are not accumulated.
- ;; Once set, its value (updated every revision) is used for
- ;; the text property `:vc-rcs-r/d/a' for inserts during
- ;; processing of forward-chronological instructions for N.
- ;; See internal func `r/d/a'.
- prda
- ;; List of forward-chronological instructions, each of the
- ;; form: (POS . ACTION), where POS is a buffer position. If
- ;; ACTION is a string, it is inserted, otherwise it is taken as
- ;; the number of characters to be deleted.
- path
- ;; N+1. When `cur' is "", this is the initial revision.
- pre)
- (unless revision
- (setq revision cur))
- (unless (assoc revision revisions)
- (error "No such revision: %s" revision))
- ;; Find which branches (if any) must be included in the edits.
- (let ((par revision)
- bpt kids)
- (while (setq bpt (vc-branch-part par)
- par (vc-branch-part bpt))
- (setq kids (cdr (assq 'branches (cdr (assoc par revisions)))))
- ;; A branchpoint may have multiple children. Find the right one.
- (while (not (string= bpt (vc-branch-part (car kids))))
- (setq kids (cdr kids)))
- (push (cons par (car kids)) nbls)))
- ;; Start with the full text.
- (set-buffer buffer)
- (insert (cdr (assq 'text meta)))
- ;; Apply reverse-chronological edits on the trunk, computing and
- ;; accumulating forward-chronological edits after some point, for
- ;; later.
- (flet ((r/d/a () (vector pre
- (cdr (assq 'date meta))
- (cdr (assq 'author meta)))))
- (while (when (setq pre cur cur (cdr (assq 'next meta)))
- (not (string= "" cur)))
- (setq
- ;; Start accumulating the forward-chronological edits when N+1
- ;; on the trunk is either the desired revision to display, or
- ;; the appropriate branchpoint for it. Do this before
- ;; updating `meta' since `r/d/a' uses N+1's `meta' value.
- prda (when (or prda (string= (if nbls (caar nbls) revision) pre))
- (r/d/a))
- meta (cdr (assoc cur revisions)))
- ;; Edits in the parse tree specify a line number (in the buffer
- ;; *BEFORE* editing occurs) to start from, but line numbers
- ;; change as a result of edits. To DTRT, we apply edits in
- ;; order of descending buffer position so that edits further
- ;; down in the buffer occur first w/o corrupting specified
- ;; buffer positions of edits occurring towards the beginning of
- ;; the buffer. In this way we avoid using markers. A pleasant
- ;; property of this approach is ability to push instructions
- ;; onto `path' directly, w/o need to maintain rev boundaries.
- (dolist (insn (cdr (assq :insn meta)))
- (goto-char (point-min))
- (forward-line (1- (pop insn)))
- (setq p (point))
- (case (pop insn)
- (k (setq s (buffer-substring-no-properties
- p (progn (forward-line (car insn))
- (point))))
- (when prda
- (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path))
- (delete-region p (point)))
- (i (setq s (car insn))
- (when prda
- (push `(,p . ,(length s)) path))
- (insert s)))))
- ;; For the initial revision, setting `:vc-rcs-r/d/a' directly is
- ;; equivalent to pushing an insert instruction (of the entire buffer
- ;; contents) onto `path' then erasing the buffer, but less wasteful.
- (put-text-property (point-min) (point-max) :vc-rcs-r/d/a (r/d/a))
- ;; Now apply the forward-chronological edits for the trunk.
- (dolist (insn path)
- (goto-char (pop insn))
- (if (stringp insn)
- (insert insn)
- (delete-char insn)))
- ;; Now apply the forward-chronological edits (directly from the
- ;; parse-tree) for the branch(es), if necessary. We re-use vars
- ;; `pre' and `meta' for the sake of internal func `r/d/a'.
- (while nbls
- (setq pre (cdr (pop nbls)))
- (while (progn
- (setq meta (cdr (assoc pre revisions))
- prda nil)
- (dolist (insn (cdr (assq :insn meta)))
- (goto-char (point-min))
- (forward-line (1- (pop insn)))
- (case (pop insn)
- (k (delete-region
- (point) (progn (forward-line (car insn))
- (point))))
- (i (insert (propertize
- (car insn)
- :vc-rcs-r/d/a
- (or prda (setq prda (r/d/a))))))))
- (prog1 (not (string= (if nbls (caar nbls) revision) pre))
- (setq pre (cdr (assq 'next meta)))))))))
- ;; Lastly, for each line, insert at bol nicely-formatted history info.
- ;; We do two passes to collect summary information used to minimize
- ;; the annotation's usage of screen real-estate: (1) Consider rendered
- ;; width of revision plus author together as a unit; and (2) Omit
- ;; author entirely if all authors are the same as the user.
- (let ((ht (make-hash-table :test 'eq))
- (me (user-login-name))
- (maxw 0)
- (all-me t)
- rda w a)
- (goto-char (point-max))
- (while (not (bobp))
- (forward-line -1)
- (setq rda (get-text-property (point) :vc-rcs-r/d/a))
- (unless (gethash rda ht)
- (setq a (aref rda 2)
- all-me (and all-me (string= a me)))
- (puthash rda (setq w (+ (length (aref rda 0))
- (length a)))
- ht)
- (setq maxw (max w maxw))))
- (let ((padding (make-string maxw 32)))
- (flet ((pad (w) (substring-no-properties padding w))
- (render (rda &rest ls)
- (propertize
- (apply 'concat
- (format-time-string "%Y-%m-%d" (aref rda 1))
- " "
- (aref rda 0)
- ls)
- :vc-annotate-prefix t
- :vc-rcs-r/d/a rda)))
- (maphash
- (if all-me
- (lambda (rda w)
- (puthash rda (render rda (pad w) ": ") ht))
- (lambda (rda w)
- (puthash rda (render rda " " (pad w) " " (aref rda 2) ": ") ht)))
- ht)))
- (while (not (eobp))
- (insert (gethash (get-text-property (point) :vc-rcs-r/d/a) ht))
- (forward-line 1))))
-
-(declare-function vc-annotate-convert-time "vc-annotate" (time))
-
-(defun vc-rcs-annotate-current-time ()
- "Return the current time, based at midnight of the current day, and
-encoded as fractional days."
- (vc-annotate-convert-time
- (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time))))))
-
-(defun vc-rcs-annotate-time ()
- "Return the time of the next annotation (as fraction of days)
-systime, or nil if there is none. Also, reposition point."
- (unless (eobp)
- (prog1 (vc-annotate-convert-time
- (aref (get-text-property (point) :vc-rcs-r/d/a) 1))
- (goto-char (next-single-property-change (point) :vc-annotate-prefix)))))
-
-(defun vc-rcs-annotate-extract-revision-at-line ()
- (aref (get-text-property (point) :vc-rcs-r/d/a) 0))
-
-\f
-;;;
-;;; Tag system
-;;;
-
-(defun vc-rcs-create-tag (backend dir name branchp)
- (when branchp
- (error "RCS backend %s does not support module branches" backend))
- (let ((result (vc-tag-precondition dir)))
- (if (stringp result)
- (error "File %s is not up-to-date" result)
- (vc-file-tree-walk
- dir
- (lambda (f)
- (vc-do-command "*vc*" 0 "rcs" (vc-name f) (concat "-n" name ":")))))))
-
-\f
-;;;
-;;; Miscellaneous
-;;;
-
-(defun vc-rcs-trunk-p (rev)
- "Return t if REV is a revision on the trunk."
- (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev))))
-
-(defun vc-rcs-minor-part (rev)
- "Return the minor revision number of a revision number REV."
- (string-match "[0-9]+\\'" rev)
- (substring rev (match-beginning 0) (match-end 0)))
-
-(defun vc-rcs-previous-revision (file rev)
- "Return the revision number immediately preceding REV for FILE,
-or nil if there is no previous revision. This default
-implementation works for MAJOR.MINOR-style revision numbers as
-used by RCS and CVS."
- (let ((branch (vc-branch-part rev))
- (minor-num (string-to-number (vc-rcs-minor-part rev))))
- (when branch
- (if (> minor-num 1)
- ;; revision does probably not start a branch or release
- (concat branch "." (number-to-string (1- minor-num)))
- (if (vc-rcs-trunk-p rev)
- ;; we are at the beginning of the trunk --
- ;; don't know anything to return here
- nil
- ;; we are at the beginning of a branch --
- ;; return revision of starting point
- (vc-branch-part branch))))))
-
-(defun vc-rcs-next-revision (file rev)
- "Return the revision number immediately following REV for FILE,
-or nil if there is no next revision. This default implementation
-works for MAJOR.MINOR-style revision numbers as used by RCS
-and CVS."
- (when (not (string= rev (vc-working-revision file)))
- (let ((branch (vc-branch-part rev))
- (minor-num (string-to-number (vc-rcs-minor-part rev))))
- (concat branch "." (number-to-string (1+ minor-num))))))
-
-(defun vc-rcs-update-changelog (files)
- "Default implementation of update-changelog.
-Uses `rcs2log' which only works for RCS and CVS."
- ;; FIXME: We (c|sh)ould add support for cvs2cl
- (let ((odefault default-directory)
- (changelog (find-change-log))
- ;; Presumably not portable to non-Unixy systems, along with rcs2log:
- (tempfile (make-temp-file
- (expand-file-name "vc"
- (or small-temporary-file-directory
- temporary-file-directory))))
- (login-name (or user-login-name
- (format "uid%d" (number-to-string (user-uid)))))
- (full-name (or add-log-full-name
- (user-full-name)
- (user-login-name)
- (format "uid%d" (number-to-string (user-uid)))))
- (mailing-address (or add-log-mailing-address
- user-mail-address)))
- (find-file-other-window changelog)
- (barf-if-buffer-read-only)
- (vc-buffer-sync)
- (undo-boundary)
- (goto-char (point-min))
- (push-mark)
- (message "Computing change log entries...")
- (message "Computing change log entries... %s"
- (unwind-protect
- (progn
- (setq default-directory odefault)
- (if (eq 0 (apply 'call-process
- (expand-file-name "rcs2log"
- exec-directory)
- nil (list t tempfile) nil
- "-c" changelog
- "-u" (concat login-name
- "\t" full-name
- "\t" mailing-address)
- (mapcar
- (lambda (f)
- (file-relative-name
- (expand-file-name f odefault)))
- files)))
- "done"
- (pop-to-buffer (get-buffer-create "*vc*"))
- (erase-buffer)
- (insert-file-contents tempfile)
- "failed"))
- (setq default-directory (file-name-directory changelog))
- (delete-file tempfile)))))
-
-(defun vc-rcs-check-headers ()
- "Check if the current file has any headers in it."
- (save-excursion
- (goto-char (point-min))
- (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
-\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))
-
-(defun vc-rcs-clear-headers ()
- "Implementation of vc-clear-headers for RCS."
- (let ((case-fold-search nil))
- (goto-char (point-min))
- (while (re-search-forward
- (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|"
- "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$")
- nil t)
- (replace-match "$\\1$"))))
-
-(defun vc-rcs-rename-file (old new)
- ;; Just move the master file (using vc-rcs-master-templates).
- (vc-rename-master (vc-name old) new vc-rcs-master-templates))
-
-(defun vc-rcs-find-file-hook ()
- ;; If the file is locked by some other user, make
- ;; the buffer read-only. Like this, even root
- ;; cannot modify a file that someone else has locked.
- (and (stringp (vc-state buffer-file-name 'RCS))
- (setq buffer-read-only t)))
-
-\f
-;;;
-;;; Internal functions
-;;;
-
-(defun vc-rcs-workfile-is-newer (file)
- "Return non-nil if FILE is newer than its RCS master.
-This likely means that FILE has been changed with respect
-to its master version."
- (let ((file-time (nth 5 (file-attributes file)))
- (master-time (nth 5 (file-attributes (vc-name file)))))
- (or (> (nth 0 file-time) (nth 0 master-time))
- (and (= (nth 0 file-time) (nth 0 master-time))
- (> (nth 1 file-time) (nth 1 master-time))))))
-
-(defun vc-rcs-find-most-recent-rev (branch)
- "Find most recent revision on BRANCH."
- (goto-char (point-min))
- (let ((latest-rev -1) value)
- (while (re-search-forward (concat "^\\(" (regexp-quote branch)
- "\\.\\([0-9]+\\)\\)\ndate[ \t]+[0-9.]+;")
- nil t)
- (let ((rev (string-to-number (match-string 2))))
- (when (< latest-rev rev)
- (setq latest-rev rev)
- (setq value (match-string 1)))))
- (or value
- (vc-branch-part branch))))
-
-(defun vc-rcs-fetch-master-state (file &optional working-revision)
- "Compute the master file's idea of the state of FILE.
-If a WORKING-REVISION is given, compute the state of that version,
-otherwise determine the workfile version based on the master file.
-This function sets the properties `vc-working-revision' and
-`vc-checkout-model' to their correct values, based on the master
-file."
- (with-temp-buffer
- (if (or (not (vc-insert-file (vc-name file) "^[0-9]"))
- (progn (goto-char (point-min))
- (not (looking-at "^head[ \t\n]+[^;]+;$"))))
- (error "File %s is not an RCS master file" (vc-name file)))
- (let ((workfile-is-latest nil)
- (default-branch (vc-parse-buffer "^branch[ \t\n]+\\([^;]*\\);" 1)))
- (vc-file-setprop file 'vc-rcs-default-branch default-branch)
- (unless working-revision
- ;; Workfile version not known yet. Determine that first. It
- ;; is either the head of the trunk, the head of the default
- ;; branch, or the "default branch" itself, if that is a full
- ;; revision number.
- (cond
- ;; no default branch
- ((or (not default-branch) (string= "" default-branch))
- (setq working-revision
- (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
- (setq workfile-is-latest t))
- ;; default branch is actually a revision
- ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$"
- default-branch)
- (setq working-revision default-branch))
- ;; else, search for the head of the default branch
- (t (vc-insert-file (vc-name file) "^desc")
- (setq working-revision
- (vc-rcs-find-most-recent-rev default-branch))
- (setq workfile-is-latest t)))
- (vc-file-setprop file 'vc-working-revision working-revision))
- ;; Check strict locking
- (goto-char (point-min))
- (vc-file-setprop file 'vc-checkout-model
- (if (re-search-forward ";[ \t\n]*strict;" nil t)
- 'locking 'implicit))
- ;; Compute state of workfile version
- (goto-char (point-min))
- (let ((locking-user
- (vc-parse-buffer (concat "^locks[ \t\n]+[^;]*[ \t\n]+\\([^:]+\\):"
- (regexp-quote working-revision)
- "[^0-9.]")
- 1)))
- (cond
- ;; not locked
- ((not locking-user)
- (if (or workfile-is-latest
- (vc-rcs-latest-on-branch-p file working-revision))
- ;; workfile version is latest on branch
- 'up-to-date
- ;; workfile version is not latest on branch
- 'needs-update))
- ;; locked by the calling user
- ((and (stringp locking-user)
- (string= locking-user (vc-user-login-name file)))
- ;; Don't call `vc-rcs-checkout-model' to avoid inf-looping.
- (if (or (eq (vc-file-getprop file 'vc-checkout-model) 'locking)
- workfile-is-latest
- (vc-rcs-latest-on-branch-p file working-revision))
- 'edited
- ;; Locking is not used for the file, but the owner does
- ;; have a lock, and there is a higher version on the current
- ;; branch. Not sure if this can occur, and if it is right
- ;; to use `needs-merge' in this case.
- 'needs-merge))
- ;; locked by somebody else
- ((stringp locking-user)
- locking-user)
- (t
- (error "Error getting state of RCS file")))))))
-
-(defun vc-rcs-consult-headers (file)
- "Search for RCS headers in FILE, and set properties accordingly.
-
-Returns: nil if no headers were found
- 'rev if a workfile revision was found
- 'rev-and-lock if revision and lock info was found"
- (cond
- ((not (get-file-buffer file)) nil)
- ((let (status version locking-user)
- (with-current-buffer (get-file-buffer file)
- (save-excursion
- (goto-char (point-min))
- (cond
- ;; search for $Id or $Header
- ;; -------------------------
- ;; The `\ 's below avoid an RCS 5.7 bug when checking in this file.
- ((or (and (search-forward "$Id\ : " nil t)
- (looking-at "[^ ]+ \\([0-9.]+\\) "))
- (and (progn (goto-char (point-min))
- (search-forward "$Header\ : " nil t))
- (looking-at "[^ ]+ \\([0-9.]+\\) ")))
- (goto-char (match-end 0))
- ;; if found, store the revision number ...
- (setq version (match-string-no-properties 1))
- ;; ... and check for the locking state
- (cond
- ((looking-at
- (concat "[0-9]+[/-][01][0-9][/-][0-3][0-9] " ; date
- "[0-2][0-9]:[0-5][0-9]+:[0-6][0-9]+\\([+-][0-9:]+\\)? " ; time
- "[^ ]+ [^ ]+ ")) ; author & state
- (goto-char (match-end 0)) ; [0-6] in regexp handles leap seconds
- (cond
- ;; unlocked revision
- ((looking-at "\\$")
- (setq locking-user 'none)
- (setq status 'rev-and-lock))
- ;; revision is locked by some user
- ((looking-at "\\([^ ]+\\) \\$")
- (setq locking-user (match-string-no-properties 1))
- (setq status 'rev-and-lock))
- ;; everything else: false
- (nil)))
- ;; unexpected information in
- ;; keyword string --> quit
- (nil)))
- ;; search for $Revision
- ;; --------------------
- ((re-search-forward (concat "\\$"
- "Revision: \\([0-9.]+\\) \\$")
- nil t)
- ;; if found, store the revision number ...
- (setq version (match-string-no-properties 1))
- ;; and see if there's any lock information
- (goto-char (point-min))
- (if (re-search-forward (concat "\\$" "Locker:") nil t)
- (cond ((looking-at " \\([^ ]+\\) \\$")
- (setq locking-user (match-string-no-properties 1))
- (setq status 'rev-and-lock))
- ((looking-at " *\\$")
- (setq locking-user 'none)
- (setq status 'rev-and-lock))
- (t
- (setq locking-user 'none)
- (setq status 'rev-and-lock)))
- (setq status 'rev)))
- ;; else: nothing found
- ;; -------------------
- (t nil))))
- (if status (vc-file-setprop file 'vc-working-revision version))
- (and (eq status 'rev-and-lock)
- (vc-file-setprop file 'vc-state
- (cond
- ((eq locking-user 'none) 'up-to-date)
- ((string= locking-user (vc-user-login-name file))
- 'edited)
- (t locking-user)))
- ;; If the file has headers, we don't want to query the
- ;; master file, because that would eliminate all the
- ;; performance gain the headers brought us. We therefore
- ;; use a heuristic now to find out whether locking is used
- ;; for this file. If we trust the file permissions, and the
- ;; file is not locked, then if the file is read-only we
- ;; assume that locking is used for the file, otherwise
- ;; locking is not used.
- (not (vc-mistrust-permissions file))
- (vc-up-to-date-p file)
- (if (string-match ".r-..-..-." (nth 8 (file-attributes file)))
- (vc-file-setprop file 'vc-checkout-model 'locking)
- (vc-file-setprop file 'vc-checkout-model 'implicit)))
- status))))
-
-(defun vc-release-greater-or-equal (r1 r2)
- "Compare release numbers, represented as strings.
-Release components are assumed cardinal numbers, not decimal fractions
-\(5.10 is a higher release than 5.9\). Omitted fields are considered
-lower \(5.6.7 is earlier than 5.6.7.1\). Comparison runs till the end
-of the string is found, or a non-numeric component shows up \(5.6.7 is
-earlier than \"5.6.7 beta\", which is probably not what you want in
-some cases\). This code is suitable for existing RCS release numbers.
-CVS releases are handled reasonably, too \(1.3 < 1.4* < 1.5\)."
- (let (v1 v2 i1 i2)
- (catch 'done
- (or (and (string-match "^\\.?\\([0-9]+\\)" r1)
- (setq i1 (match-end 0))
- (setq v1 (string-to-number (match-string 1 r1)))
- (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
- (setq i2 (match-end 0))
- (setq v2 (string-to-number (match-string 1 r2)))
- (if (> v1 v2) (throw 'done t)
- (if (< v1 v2) (throw 'done nil)
- (throw 'done
- (vc-release-greater-or-equal
- (substring r1 i1)
- (substring r2 i2)))))))
- (throw 'done t)))
- (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
- (throw 'done nil))
- (throw 'done t)))))
-
-(defun vc-rcs-release-p (release)
- "Return t if we have RELEASE or better."
- (let ((installation (vc-rcs-system-release)))
- (if (and installation
- (not (eq installation 'unknown)))
- (vc-release-greater-or-equal installation release))))
-
-(defun vc-rcs-system-release ()
- "Return the RCS release installed on this system, as a string.
-Return symbol `unknown' if the release cannot be deducted. The user can
-override this using variable `vc-rcs-release'.
-
-If the user has not set variable `vc-rcs-release' and it is nil,
-variable `vc-rcs-release' is set to the returned value."
- (or vc-rcs-release
- (setq vc-rcs-release
- (or (and (zerop (vc-do-command "*vc*" nil "rcs" nil "-V"))
- (with-current-buffer (get-buffer "*vc*")
- (vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1)))
- 'unknown))))
-
-(defun vc-rcs-set-non-strict-locking (file)
- (vc-do-command "*vc*" 0 "rcs" file "-U")
- (vc-file-setprop file 'vc-checkout-model 'implicit)
- (set-file-modes file (logior (file-modes file) 128)))
-
-(defun vc-rcs-set-default-branch (file branch)
- (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-b" branch))
- (vc-file-setprop file 'vc-rcs-default-branch branch))
-
-(defun vc-rcs-parse (&optional buffer)
- "Parse current buffer, presumed to be in RCS-style masterfile format.
-Optional arg BUFFER specifies another buffer to parse. Return an alist
-of two elements, w/ keys `headers' and `revisions' and values in turn
-sub-alists. For `headers', the values unless otherwise specified are
-strings and the keys are:
-
- desc -- description
- head -- latest revision
- branch -- the branch the \"head revision\" lies on;
- absent if the head revision lies on the trunk
- access -- ???
- symbols -- sub-alist of (SYMBOL . REVISION) elements
- locks -- if file is checked out, something like \"ttn:1.7\"
- strict -- t if \"strict locking\" is in effect, otherwise nil
- comment -- may be absent; typically something like \"# \" or \"; \"
- expand -- may be absent; ???
-
-For `revisions', the car is REVISION (string), the cdr a sub-alist,
-with string values (unless otherwise specified) and keys:
-
- date -- a time value (like that returned by `encode-time'); as a
- special case, a year value less than 100 is augmented by 1900
- author -- username
- state -- typically \"Exp\" or \"Rel\"
- branches -- list of revisions that begin branches from this revision
- next -- on the trunk: the chronologically-preceding revision, or \"\";
- on a branch: the chronologically-following revision, or \"\"
- log -- change log entry
- text -- for the head revision on the trunk, the body of the file;
- other revisions have `:insn' instead
- :insn -- for non-head revisions, a list of parsed instructions
- in one of two forms, in both cases START meaning \"first
- go to line START\":
- - `(START k COUNT)' -- kill COUNT lines
- - `(START i TEXT)' -- insert TEXT (a string)
- The list is in descending order by START.
-
-The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension."
- (setq buffer (get-buffer (or buffer (current-buffer))))
- (set-buffer buffer)
- ;; An RCS masterfile can be viewed as containing four regular (for the
- ;; most part) sections: (a) the "headers", (b) the "rev headers", (c)
- ;; the "description" and (d) the "rev bodies", in that order. In the
- ;; returned alist (see docstring), elements from (b) and (d) are
- ;; combined pairwise to form the "revisions", while those from (a) and
- ;; (c) are simply combined to form the "headers".
- ;;
- ;; Loosely speaking, each section contains a series of alternating
- ;; "tags" and "printed representations". In the (b) and (d), many
- ;; such series can appear, and a revision number on a line by itself
- ;; precedes the series of tags and printed representations associated
- ;; with it.
- ;;
- ;; In (a) and (b), the printed representations (with the exception of
- ;; the `comment' tag in the headers) terminate with a semicolon, which
- ;; is NOT part of the "value" finally associated with the tag. All
- ;; other printed representations are in "@@-format"; there is an "@",
- ;; the middle part (to be translated into the value), another "@" and
- ;; a newline. Each "@@" in the middle part indicates the position of
- ;; a single "@" (and consequently the requirement of an additional
- ;; initial step when translating to the value).
- ;;
- ;; Parser state includes vars that collect parts of the return value...
- (let ((desc nil) (headers nil) (revs nil)
- ;; ... as well as vars that support a single-pass, tag-assisted,
- ;; minimal-data-copying scan. Basically -- skirting around the
- ;; grouping by revision required in (b) and (d) -- we repeatedly
- ;; and context-sensitively read a tag (that MUST be present),
- ;; determine the bounds of the printed representation, translate
- ;; it into a value, and push the tag plus value onto one of the
- ;; collection vars. Finally, we return the parse tree
- ;; incorporating the values of the collection vars (see "rv").
- ;;
- ;; A symbol or string to keep track of context (for error messages).
- context
- ;; A symbol, the current tag.
- tok
- ;; Region (begin and end buffer positions) of the printed
- ;; representation for the current tag.
- b e
- ;; A list of buffer positions where "@@" can be found within the
- ;; printed representation region. For each location, we push two
- ;; elements onto the list, 1+ and 2+ the location, respectively,
- ;; with the 2+ appearing at the head. In this way, the expression
- ;; `(,e ,@@-holes ,b)
- ;; describes regions that can be concatenated (in reverse order)
- ;; to "de-@@-format" the printed representation as the first step
- ;; to translating it into some value. See internal func `gather'.
- @-holes)
- (flet ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]'
- (at (tag) (save-excursion (eq tag (read buffer))))
- (to-eol () (buffer-substring-no-properties
- (point) (progn (forward-line 1)
- (1- (point)))))
- (to-semi () (setq b (point)
- e (progn (search-forward ";")
- (1- (point)))))
- (to-one@ () (setq @-holes nil
- b (progn (search-forward "@") (point))
- e (progn (while (and (search-forward "@")
- (= ?@ (char-after))
- (progn
- (push (point) @-holes)
- (forward-char 1)
- (push (point) @-holes))))
- (1- (point)))))
- (tok+val (set-b+e name &optional proc)
- (unless (eq name (setq tok (read buffer)))
- (error "Missing `%s' while parsing %s" name context))
- (sw)
- (funcall set-b+e)
- (cons tok (if proc
- (funcall proc)
- (buffer-substring-no-properties b e))))
- (k-semi (name &optional proc) (tok+val 'to-semi name proc))
- (gather () (let ((pairs `(,e ,@@-holes ,b))
- acc)
- (while pairs
- (push (buffer-substring-no-properties
- (cadr pairs) (car pairs))
- acc)
- (setq pairs (cddr pairs)))
- (apply 'concat acc)))
- (k-one@ (name &optional later) (tok+val 'to-one@ name
- (if later
- (lambda () t)
- 'gather))))
- (save-excursion
- (goto-char (point-min))
- ;; headers
- (setq context 'headers)
- (flet ((hpush (name &optional proc)
- (push (k-semi name proc) headers)))
- (hpush 'head)
- (when (at 'branch)
- (hpush 'branch))
- (hpush 'access)
- (hpush 'symbols
- (lambda ()
- (mapcar (lambda (together)
- (let ((two (split-string together ":")))
- (setcar two (intern (car two)))
- (setcdr two (cadr two))
- two))
- (split-string
- (buffer-substring-no-properties b e)))))
- (hpush 'locks))
- (push `(strict . ,(when (at 'strict)
- (search-forward ";")
- t))
- headers)
- (when (at 'comment)
- (push (k-one@ 'comment) headers)
- (search-forward ";"))
- (when (at 'expand)
- (push (k-one@ 'expand) headers)
- (search-forward ";"))
- (setq headers (nreverse headers))
- ;; rev headers
- (sw) (setq context 'rev-headers)
- (while (looking-at "[0-9]")
- (push `(,(to-eol)
- ,(k-semi 'date
- (lambda ()
- (let ((ls (mapcar 'string-to-number
- (split-string
- (buffer-substring-no-properties
- b e)
- "\\."))))
- ;; Hack the year -- verified to be the
- ;; same algorithm used in RCS 5.7.
- (when (< (car ls) 100)
- (setcar ls (+ 1900 (car ls))))
- (apply 'encode-time (nreverse ls)))))
- ,@(mapcar 'k-semi '(author state))
- ,(k-semi 'branches
- (lambda ()
- (split-string
- (buffer-substring-no-properties b e))))
- ,(k-semi 'next))
- revs)
- (sw))
- (setq revs (nreverse revs))
- ;; desc
- (sw) (setq context 'desc
- desc (k-one@ 'desc))
- ;; rev bodies
- (let (acc
- ;; Element of `revs' that initially holds only header info.
- ;; "Pairwise combination" occurs when we add body info.
- rev
- ;; Components of the editing commands (aside from the actual
- ;; text) that comprise the `text' printed representations
- ;; (not including the "head" revision).
- cmd start act
- ;; Ascending (reversed) `@-holes' which the internal func
- ;; `incg' pops to effect incremental gathering.
- asc
- ;; Function to extract text (for the `a' command), either
- ;; `incg' or `buffer-substring-no-properties'. (This is
- ;; for speed; strictly speaking, it is sufficient to use
- ;; only the former since it behaves identically to the
- ;; latter in the absense of "@@".)
- sub)
- (flet ((incg (beg end) (let ((b beg) (e end) @-holes)
- (while (and asc (< (car asc) e))
- (push (pop asc) @-holes))
- ;; Self-deprecate when work is done.
- ;; Folding many dimensions into one.
- ;; Thanks B.Mandelbrot, for complex sum.
- ;; O beauteous math! --the Unvexed Bum
- (unless asc
- (setq sub 'buffer-substring-no-properties))
- (gather))))
- (while (and (sw)
- (not (eobp))
- (setq context (to-eol)
- rev (or (assoc context revs)
- (error "Rev `%s' has body but no head"
- context))))
- (push (k-one@ 'log) (cdr rev))
- ;; For rev body `text' tags, delay translation slightly...
- (push (k-one@ 'text t) (cdr rev))
- ;; ... until we decide which tag and value is appropriate to
- ;; collect. For the "head" revision, compute the value of the
- ;; `text' printed representation by simple `gather'. For all
- ;; other revisions, replace the `text' tag+value with `:insn'
- ;; plus value, always scanning in-place.
- (if (string= context (cdr (assq 'head headers)))
- (setcdr (cadr rev) (gather))
- (if @-holes
- (setq asc (nreverse @-holes)
- sub 'incg)
- (setq sub 'buffer-substring-no-properties))
- (goto-char b)
- (setq acc nil)
- (while (< (point) e)
- (forward-char 1)
- (setq cmd (char-before)
- start (read (current-buffer))
- act (read (current-buffer)))
- (forward-char 1)
- (push (case cmd
- (?d
- ;; `d' means "delete lines".
- ;; For Emacs spirit, we use `k' for "kill".
- `(,start k ,act))
- (?a
- ;; `a' means "append after this line" but
- ;; internally we normalize it so that START
- ;; specifies the actual line for insert, thus
- ;; requiring less hair in the realization algs.
- ;; For Emacs spirit, we use `i' for "insert".
- `(,(1+ start) i
- ,(funcall sub (point) (progn (forward-line act)
- (point)))))
- (t (error "Bad command `%c' in `text' for rev `%s'"
- cmd context)))
- acc))
- (goto-char (1+ e))
- (setcar (cdr rev) (cons :insn acc)))))))
- ;; rv
- `((headers ,desc ,@headers)
- (revisions ,@revs)))))
-
-(provide 'vc-rcs)
-
-;; arch-tag: 759b4916-5b0d-431d-b647-b185b8c652cf
-;;; vc-rcs.el ends here
+++ /dev/null
-;;; vc-sccs.el --- support for SCCS version-control
-
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Author: FSF (see vc.el for full credits)
-;; Maintainer: Andre Spiegel <spiegel@gnu.org>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Proper function of the SCCS diff commands requires the shellscript vcdiff
-;; to be installed somewhere on Emacs's path for executables.
-;;
-
-;;; Code:
-
-(eval-when-compile
- (require 'vc))
-
-;;;
-;;; Customization options
-;;;
-
-;; ;; Maybe a better solution is to not use "get" but "sccs get".
-;; (defcustom vc-sccs-path
-;; (let ((path ()))
-;; (dolist (dir '("/usr/sccs" "/usr/lib/sccs" "/usr/libexec/sccs"))
-;; (if (file-directory-p dir)
-;; (push dir path)))
-;; path)
-;; "List of extra directories to search for SCCS commands."
-;; :type '(repeat directory)
-;; :group 'vc)
-
-(defcustom vc-sccs-register-switches nil
- "Switches for registering a file in SCCS.
-A string or list of strings passed to the checkin program by
-\\[vc-register]. If nil, use the value of `vc-register-switches'.
-If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc)
-
-(defcustom vc-sccs-diff-switches nil
- "String or list of strings specifying switches for SCCS diff under VC.
-If nil, use the value of `vc-diff-switches'. If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "21.1"
- :group 'vc)
-
-(defcustom vc-sccs-header (or (cdr (assoc 'SCCS vc-header-alist)) '("%W%"))
- "Header keywords to be inserted by `vc-insert-headers'."
- :type '(repeat string)
- :group 'vc)
-
-;;;###autoload
-(defcustom vc-sccs-master-templates
- (purecopy '("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir))
- "Where to look for SCCS master files.
-For a description of possible values, see `vc-check-master-templates'."
- :type '(choice (const :tag "Use standard SCCS file names"
- ("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir))
- (repeat :tag "User-specified"
- (choice string
- function)))
- :version "21.1"
- :group 'vc)
-
-\f
-;;;
-;;; Internal variables
-;;;
-
-(defconst vc-sccs-name-assoc-file "VC-names")
-
-\f
-;;; Properties of the backend
-
-(defun vc-sccs-revision-granularity () 'file)
-(defun vc-sccs-checkout-model (files) 'locking)
-
-;;;
-;;; State-querying functions
-;;;
-
-;; The autoload cookie below places vc-sccs-registered directly into
-;; loaddefs.el, so that vc-sccs.el does not need to be loaded for
-;; every file that is visited. The definition is repeated below
-;; so that Help and etags can find it.
-
-;;;###autoload (defun vc-sccs-registered(f) (vc-default-registered 'SCCS f))
-(defun vc-sccs-registered (f) (vc-default-registered 'SCCS f))
-
-(defun vc-sccs-state (file)
- "SCCS-specific function to compute the version control state."
- (if (not (vc-sccs-registered file))
- 'unregistered
- (with-temp-buffer
- (if (vc-insert-file (vc-sccs-lock-file file))
- (let* ((locks (vc-sccs-parse-locks))
- (working-revision (vc-working-revision file))
- (locking-user (cdr (assoc working-revision locks))))
- (if (not locking-user)
- (if (vc-workfile-unchanged-p file)
- 'up-to-date
- 'unlocked-changes)
- (if (string= locking-user (vc-user-login-name file))
- 'edited
- locking-user)))
- 'up-to-date))))
-
-(defun vc-sccs-state-heuristic (file)
- "SCCS-specific state heuristic."
- (if (not (vc-mistrust-permissions file))
- ;; This implementation assumes that any file which is under version
- ;; control and has -rw-r--r-- is locked by its owner. This is true
- ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
- ;; We have to be careful not to exclude files with execute bits on;
- ;; scripts can be under version control too. Also, we must ignore the
- ;; group-read and other-read bits, since paranoid users turn them off.
- (let* ((attributes (file-attributes file 'string))
- (owner-name (nth 2 attributes))
- (permissions (nth 8 attributes)))
- (if (string-match ".r-..-..-." permissions)
- 'up-to-date
- (if (string-match ".rw..-..-." permissions)
- (if (file-ownership-preserved-p file)
- 'edited
- owner-name)
- ;; Strange permissions.
- ;; Fall through to real state computation.
- (vc-sccs-state file))))
- (vc-sccs-state file)))
-
-(defun vc-sccs-dir-status (dir update-function)
- ;; FIXME: this function should be rewritten, using `vc-expand-dirs'
- ;; is not TRTD because it returns files from multiple backends.
- ;; It should also return 'unregistered files.
-
- ;; Doing lots of individual VC-state calls is painful, but
- ;; there is no better option in SCCS-land.
- (let ((flist (vc-expand-dirs (list dir)))
- (result nil))
- (dolist (file flist)
- (let ((state (vc-state file))
- (frel (file-relative-name file)))
- (when (and (eq (vc-backend file) 'SCCS)
- (not (eq state 'up-to-date)))
- (push (list frel state) result))))
- (funcall update-function result)))
-
-(defun vc-sccs-working-revision (file)
- "SCCS-specific version of `vc-working-revision'."
- (with-temp-buffer
- ;; The working revision is always the latest revision number.
- ;; To find this number, search the entire delta table,
- ;; rather than just the first entry, because the
- ;; first entry might be a deleted ("R") revision.
- (vc-insert-file (vc-name file) "^\001e\n\001[^s]")
- (vc-parse-buffer "^\001d D \\([^ ]+\\)" 1)))
-
-(defun vc-sccs-workfile-unchanged-p (file)
- "SCCS-specific implementation of `vc-workfile-unchanged-p'."
- (zerop (apply 'vc-do-command "*vc*" 1 "vcdiff" (vc-name file)
- (list "--brief" "-q"
- (concat "-r" (vc-working-revision file))))))
-
-\f
-;;;
-;;; State-changing functions
-;;;
-
-(defun vc-sccs-do-command (buffer okstatus command file-or-list &rest flags)
- ;; (let ((load-path (append vc-sccs-path load-path)))
- ;; (apply 'vc-do-command buffer okstatus command file-or-list flags))
- (apply 'vc-do-command (or buffer "*vc*") okstatus "sccs" file-or-list command flags))
-
-(defun vc-sccs-create-repo ()
- "Create a new SCCS repository."
- ;; SCCS is totally file-oriented, so all we have to do is make the directory
- (make-directory "SCCS"))
-
-(defun vc-sccs-register (files &optional rev comment)
- "Register FILES into the SCCS version-control system.
-REV is the optional revision number for the file. COMMENT can be used
-to provide an initial description of FILES.
-Passes either `vc-sccs-register-switches' or `vc-register-switches'
-to the SCCS command.
-
-Automatically retrieve a read-only version of the files with keywords
-expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
- (dolist (file files)
- (let* ((dirname (or (file-name-directory file) ""))
- (basename (file-name-nondirectory file))
- (project-file (vc-sccs-search-project-dir dirname basename)))
- (let ((vc-name
- (or project-file
- (format (car vc-sccs-master-templates) dirname basename))))
- (apply 'vc-sccs-do-command nil 0 "admin" vc-name
- (and rev (not (string= rev "")) (concat "-r" rev))
- "-fb"
- (concat "-i" (file-relative-name file))
- (and comment (concat "-y" comment))
- (vc-switches 'SCCS 'register)))
- (delete-file file)
- (if vc-keep-workfiles
- (vc-sccs-do-command nil 0 "get" (vc-name file))))))
-
-(defun vc-sccs-responsible-p (file)
- "Return non-nil if SCCS thinks it would be responsible for registering FILE."
- ;; TODO: check for all the patterns in vc-sccs-master-templates
- (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file)))
- (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "")
- (file-name-nondirectory file)))))
-
-(defun vc-sccs-checkin (files rev comment &optional extra-args-ignored)
- "SCCS-specific version of `vc-backend-checkin'."
- (dolist (file (vc-expand-dirs files))
- (apply 'vc-sccs-do-command nil 0 "delta" (vc-name file)
- (if rev (concat "-r" rev))
- (concat "-y" comment)
- (vc-switches 'SCCS 'checkin))
- (if vc-keep-workfiles
- (vc-sccs-do-command nil 0 "get" (vc-name file)))))
-
-(defun vc-sccs-find-revision (file rev buffer)
- (apply 'vc-sccs-do-command
- buffer 0 "get" (vc-name file)
- "-s" ;; suppress diagnostic output
- "-p"
- (and rev
- (concat "-r"
- (vc-sccs-lookup-triple file rev)))
- (vc-switches 'SCCS 'checkout)))
-
-(defun vc-sccs-checkout (file &optional editable rev)
- "Retrieve a copy of a saved revision of SCCS controlled FILE.
-If FILE is a directory, all version-controlled files beneath are checked out.
-EDITABLE non-nil means that the file should be writable and
-locked. REV is the revision to check out."
- (if (file-directory-p file)
- (mapc 'vc-sccs-checkout (vc-expand-dirs (list file)))
- (let ((file-buffer (get-file-buffer file))
- switches)
- (message "Checking out %s..." file)
- (save-excursion
- ;; Change buffers to get local value of vc-checkout-switches.
- (if file-buffer (set-buffer file-buffer))
- (setq switches (vc-switches 'SCCS 'checkout))
- ;; Save this buffer's default-directory
- ;; and use save-excursion to make sure it is restored
- ;; in the same buffer it was saved in.
- (let ((default-directory default-directory))
- (save-excursion
- ;; Adjust the default-directory so that the check-out creates
- ;; the file in the right place.
- (setq default-directory (file-name-directory file))
-
- (and rev (or (string= rev "")
- (not (stringp rev)))
- (setq rev nil))
- (apply 'vc-sccs-do-command nil 0 "get" (vc-name file)
- (if editable "-e")
- (and rev (concat "-r" (vc-sccs-lookup-triple file rev)))
- switches))))
- (message "Checking out %s...done" file))))
-
-(defun vc-sccs-rollback (files)
- "Roll back, undoing the most recent checkins of FILES. Directories
-are expanded to all version-controlled subfiles."
- (setq files (vc-expand-dirs files))
- (if (not files)
- (error "SCCS backend doesn't support directory-level rollback"))
- (dolist (file files)
- (let ((discard (vc-working-revision file)))
- (if (null (yes-or-no-p (format "Remove version %s from %s history? "
- discard file)))
- (error "Aborted"))
- (message "Removing revision %s from %s..." discard file)
- (vc-sccs-do-command nil 0 "rmdel"
- (vc-name file) (concat "-r" discard))
- (vc-sccs-do-command nil 0 "get" (vc-name file) nil))))
-
-(defun vc-sccs-revert (file &optional contents-done)
- "Revert FILE to the version it was based on. If FILE is a directory,
-revert all subfiles."
- (if (file-directory-p file)
- (mapc 'vc-sccs-revert (vc-expand-dirs (list file)))
- (vc-sccs-do-command nil 0 "unget" (vc-name file))
- (vc-sccs-do-command nil 0 "get" (vc-name file))
- ;; Checking out explicit revisions is not supported under SCCS, yet.
- ;; We always "revert" to the latest revision; therefore
- ;; vc-working-revision is cleared here so that it gets recomputed.
- (vc-file-setprop file 'vc-working-revision nil)))
-
-(defun vc-sccs-steal-lock (file &optional rev)
- "Steal the lock on the current workfile for FILE and revision REV."
- (if (file-directory-p file)
- (mapc 'vc-sccs-steal-lock (vc-expand-dirs (list file)))
- (vc-sccs-do-command nil 0 "unget"
- (vc-name file) "-n" (if rev (concat "-r" rev)))
- (vc-sccs-do-command nil 0 "get"
- (vc-name file) "-g" (if rev (concat "-r" rev)))))
-
-(defun vc-sccs-modify-change-comment (files rev comment)
- "Modify (actually, append to) the change comments for FILES on a specified REV."
- (dolist (file (vc-expand-dirs files))
- (vc-sccs-do-command nil 0 "cdc" (vc-name file)
- (concat "-y" comment) (concat "-r" rev))))
-
-\f
-;;;
-;;; History functions
-;;;
-
-(defun vc-sccs-print-log (files buffer &optional shortlog start-revision-ignored limit)
- "Get change log associated with FILES."
- (setq files (vc-expand-dirs files))
- (vc-sccs-do-command buffer 0 "prs" (mapcar 'vc-name files))
- (when limit 'limit-unsupported))
-
-(defun vc-sccs-diff (files &optional oldvers newvers buffer)
- "Get a difference report using SCCS between two filesets."
- (setq files (vc-expand-dirs files))
- (setq oldvers (vc-sccs-lookup-triple (car files) oldvers))
- (setq newvers (vc-sccs-lookup-triple (car files) newvers))
- (apply 'vc-do-command (or buffer "*vc-diff*")
- 1 "vcdiff" (mapcar 'vc-name (vc-expand-dirs files))
- (append (list "-q"
- (and oldvers (concat "-r" oldvers))
- (and newvers (concat "-r" newvers)))
- (vc-switches 'SCCS 'diff))))
-
-\f
-;;;
-;;; Tag system. SCCS doesn't have tags, so we simulate them by maintaining
-;;; our own set of name-to-revision mappings.
-;;;
-
-(defun vc-sccs-create-tag (backend dir name branchp)
- (when branchp
- (error "SCCS backend %s does not support module branches" backend))
- (let ((result (vc-tag-precondition dir)))
- (if (stringp result)
- (error "File %s is not up-to-date" result)
- (vc-file-tree-walk
- dir
- (lambda (f)
- (vc-sccs-add-triple name f (vc-working-revision f)))))))
-
-\f
-;;;
-;;; Miscellaneous
-;;;
-
-(defun vc-sccs-previous-revision (file rev)
- (vc-call-backend 'RCS 'previous-revision file rev))
-
-(defun vc-sccs-next-revision (file rev)
- (vc-call-backend 'RCS 'next-revision file rev))
-
-(defun vc-sccs-check-headers ()
- "Check if the current file has any headers in it."
- (save-excursion
- (goto-char (point-min))
- (re-search-forward "%[A-Z]%" nil t)))
-
-(defun vc-sccs-rename-file (old new)
- ;; Move the master file (using vc-rcs-master-templates).
- (vc-rename-master (vc-name old) new vc-sccs-master-templates)
- ;; Update the tag file.
- (with-current-buffer
- (find-file-noselect
- (expand-file-name vc-sccs-name-assoc-file
- (file-name-directory (vc-name old))))
- (goto-char (point-min))
- ;; (replace-regexp (concat ":" (regexp-quote old) "$") (concat ":" new))
- (while (re-search-forward (concat ":" (regexp-quote old) "$") nil t)
- (replace-match (concat ":" new) nil nil))
- (basic-save-buffer)
- (kill-buffer (current-buffer))))
-
-(defun vc-sccs-find-file-hook ()
- ;; If the file is locked by some other user, make
- ;; the buffer read-only. Like this, even root
- ;; cannot modify a file that someone else has locked.
- (and (stringp (vc-state buffer-file-name 'SCCS))
- (setq buffer-read-only t)))
-
-\f
-;;;
-;;; Internal functions
-;;;
-
-;; This function is wrapped with `progn' so that the autoload cookie
-;; copies the whole function itself into loaddefs.el rather than just placing
-;; a (autoload 'vc-sccs-search-project-dir "vc-sccs") which would not
-;; help us avoid loading vc-sccs.
-;;;###autoload
-(progn (defun vc-sccs-search-project-dir (dirname basename)
- "Return the name of a master file in the SCCS project directory.
-Does not check whether the file exists but returns nil if it does not
-find any project directory."
- (let ((project-dir (getenv "PROJECTDIR")) dirs dir)
- (when project-dir
- (if (file-name-absolute-p project-dir)
- (setq dirs '("SCCS" ""))
- (setq dirs '("src/SCCS" "src" "source/SCCS" "source"))
- (setq project-dir (expand-file-name (concat "~" project-dir))))
- (while (and (not dir) dirs)
- (setq dir (expand-file-name (car dirs) project-dir))
- (unless (file-directory-p dir)
- (setq dir nil)
- (setq dirs (cdr dirs))))
- (and dir (expand-file-name (concat "s." basename) dir))))))
-
-(defun vc-sccs-lock-file (file)
- "Generate lock file name corresponding to FILE."
- (let ((master (vc-name file)))
- (and
- master
- (string-match "\\(.*/\\)\\(s\\.\\)\\(.*\\)" master)
- (replace-match "p." t t master 2))))
-
-(defun vc-sccs-parse-locks ()
- "Parse SCCS locks in current buffer.
-The result is a list of the form ((REVISION . USER) (REVISION . USER) ...)."
- (let (master-locks)
- (goto-char (point-min))
- (while (re-search-forward "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?"
- nil t)
- (setq master-locks
- (cons (cons (match-string 1) (match-string 2)) master-locks)))
- ;; FIXME: is it really necessary to reverse ?
- (nreverse master-locks)))
-
-(defun vc-sccs-add-triple (name file rev)
- (with-current-buffer
- (find-file-noselect
- (expand-file-name vc-sccs-name-assoc-file
- (file-name-directory (vc-name file))))
- (goto-char (point-max))
- (insert name "\t:\t" file "\t" rev "\n")
- (basic-save-buffer)
- (kill-buffer (current-buffer))))
-
-(defun vc-sccs-lookup-triple (file name)
- "Return the numeric revision corresponding to a named tag of FILE.
-If NAME is nil or a revision number string it's just passed through."
- (if (or (null name)
- (let ((firstchar (aref name 0)))
- (and (>= firstchar ?0) (<= firstchar ?9))))
- name
- (with-temp-buffer
- (vc-insert-file
- (expand-file-name vc-sccs-name-assoc-file
- (file-name-directory (vc-name file))))
- (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1))))
-
-(provide 'vc-sccs)
-
-;; arch-tag: d751dee3-d7b3-47e1-95e3-7ae98c052041
-;;; vc-sccs.el ends here
+++ /dev/null
-;;; vc-svn.el --- non-resident support for Subversion version-control
-
-;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Author: FSF (see vc.el for full credits)
-;; Maintainer: Stefan Monnier <monnier@gnu.org>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Sync'd with Subversion's vc-svn.el as of revision 5801. but this version
-;; has been extensively modified since to handle filesets.
-
-;;; Code:
-
-(eval-when-compile
- (require 'vc))
-
-;; Clear up the cache to force vc-call to check again and discover
-;; new functions when we reload this file.
-(put 'SVN 'vc-functions nil)
-
-;;;
-;;; Customization options
-;;;
-
-;; FIXME there is also svnadmin.
-(defcustom vc-svn-program "svn"
- "Name of the SVN executable."
- :type 'string
- :group 'vc)
-
-(defcustom vc-svn-global-switches nil
- "Global switches to pass to any SVN command."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List"
- :value ("")
- string))
- :version "22.1"
- :group 'vc)
-
-(defcustom vc-svn-register-switches nil
- "Switches for registering a file into SVN.
-A string or list of strings passed to the checkin program by
-\\[vc-register]. If nil, use the value of `vc-register-switches'.
-If t, use no switches."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :version "22.1"
- :group 'vc)
-
-(defcustom vc-svn-diff-switches
- t ;`svn' doesn't support common args like -c or -b.
- "String or list of strings specifying extra switches for svn diff under VC.
-If nil, use the value of `vc-diff-switches' (or `diff-switches'),
-together with \"-x --diff-cmd=diff\" (since svn diff does not
-support the default \"-c\" value of `diff-switches'). If you
-want to force an empty list of arguments, use t."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List"
- :value ("")
- string))
- :version "22.1"
- :group 'vc)
-
-(defcustom vc-svn-header (or (cdr (assoc 'SVN vc-header-alist)) '("\$Id\$"))
- "Header keywords to be inserted by `vc-insert-headers'."
- :version "22.1"
- :type '(repeat string)
- :group 'vc)
-
-;; We want to autoload it for use by the autoloaded version of
-;; vc-svn-registered, but we want the value to be compiled at startup, not
-;; at dump time.
-;; ;;;###autoload
-(defconst vc-svn-admin-directory
- (cond ((and (memq system-type '(cygwin windows-nt ms-dos))
- (getenv "SVN_ASP_DOT_NET_HACK"))
- "_svn")
- (t ".svn"))
- "The name of the \".svn\" subdirectory or its equivalent.")
-
-;;; Properties of the backend
-
-(defun vc-svn-revision-granularity () 'repository)
-(defun vc-svn-checkout-model (files) 'implicit)
-
-;;;
-;;; State-querying functions
-;;;
-
-;;; vc-svn-admin-directory is generally not defined when the
-;;; autoloaded function is called.
-
-;;;###autoload (defun vc-svn-registered (f)
-;;;###autoload (let ((admin-dir (cond ((and (eq system-type 'windows-nt)
-;;;###autoload (getenv "SVN_ASP_DOT_NET_HACK"))
-;;;###autoload "_svn")
-;;;###autoload (t ".svn"))))
-;;;###autoload (when (file-readable-p (expand-file-name
-;;;###autoload (concat admin-dir "/entries")
-;;;###autoload (file-name-directory f)))
-;;;###autoload (load "vc-svn")
-;;;###autoload (vc-svn-registered f))))
-
-(defun vc-svn-registered (file)
- "Check if FILE is SVN registered."
- (when (file-readable-p (expand-file-name (concat vc-svn-admin-directory
- "/entries")
- (file-name-directory file)))
- (with-temp-buffer
- (cd (file-name-directory file))
- (let* (process-file-side-effects
- (status
- (condition-case nil
- ;; Ignore all errors.
- (vc-svn-command t t file "status" "-v")
- ;; Some problem happened. E.g. We can't find an `svn'
- ;; executable. We used to only catch `file-error' but when
- ;; the process is run on a remote host via Tramp, the error
- ;; is only reported via the exit status which is turned into
- ;; an `error' by vc-do-command.
- (error nil))))
- (when (eq 0 status)
- (let ((parsed (vc-svn-parse-status file)))
- (and parsed (not (memq parsed '(ignored unregistered))))))))))
-
-(defun vc-svn-state (file &optional localp)
- "SVN-specific version of `vc-state'."
- (let (process-file-side-effects)
- (setq localp (or localp (vc-stay-local-p file 'SVN)))
- (with-temp-buffer
- (cd (file-name-directory file))
- (vc-svn-command t 0 file "status" (if localp "-v" "-u"))
- (vc-svn-parse-status file))))
-
-(defun vc-svn-state-heuristic (file)
- "SVN-specific state heuristic."
- (vc-svn-state file 'local))
-
-;; FIXME it would be better not to have the "remote" argument,
-;; but to distinguish the two output formats based on content.
-(defun vc-svn-after-dir-status (callback &optional remote)
- (let ((state-map '((?A . added)
- (?C . conflict)
- (?I . ignored)
- (?M . edited)
- (?D . removed)
- (?R . removed)
- (?? . unregistered)
- ;; This is what vc-svn-parse-status does.
- (?~ . edited)))
- (re (if remote "^\\(.\\)...... \\([ *]\\) +\\(?:[-0-9]+\\)? \\(.*\\)$"
- ;; Subexp 2 is a dummy in this case, so the numbers match.
- "^\\(.\\)....\\(.\\) \\(.*\\)$"))
- result)
- (goto-char (point-min))
- (while (re-search-forward re nil t)
- (let ((state (cdr (assq (aref (match-string 1) 0) state-map)))
- (filename (match-string 3)))
- (and remote (string-equal (match-string 2) "*")
- ;; FIXME are there other possible combinations?
- (cond ((eq state 'edited) (setq state 'needs-merge))
- ((not state) (setq state 'needs-update))))
- (when (and state (not (string= "." filename)))
- (setq result (cons (list filename state) result)))))
- (funcall callback result)))
-
-(defun vc-svn-dir-status (dir callback)
- "Run 'svn status' for DIR and update BUFFER via CALLBACK.
-CALLBACK is called as (CALLBACK RESULT BUFFER), where
-RESULT is a list of conses (FILE . STATE) for directory DIR."
- ;; FIXME should this rather be all the files in dir?
- ;; FIXME: the vc-stay-local-p logic below is disabled, it ends up
- ;; calling synchronously (vc-svn-registered DIR) => calling svn status -v DIR
- ;; which is VERY SLOW for big trees and it makes emacs
- ;; completely unresponsive during that time.
- (let* ((local (and nil (vc-stay-local-p dir 'SVN)))
- (remote (or t (not local) (eq local 'only-file))))
- (vc-svn-command (current-buffer) 'async nil "status"
- (if remote "-u"))
- (vc-exec-after
- `(vc-svn-after-dir-status (quote ,callback) ,remote))))
-
-(defun vc-svn-dir-status-files (dir files default-state callback)
- (apply 'vc-svn-command (current-buffer) 'async nil "status" files)
- (vc-exec-after
- `(vc-svn-after-dir-status (quote ,callback))))
-
-(defun vc-svn-dir-extra-headers (dir)
- "Generate extra status headers for a Subversion working copy."
- (let (process-file-side-effects)
- (vc-svn-command "*vc*" 0 nil "info"))
- (let ((repo
- (save-excursion
- (and (progn
- (set-buffer "*vc*")
- (goto-char (point-min))
- (re-search-forward "Repository Root: *\\(.*\\)" nil t))
- (match-string 1)))))
- (concat
- (cond (repo
- (concat
- (propertize "Repository : " 'face 'font-lock-type-face)
- (propertize repo 'face 'font-lock-variable-name-face)))
- (t "")))))
-
-(defun vc-svn-working-revision (file)
- "SVN-specific version of `vc-working-revision'."
- ;; There is no need to consult RCS headers under SVN, because we
- ;; get the workfile version for free when we recognize that a file
- ;; is registered in SVN.
- (vc-svn-registered file)
- (vc-file-getprop file 'vc-working-revision))
-
-;; vc-svn-mode-line-string doesn't exist because the default implementation
-;; works just fine.
-
-(defun vc-svn-previous-revision (file rev)
- (let ((newrev (1- (string-to-number rev))))
- (when (< 0 newrev)
- (number-to-string newrev))))
-
-(defun vc-svn-next-revision (file rev)
- (let ((newrev (1+ (string-to-number rev))))
- ;; The "working revision" is an uneasy conceptual fit under Subversion;
- ;; we use it as the upper bound until a better idea comes along. If the
- ;; workfile version W coincides with the tree's latest revision R, then
- ;; this check prevents a "no such revision: R+1" error. Otherwise, it
- ;; inhibits showing of W+1 through R, which could be considered anywhere
- ;; from gracious to impolite.
- (unless (< (string-to-number (vc-file-getprop file 'vc-working-revision))
- newrev)
- (number-to-string newrev))))
-
-
-;;;
-;;; State-changing functions
-;;;
-
-(defun vc-svn-create-repo ()
- "Create a new SVN repository."
- (vc-do-command "*vc*" 0 "svnadmin" '("create" "SVN"))
- (vc-do-command "*vc*" 0 vc-svn-program '(".")
- "checkout" (concat "file://" default-directory "SVN")))
-
-(defun vc-svn-register (files &optional rev comment)
- "Register FILES into the SVN version-control system.
-The COMMENT argument is ignored This does an add but not a commit.
-Passes either `vc-svn-register-switches' or `vc-register-switches'
-to the SVN command."
- (apply 'vc-svn-command nil 0 files "add" (vc-switches 'SVN 'register)))
-
-(defun vc-svn-responsible-p (file)
- "Return non-nil if SVN thinks it is responsible for FILE."
- (file-directory-p (expand-file-name vc-svn-admin-directory
- (if (file-directory-p file)
- file
- (file-name-directory file)))))
-
-(defalias 'vc-svn-could-register 'vc-svn-responsible-p
- "Return non-nil if FILE could be registered in SVN.
-This is only possible if SVN is responsible for FILE's directory.")
-
-(defun vc-svn-checkin (files rev comment &optional extra-args-ignored)
- "SVN-specific version of `vc-backend-checkin'."
- (if rev (error "Committing to a specific revision is unsupported in SVN"))
- (let ((status (apply
- 'vc-svn-command nil 1 files "ci"
- (nconc (list "-m" comment) (vc-switches 'SVN 'checkin)))))
- (set-buffer "*vc*")
- (goto-char (point-min))
- (unless (equal status 0)
- ;; Check checkin problem.
- (cond
- ((search-forward "Transaction is out of date" nil t)
- (mapc (lambda (file) (vc-file-setprop file 'vc-state 'needs-merge))
- files)
- (error (substitute-command-keys
- (concat "Up-to-date check failed: "
- "type \\[vc-next-action] to merge in changes"))))
- (t
- (pop-to-buffer (current-buffer))
- (goto-char (point-min))
- (shrink-window-if-larger-than-buffer)
- (error "Check-in failed"))))
- ;; Update file properties
- ;; (vc-file-setprop
- ;; file 'vc-working-revision
- ;; (vc-parse-buffer "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" 2))
- ))
-
-(defun vc-svn-find-revision (file rev buffer)
- "SVN-specific retrieval of a specified version into a buffer."
- (let (process-file-side-effects)
- (apply 'vc-svn-command
- buffer 0 file
- "cat"
- (and rev (not (string= rev ""))
- (concat "-r" rev))
- (vc-switches 'SVN 'checkout))))
-
-(defun vc-svn-checkout (file &optional editable rev)
- (message "Checking out %s..." file)
- (with-current-buffer (or (get-file-buffer file) (current-buffer))
- (vc-svn-update file editable rev (vc-switches 'SVN 'checkout)))
- (vc-mode-line file 'SVN)
- (message "Checking out %s...done" file))
-
-(defun vc-svn-update (file editable rev switches)
- (if (and (file-exists-p file) (not rev))
- ;; If no revision was specified, there's nothing to do.
- nil
- ;; Check out a particular version (or recreate the file).
- (vc-file-setprop file 'vc-working-revision nil)
- (apply 'vc-svn-command nil 0 file
- "--non-interactive" ; bug#4280
- "update"
- (cond
- ((null rev) "-rBASE")
- ((or (eq rev t) (equal rev "")) nil)
- (t (concat "-r" rev)))
- switches)))
-
-(defun vc-svn-delete-file (file)
- (vc-svn-command nil 0 file "remove"))
-
-(defun vc-svn-rename-file (old new)
- (vc-svn-command nil 0 new "move" (file-relative-name old)))
-
-(defun vc-svn-revert (file &optional contents-done)
- "Revert FILE to the version it was based on."
- (unless contents-done
- (vc-svn-command nil 0 file "revert")))
-
-(defun vc-svn-merge (file first-version &optional second-version)
- "Merge changes into current working copy of FILE.
-The changes are between FIRST-VERSION and SECOND-VERSION."
- (vc-svn-command nil 0 file
- "merge"
- "-r" (if second-version
- (concat first-version ":" second-version)
- first-version))
- (vc-file-setprop file 'vc-state 'edited)
- (with-current-buffer (get-buffer "*vc*")
- (goto-char (point-min))
- (if (looking-at "C ")
- 1 ; signal conflict
- 0))) ; signal success
-
-(defun vc-svn-merge-news (file)
- "Merge in any new changes made to FILE."
- (message "Merging changes into %s..." file)
- ;; (vc-file-setprop file 'vc-working-revision nil)
- (vc-file-setprop file 'vc-checkout-time 0)
- (vc-svn-command nil 0 file "update")
- ;; Analyze the merge result reported by SVN, and set
- ;; file properties accordingly.
- (with-current-buffer (get-buffer "*vc*")
- (goto-char (point-min))
- ;; get new working revision
- (if (re-search-forward
- "^\\(Updated to\\|At\\) revision \\([0-9]+\\)" nil t)
- (vc-file-setprop file 'vc-working-revision (match-string 2))
- (vc-file-setprop file 'vc-working-revision nil))
- ;; get file status
- (goto-char (point-min))
- (prog1
- (if (looking-at "At revision")
- 0 ;; there were no news; indicate success
- (if (re-search-forward
- ;; Newer SVN clients have 3 columns of chars (one for the
- ;; file's contents, then second for its properties, and the
- ;; third for lock-grabbing info), before the 2 spaces.
- ;; We also used to match the filename in column 0 without any
- ;; meta-info before it, but I believe this can never happen.
- (concat "^\\(\\([ACGDU]\\)\\(.[B ]\\)? \\)"
- (regexp-quote (file-name-nondirectory file)))
- nil t)
- (cond
- ;; Merge successful, we are in sync with repository now
- ((string= (match-string 2) "U")
- (vc-file-setprop file 'vc-state 'up-to-date)
- (vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file)))
- 0);; indicate success to the caller
- ;; Merge successful, but our own changes are still in the file
- ((string= (match-string 2) "G")
- (vc-file-setprop file 'vc-state 'edited)
- 0);; indicate success to the caller
- ;; Conflicts detected!
- (t
- (vc-file-setprop file 'vc-state 'edited)
- 1);; signal the error to the caller
- )
- (pop-to-buffer "*vc*")
- (error "Couldn't analyze svn update result")))
- (message "Merging changes into %s...done" file))))
-
-(defun vc-svn-modify-change-comment (files rev comment)
- "Modify the change comments for a specified REV.
-You must have ssh access to the repository host, and the directory Emacs
-uses locally for temp files must also be writable by you on that host.
-This is only supported if the repository access method is either file://
-or svn+ssh://."
- (let (tempfile host remotefile directory fileurl-p)
- (with-temp-buffer
- (vc-do-command (current-buffer) 0 vc-svn-program nil "info")
- (goto-char (point-min))
- (unless (re-search-forward "Repository Root: \\(file://\\(/.*\\)\\)\\|\\(svn\\+ssh://\\([^/]+\\)\\(/.*\\)\\)" nil t)
- (error "Repository information is unavailable"))
- (if (match-string 1)
- (progn
- (setq fileurl-p t)
- (setq directory (match-string 2)))
- (setq host (match-string 4))
- (setq directory (match-string 5))
- (setq remotefile (concat host ":" tempfile))))
- (with-temp-file (setq tempfile (make-temp-file user-mail-address))
- (insert comment))
- (if fileurl-p
- ;; Repository Root is a local file.
- (progn
- (unless (vc-do-command
- "*vc*" 0 "svnadmin" nil
- "setlog" "--bypass-hooks" directory
- "-r" rev (format "%s" tempfile))
- (error "Log edit failed"))
- (delete-file tempfile))
-
- ;; Remote repository, using svn+ssh.
- (unless (vc-do-command "*vc*" 0 "scp" nil "-q" tempfile remotefile)
- (error "Copy of comment to %s failed" remotefile))
- (unless (vc-do-command
- "*vc*" 0 "ssh" nil "-q" host
- (format "svnadmin setlog --bypass-hooks %s -r %s %s; rm %s"
- directory rev tempfile tempfile))
- (error "Log edit failed")))))
-
-;;;
-;;; History functions
-;;;
-
-(defvar log-view-per-file-logs)
-
-(define-derived-mode vc-svn-log-view-mode log-view-mode "SVN-Log-View"
- (require 'add-log)
- (set (make-local-variable 'log-view-per-file-logs) nil))
-
-(defun vc-svn-print-log (files buffer &optional shortlog start-revision limit)
- "Get change log(s) associated with FILES."
- (save-current-buffer
- (vc-setup-buffer buffer)
- (let ((inhibit-read-only t))
- (goto-char (point-min))
- (if files
- (dolist (file files)
- (insert "Working file: " file "\n")
- (apply
- 'vc-svn-command
- buffer
- 'async
- ;; (if (and (= (length files) 1) (vc-stay-local-p file 'SVN)) 'async 0)
- (list file)
- "log"
- (append
- (list
- (if start-revision
- (format "-r%s" start-revision)
- ;; By default Subversion only shows the log up to the
- ;; working revision, whereas we also want the log of the
- ;; subsequent commits. At least that's what the
- ;; vc-cvs.el code does.
- "-rHEAD:0"))
- (when limit (list "--limit" (format "%s" limit))))))
- ;; Dump log for the entire directory.
- (apply 'vc-svn-command buffer 0 nil "log"
- (append
- (list
- (if start-revision (format "-r%s" start-revision) "-rHEAD:0"))
- (when limit (list "--limit" (format "%s" limit)))))))))
-
-(defun vc-svn-diff (files &optional oldvers newvers buffer)
- "Get a difference report using SVN between two revisions of fileset FILES."
- (and oldvers
- (not newvers)
- files
- (catch 'no
- (dolist (f files)
- (or (equal oldvers (vc-working-revision f))
- (throw 'no nil)))
- t)
- ;; Use nil rather than the current revision because svn handles
- ;; it better (i.e. locally). Note that if _any_ of the files
- ;; has a different revision, we fetch the lot, which is
- ;; obviously sub-optimal.
- (setq oldvers nil))
- (let* ((switches
- (if vc-svn-diff-switches
- (vc-switches 'SVN 'diff)
- (list "--diff-cmd=diff" "-x"
- (mapconcat 'identity (vc-switches nil 'diff) " "))))
- (async (and (not vc-disable-async-diff)
- (vc-stay-local-p files 'SVN)
- (or oldvers newvers)))) ; Svn diffs those locally.
- (apply 'vc-svn-command buffer
- (if async 'async 0)
- files "diff"
- (append
- switches
- (when oldvers
- (list "-r" (if newvers (concat oldvers ":" newvers)
- oldvers)))))
- (if async 1 ; async diff => pessimistic assumption
- ;; For some reason `svn diff' does not return a useful
- ;; status w.r.t whether the diff was empty or not.
- (buffer-size (get-buffer buffer)))))
-
-;;;
-;;; Tag system
-;;;
-
-(defun vc-svn-create-tag (dir name branchp)
- "Assign to DIR's current revision a given NAME.
-If BRANCHP is non-nil, the name is created as a branch (and the current
-workspace is immediately moved to that new branch).
-NAME is assumed to be a URL."
- (vc-svn-command nil 0 dir "copy" name)
- (when branchp (vc-svn-retrieve-tag dir name nil)))
-
-(defun vc-svn-retrieve-tag (dir name update)
- "Retrieve a tag at and below DIR.
-NAME is the name of the tag; if it is empty, do a `svn update'.
-If UPDATE is non-nil, then update (resynch) any affected buffers.
-NAME is assumed to be a URL."
- (vc-svn-command nil 0 dir "switch" name)
- ;; FIXME: parse the output and obey `update'.
- )
-
-;;;
-;;; Miscellaneous
-;;;
-
-;; Subversion makes backups for us, so don't bother.
-;; (defun vc-svn-make-version-backups-p (file)
-;; "Return non-nil if version backups should be made for FILE."
-;; (vc-stay-local-p file 'SVN))
-
-(defun vc-svn-check-headers ()
- "Check if the current file has any headers in it."
- (save-excursion
- (goto-char (point-min))
- (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
-\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))
-
-
-;;;
-;;; Internal functions
-;;;
-
-(defun vc-svn-command (buffer okstatus file-or-list &rest flags)
- "A wrapper around `vc-do-command' for use in vc-svn.el.
-The difference to vc-do-command is that this function always invokes `svn',
-and that it passes `vc-svn-global-switches' to it before FLAGS."
- (apply 'vc-do-command (or buffer "*vc*") okstatus vc-svn-program file-or-list
- (if (stringp vc-svn-global-switches)
- (cons vc-svn-global-switches flags)
- (append vc-svn-global-switches
- flags))))
-
-(defun vc-svn-repository-hostname (dirname)
- (with-temp-buffer
- (let ((coding-system-for-read
- (or file-name-coding-system
- default-file-name-coding-system)))
- (vc-insert-file (expand-file-name (concat vc-svn-admin-directory
- "/entries")
- dirname)))
- (goto-char (point-min))
- (when (re-search-forward
- ;; Old `svn' used name="svn:this_dir", newer use just name="".
- (concat "name=\"\\(?:svn:this_dir\\)?\"[\n\t ]*"
- "\\(?:[-a-z]+=\"[^\"]*\"[\n\t ]*\\)*?"
- "url=\"\\(?1:[^\"]+\\)\""
- ;; Yet newer ones don't use XML any more.
- "\\|^\ndir\n[0-9]+\n\\(?1:.*\\)") nil t)
- ;; This is not a hostname but a URL. This may actually be considered
- ;; as a feature since it allows vc-svn-stay-local to specify different
- ;; behavior for different modules on the same server.
- (match-string 1))))
-
-(defun vc-svn-resolve-when-done ()
- "Call \"svn resolved\" if the conflict markers have been removed."
- (save-excursion
- (goto-char (point-min))
- (unless (re-search-forward "^<<<<<<< " nil t)
- (vc-svn-command nil 0 buffer-file-name "resolved")
- ;; Remove the hook so that it is not called multiple times.
- (remove-hook 'after-save-hook 'vc-svn-resolve-when-done t))))
-
-;; Inspired by vc-arch-find-file-hook.
-(defun vc-svn-find-file-hook ()
- (when (eq ?C (vc-file-getprop buffer-file-name 'vc-svn-status))
- ;; If the file is marked as "conflicted", then we should try and call
- ;; "svn resolved" when applicable.
- (if (save-excursion
- (goto-char (point-min))
- (re-search-forward "^<<<<<<< " nil t))
- ;; There are conflict markers.
- (progn
- (smerge-start-session)
- (add-hook 'after-save-hook 'vc-svn-resolve-when-done nil t))
- ;; There are no conflict markers. This is problematic: maybe it means
- ;; the conflict has been resolved and we should immediately call "svn
- ;; resolved", or it means that the file's type does not allow Svn to
- ;; use conflict markers in which case we don't really know what to do.
- ;; So let's just punt for now.
- nil)
- (message "There are unresolved conflicts in this file")))
-
-(defun vc-svn-parse-status (&optional filename)
- "Parse output of \"svn status\" command in the current buffer.
-Set file properties accordingly. Unless FILENAME is non-nil, parse only
-information about FILENAME and return its status."
- (let (file status)
- (goto-char (point-min))
- (while (re-search-forward
- ;; Ignore the files with status X.
- "^\\(?:\\?\\|[ ACDGIMR!~][ MC][ L][ +][ S]..\\([ *]\\) +\\([-0-9]+\\) +\\([0-9?]+\\) +\\([^ ]+\\)\\) +" nil t)
- ;; If the username contains spaces, the output format is ambiguous,
- ;; so don't trust the output's filename unless we have to.
- (setq file (or filename
- (expand-file-name
- (buffer-substring (point) (line-end-position)))))
- (setq status (char-after (line-beginning-position)))
- (if (eq status ??)
- (vc-file-setprop file 'vc-state 'unregistered)
- ;; Use the last-modified revision, so that searching in vc-print-log
- ;; output works.
- (vc-file-setprop file 'vc-working-revision (match-string 3))
- ;; Remember Svn's own status.
- (vc-file-setprop file 'vc-svn-status status)
- (vc-file-setprop
- file 'vc-state
- (cond
- ((eq status ?\ )
- (if (eq (char-after (match-beginning 1)) ?*)
- 'needs-update
- (vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file)))
- 'up-to-date))
- ((eq status ?A)
- ;; If the file was actually copied, (match-string 2) is "-".
- (vc-file-setprop file 'vc-working-revision "0")
- (vc-file-setprop file 'vc-checkout-time 0)
- 'added)
- ((eq status ?C)
- (vc-file-setprop file 'vc-state 'conflict))
- ((eq status '?M)
- (if (eq (char-after (match-beginning 1)) ?*)
- 'needs-merge
- 'edited))
- ((eq status ?I)
- (vc-file-setprop file 'vc-state 'ignored))
- ((memq status '(?D ?R))
- (vc-file-setprop file 'vc-state 'removed))
- (t 'edited)))))
- (when filename (vc-file-getprop filename 'vc-state))))
-
-(defun vc-svn-valid-symbolic-tag-name-p (tag)
- "Return non-nil if TAG is a valid symbolic tag name."
- ;; According to the SVN manual, a valid symbolic tag must start with
- ;; an uppercase or lowercase letter and can contain uppercase and
- ;; lowercase letters, digits, `-', and `_'.
- (and (string-match "^[a-zA-Z]" tag)
- (not (string-match "[^a-z0-9A-Z-_]" tag))))
-
-(defun vc-svn-valid-revision-number-p (tag)
- "Return non-nil if TAG is a valid revision number."
- (and (string-match "^[0-9]" tag)
- (not (string-match "[^0-9]" tag))))
-
-;; Support for `svn annotate'
-
-(defun vc-svn-annotate-command (file buf &optional rev)
- (vc-svn-command buf 'async file "annotate" (if rev (concat "-r" rev))))
-
-(defun vc-svn-annotate-time-of-rev (rev)
- ;; Arbitrarily assume 10 commmits per day.
- (/ (string-to-number rev) 10.0))
-
-(defvar vc-annotate-parent-rev)
-
-(defun vc-svn-annotate-current-time ()
- (vc-svn-annotate-time-of-rev vc-annotate-parent-rev))
-
-(defconst vc-svn-annotate-re "[ \t]*\\([0-9]+\\)[ \t]+[^\t ]+ ")
-
-(defun vc-svn-annotate-time ()
- (when (looking-at vc-svn-annotate-re)
- (goto-char (match-end 0))
- (vc-svn-annotate-time-of-rev (match-string 1))))
-
-(defun vc-svn-annotate-extract-revision-at-line ()
- (save-excursion
- (beginning-of-line)
- (if (looking-at vc-svn-annotate-re) (match-string 1))))
-
-(defun vc-svn-revision-table (files)
- (let ((vc-svn-revisions '()))
- (with-current-buffer "*vc*"
- (vc-svn-command nil 0 files "log" "-q")
- (goto-char (point-min))
- (forward-line)
- (let ((start (point-min))
- (loglines (buffer-substring-no-properties (point-min)
- (point-max))))
- (while (string-match "^r\\([0-9]+\\) " loglines)
- (push (match-string 1 loglines) vc-svn-revisions)
- (setq start (+ start (match-end 0)))
- (setq loglines (buffer-substring-no-properties start (point-max)))))
- vc-svn-revisions)))
-
-(provide 'vc-svn)
-
-;; arch-tag: 02f10c68-2b4d-453a-90fc-1eee6cfb268d
-;;; vc-svn.el ends here
+++ /dev/null
-;;; vc.el --- drive a version-control system from within Emacs
-
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
-
-;; Author: FSF (see below for full credits)
-;; Maintainer: Andre Spiegel <spiegel@gnu.org>
-;; Keywords: tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs 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 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Credits:
-
-;; VC was initially designed and implemented by Eric S. Raymond
-;; <esr@thyrsus.com> in 1992. Over the years, many other people have
-;; contributed substantial amounts of work to VC. These include:
-;;
-;; Per Cederqvist <ceder@lysator.liu.se>
-;; Paul Eggert <eggert@twinsun.com>
-;; Sebastian Kremer <sk@thp.uni-koeln.de>
-;; Martin Lorentzson <martinl@gnu.org>
-;; Dave Love <fx@gnu.org>
-;; Stefan Monnier <monnier@cs.yale.edu>
-;; Thien-Thi Nguyen <ttn@gnu.org>
-;; Dan Nicolaescu <dann@ics.uci.edu>
-;; J.D. Smith <jdsmith@alum.mit.edu>
-;; Andre Spiegel <spiegel@gnu.org>
-;; Richard Stallman <rms@gnu.org>
-;;
-;; In July 2007 ESR returned and redesigned the mode to cope better
-;; with modern version-control systems that do commits by fileset
-;; rather than per individual file.
-;;
-;; If you maintain a client of the mode or customize it in your .emacs,
-;; note that some backend functions which formerly took single file arguments
-;; now take a list of files. These include: register, checkin, print-log,
-;; rollback, and diff.
-
-;;; Commentary:
-
-;; This mode is fully documented in the Emacs user's manual.
-;;
-;; Supported version-control systems presently include CVS, RCS, GNU
-;; Arch, Subversion, Bzr, Git, Mercurial, Monotone and SCCS
-;; (or its free replacement, CSSC).
-;;
-;; If your site uses the ChangeLog convention supported by Emacs, the
-;; function `log-edit-comment-to-change-log' could prove a useful checkin hook,
-;; although you might prefer to use C-c C-a (i.e. `log-edit-insert-changelog')
-;; from the commit buffer instead or to set `log-edit-setup-invert'.
-;;
-;; When using SCCS, RCS, CVS: be careful not to do repo surgery, or
-;; operations like registrations and deletions and renames, outside VC
-;; while VC is running. The support for these systems was designed
-;; when disks were much slower, and the code maintains a lot of
-;; internal state in order to reduce expensive operations to a
-;; minimum. Thus, if you mess with the repo while VC's back is turned,
-;; VC may get seriously confused.
-;;
-;; When using Subversion or a later system, anything you do outside VC
-;; *through the VCS tools* should safely interlock with VC
-;; operations. Under these VC does little state caching, because local
-;; operations are assumed to be fast. The dividing line is
-;;
-;; ADDING SUPPORT FOR OTHER BACKENDS
-;;
-;; VC can use arbitrary version control systems as a backend. To add
-;; support for a new backend named SYS, write a library vc-sys.el that
-;; contains functions of the form `vc-sys-...' (note that SYS is in lower
-;; case for the function and library names). VC will use that library if
-;; you put the symbol SYS somewhere into the list of
-;; `vc-handled-backends'. Then, for example, if `vc-sys-registered'
-;; returns non-nil for a file, all SYS-specific versions of VC commands
-;; will be available for that file.
-;;
-;; VC keeps some per-file information in the form of properties (see
-;; vc-file-set/getprop in vc-hooks.el). The backend-specific functions
-;; do not generally need to be aware of these properties. For example,
-;; `vc-sys-working-revision' should compute the working revision and
-;; return it; it should not look it up in the property, and it needn't
-;; store it there either. However, if a backend-specific function does
-;; store a value in a property, that value takes precedence over any
-;; value that the generic code might want to set (check for uses of
-;; the macro `with-vc-properties' in vc.el).
-;;
-;; In the list of functions below, each identifier needs to be prepended
-;; with `vc-sys-'. Some of the functions are mandatory (marked with a
-;; `*'), others are optional (`-').
-;;
-;; BACKEND PROPERTIES
-;;
-;; * revision-granularity
-;;
-;; Takes no arguments. Returns either 'file or 'repository. Backends
-;; that return 'file have per-file revision numbering; backends
-;; that return 'repository have per-repository revision numbering,
-;; so a revision level implicitly identifies a changeset
-;;
-;; STATE-QUERYING FUNCTIONS
-;;
-;; * registered (file)
-;;
-;; Return non-nil if FILE is registered in this backend. Both this
-;; function as well as `state' should be careful to fail gracefully
-;; in the event that the backend executable is absent. It is
-;; preferable that this function's body is autoloaded, that way only
-;; calling vc-registered does not cause the backend to be loaded
-;; (all the vc-FOO-registered functions are called to try to find
-;; the controlling backend for FILE.
-;;
-;; * state (file)
-;;
-;; Return the current version control state of FILE. For a list of
-;; possible values, see `vc-state'. This function should do a full and
-;; reliable state computation; it is usually called immediately after
-;; C-x v v. If you want to use a faster heuristic when visiting a
-;; file, put that into `state-heuristic' below. Note that under most
-;; VCSes this won't be called at all, dir-status is used instead.
-;;
-;; - state-heuristic (file)
-;;
-;; If provided, this function is used to estimate the version control
-;; state of FILE at visiting time. It should be considerably faster
-;; than the implementation of `state'. For a list of possible values,
-;; see the doc string of `vc-state'.
-;;
-;; - dir-status (dir update-function)
-;;
-;; Produce RESULT: a list of lists of the form (FILE VC-STATE EXTRA)
-;; for the files in DIR.
-;; EXTRA can be used for backend specific information about FILE.
-;; If a command needs to be run to compute this list, it should be
-;; run asynchronously using (current-buffer) as the buffer for the
-;; command. When RESULT is computed, it should be passed back by
-;; doing: (funcall UPDATE-FUNCTION RESULT nil).
-;; If the backend uses a process filter, hence it produces partial results,
-;; they can be passed back by doing:
-;; (funcall UPDATE-FUNCTION RESULT t)
-;; and then do a (funcall UPDATE-FUNCTION RESULT nil)
-;; when all the results have been computed.
-;; To provide more backend specific functionality for `vc-dir'
-;; the following functions might be needed: `dir-extra-headers',
-;; `dir-printer', `extra-dir-menu' and `dir-status-files'.
-;;
-;; - dir-status-files (dir files default-state update-function)
-;;
-;; This function is identical to dir-status except that it should
-;; only report status for the specified FILES. Also it needs to
-;; report on all requested files, including up-to-date or ignored
-;; files. If not provided, the default is to consider that the files
-;; are in DEFAULT-STATE.
-;;
-;; - dir-extra-headers (dir)
-;;
-;; Return a string that will be added to the *vc-dir* buffer header.
-;;
-;; - dir-printer (fileinfo)
-;;
-;; Pretty print the `vc-dir-fileinfo' FILEINFO.
-;; If a backend needs to show more information than the default FILE
-;; and STATE in the vc-dir listing, it can store that extra
-;; information in `vc-dir-fileinfo->extra'. This function can be
-;; used to display that extra information in the *vc-dir* buffer.
-;;
-;; - status-fileinfo-extra (file)
-;;
-;; Compute `vc-dir-fileinfo->extra' for FILE.
-;;
-;; * working-revision (file)
-;;
-;; Return the working revision of FILE. This is the revision fetched
-;; by the last checkout or upate, not necessarily the same thing as the
-;; head or tip revision. Should return "0" for a file added but not yet
-;; committed.
-;;
-;; - latest-on-branch-p (file)
-;;
-;; Return non-nil if the working revision of FILE is the latest revision
-;; on its branch (many VCSes call this the 'tip' or 'head' revision).
-;; The default implementation always returns t, which means that
-;; working with non-current revisions is not supported by default.
-;;
-;; * checkout-model (files)
-;;
-;; Indicate whether FILES need to be "checked out" before they can be
-;; edited. See `vc-checkout-model' for a list of possible values.
-;;
-;; - workfile-unchanged-p (file)
-;;
-;; Return non-nil if FILE is unchanged from the working revision.
-;; This function should do a brief comparison of FILE's contents
-;; with those of the repository copy of the working revision. If
-;; the backend does not have such a brief-comparison feature, the
-;; default implementation of this function can be used, which
-;; delegates to a full vc-BACKEND-diff. (Note that vc-BACKEND-diff
-;; must not run asynchronously in this case, see variable
-;; `vc-disable-async-diff'.)
-;;
-;; - mode-line-string (file)
-;;
-;; If provided, this function should return the VC-specific mode
-;; line string for FILE. The returned string should have a
-;; `help-echo' property which is the text to be displayed as a
-;; tooltip when the mouse hovers over the VC entry on the mode-line.
-;; The default implementation deals well with all states that
-;; `vc-state' can return.
-;;
-;; STATE-CHANGING FUNCTIONS
-;;
-;; * create-repo (backend)
-;;
-;; Create an empty repository in the current directory and initialize
-;; it so VC mode can add files to it. For file-oriented systems, this
-;; need do no more than create a subdirectory with the right name.
-;;
-;; * register (files &optional rev comment)
-;;
-;; Register FILES in this backend. Optionally, an initial revision REV
-;; and an initial description of the file, COMMENT, may be specified,
-;; but it is not guaranteed that the backend will do anything with this.
-;; The implementation should pass the value of vc-register-switches
-;; to the backend command. (Note: in older versions of VC, this
-;; command took a single file argument and not a list.)
-;;
-;; - init-revision (file)
-;;
-;; The initial revision to use when registering FILE if one is not
-;; specified by the user. If not provided, the variable
-;; vc-default-init-revision is used instead.
-;;
-;; - responsible-p (file)
-;;
-;; Return non-nil if this backend considers itself "responsible" for
-;; FILE, which can also be a directory. This function is used to find
-;; out what backend to use for registration of new files and for things
-;; like change log generation. The default implementation always
-;; returns nil.
-;;
-;; - could-register (file)
-;;
-;; Return non-nil if FILE could be registered under this backend. The
-;; default implementation always returns t.
-;;
-;; - receive-file (file rev)
-;;
-;; Let this backend "receive" a file that is already registered under
-;; another backend. The default implementation simply calls `register'
-;; for FILE, but it can be overridden to do something more specific,
-;; e.g. keep revision numbers consistent or choose editing modes for
-;; FILE that resemble those of the other backend.
-;;
-;; - unregister (file)
-;;
-;; Unregister FILE from this backend. This is only needed if this
-;; backend may be used as a "more local" backend for temporary editing.
-;;
-;; * checkin (files rev comment)
-;;
-;; Commit changes in FILES to this backend. REV is a historical artifact
-;; and should be ignored. COMMENT is used as a check-in comment.
-;; The implementation should pass the value of vc-checkin-switches to
-;; the backend command.
-;;
-;; * find-revision (file rev buffer)
-;;
-;; Fetch revision REV of file FILE and put it into BUFFER.
-;; If REV is the empty string, fetch the head of the trunk.
-;; The implementation should pass the value of vc-checkout-switches
-;; to the backend command.
-;;
-;; * checkout (file &optional editable rev)
-;;
-;; Check out revision REV of FILE into the working area. If EDITABLE
-;; is non-nil, FILE should be writable by the user and if locking is
-;; used for FILE, a lock should also be set. If REV is non-nil, that
-;; is the revision to check out (default is the working revision).
-;; If REV is t, that means to check out the head of the current branch;
-;; if it is the empty string, check out the head of the trunk.
-;; The implementation should pass the value of vc-checkout-switches
-;; to the backend command.
-;;
-;; * revert (file &optional contents-done)
-;;
-;; Revert FILE back to the working revision. If optional
-;; arg CONTENTS-DONE is non-nil, then the contents of FILE have
-;; already been reverted from a version backup, and this function
-;; only needs to update the status of FILE within the backend.
-;; If FILE is in the `added' state it should be returned to the
-;; `unregistered' state.
-;;
-;; - rollback (files)
-;;
-;; Remove the tip revision of each of FILES from the repository. If
-;; this function is not provided, trying to cancel a revision is
-;; caught as an error. (Most backends don't provide it.) (Also
-;; note that older versions of this backend command were called
-;; 'cancel-version' and took a single file arg, not a list of
-;; files.)
-;;
-;; - merge (file rev1 rev2)
-;;
-;; Merge the changes between REV1 and REV2 into the current working file.
-;;
-;; - merge-news (file)
-;;
-;; Merge recent changes from the current branch into FILE.
-;;
-;; - steal-lock (file &optional revision)
-;;
-;; Steal any lock on the working revision of FILE, or on REVISION if
-;; that is provided. This function is only needed if locking is
-;; used for files under this backend, and if files can indeed be
-;; locked by other users.
-;;
-;; - modify-change-comment (files rev comment)
-;;
-;; Modify the change comments associated with the files at the
-;; given revision. This is optional, many backends do not support it.
-;;
-;; - mark-resolved (files)
-;;
-;; Mark conflicts as resolved. Some VC systems need to run a
-;; command to mark conflicts as resolved.
-;;
-;; HISTORY FUNCTIONS
-;;
-;; * print-log (files buffer &optional shortlog start-revision limit)
-;;
-;; Insert the revision log for FILES into BUFFER.
-;; If SHORTLOG is true insert a short version of the log.
-;; If LIMIT is true insert only insert LIMIT log entries. If the
-;; backend does not support limiting the number of entries to show
-;; it should return `limit-unsupported'.
-;; If START-REVISION is given, then show the log starting from the
-;; revision. At this point START-REVISION is only required to work
-;; in conjunction with LIMIT = 1.
-;;
-;; * log-outgoing (backend remote-location)
-;;
-;; Insert in BUFFER the revision log for the changes that will be
-;; sent when performing a push operation to REMOTE-LOCATION.
-;;
-;; * log-incoming (backend remote-location)
-;;
-;; Insert in BUFFER the revision log for the changes that will be
-;; received when performing a pull operation from REMOTE-LOCATION.
-;;
-;; - log-view-mode ()
-;;
-;; Mode to use for the output of print-log. This defaults to
-;; `log-view-mode' and is expected to be changed (if at all) to a derived
-;; mode of `log-view-mode'.
-;;
-;; - show-log-entry (revision)
-;;
-;; If provided, search the log entry for REVISION in the current buffer,
-;; and make sure it is displayed in the buffer's window. The default
-;; implementation of this function works for RCS-style logs.
-;;
-;; - comment-history (file)
-;;
-;; Return a string containing all log entries that were made for FILE.
-;; This is used for transferring a file from one backend to another,
-;; retaining comment information.
-;;
-;; - update-changelog (files)
-;;
-;; Using recent log entries, create ChangeLog entries for FILES, or for
-;; all files at or below the default-directory if FILES is nil. The
-;; default implementation runs rcs2log, which handles RCS- and
-;; CVS-style logs.
-;;
-;; * diff (files &optional rev1 rev2 buffer)
-;;
-;; Insert the diff for FILE into BUFFER, or the *vc-diff* buffer if
-;; BUFFER is nil. If REV1 and REV2 are non-nil, report differences
-;; from REV1 to REV2. If REV1 is nil, use the working revision (as
-;; found in the repository) as the older revision; if REV2 is nil,
-;; use the current working-copy contents as the newer revision. This
-;; function should pass the value of (vc-switches BACKEND 'diff) to
-;; the backend command. It should return a status of either 0 (no
-;; differences found), or 1 (either non-empty diff or the diff is
-;; run asynchronously).
-;;
-;; - revision-completion-table (files)
-;;
-;; Return a completion table for existing revisions of FILES.
-;; The default is to not use any completion table.
-;;
-;; - annotate-command (file buf &optional rev)
-;;
-;; If this function is provided, it should produce an annotated display
-;; of FILE in BUF, relative to revision REV. Annotation means each line
-;; of FILE displayed is prefixed with version information associated with
-;; its addition (deleted lines leave no history) and that the text of the
-;; file is fontified according to age.
-;;
-;; - annotate-time ()
-;;
-;; Only required if `annotate-command' is defined for the backend.
-;; Return the time of the next line of annotation at or after point,
-;; as a floating point fractional number of days. The helper
-;; function `vc-annotate-convert-time' may be useful for converting
-;; multi-part times as returned by `current-time' and `encode-time'
-;; to this format. Return nil if no more lines of annotation appear
-;; in the buffer. You can safely assume that point is placed at the
-;; beginning of each line, starting at `point-min'. The buffer that
-;; point is placed in is the Annotate output, as defined by the
-;; relevant backend. This function also affects how much of the line
-;; is fontified; where it leaves point is where fontification begins.
-;;
-;; - annotate-current-time ()
-;;
-;; Only required if `annotate-command' is defined for the backend,
-;; AND you'd like the current time considered to be anything besides
-;; (vc-annotate-convert-time (current-time)) -- i.e. the current
-;; time with hours, minutes, and seconds included. Probably safe to
-;; ignore. Return the current-time, in units of fractional days.
-;;
-;; - annotate-extract-revision-at-line ()
-;;
-;; Only required if `annotate-command' is defined for the backend.
-;; Invoked from a buffer in vc-annotate-mode, return the revision
-;; corresponding to the current line, or nil if there is no revision
-;; corresponding to the current line.
-;; If the backend supports annotating through copies and renames,
-;; and displays a file name and a revision, then return a cons
-;; (REVISION . FILENAME).
-;;
-;; TAG SYSTEM
-;;
-;; - create-tag (dir name branchp)
-;;
-;; Attach the tag NAME to the state of the working copy. This
-;; should make sure that files are up-to-date before proceeding with
-;; the action. DIR can also be a file and if BRANCHP is specified,
-;; NAME should be created as a branch and DIR should be checked out
-;; under this new branch. The default implementation does not
-;; support branches but does a sanity check, a tree traversal and
-;; assigns the tag to each file.
-;;
-;; - retrieve-tag (dir name update)
-;;
-;; Retrieve the version tagged by NAME of all registered files at or below DIR.
-;; If UPDATE is non-nil, then update buffers of any files in the
-;; tag that are currently visited. The default implementation
-;; does a sanity check whether there aren't any uncommitted changes at
-;; or below DIR, and then performs a tree walk, using the `checkout'
-;; function to retrieve the corresponding revisions.
-;;
-;; MISCELLANEOUS
-;;
-;; - make-version-backups-p (file)
-;;
-;; Return non-nil if unmodified repository revisions of FILE should be
-;; backed up locally. If this is done, VC can perform `diff' and
-;; `revert' operations itself, without calling the backend system. The
-;; default implementation always returns nil.
-;;
-;; - root (file)
-;; Return the root of the VC controlled hierarchy for file.
-;;
-;; - repository-hostname (dirname)
-;;
-;; Return the hostname that the backend will have to contact
-;; in order to operate on a file in DIRNAME. If the return value
-;; is nil, it means that the repository is local.
-;; This function is used in `vc-stay-local-p' which backends can use
-;; for their convenience.
-;;
-;; - previous-revision (file rev)
-;;
-;; Return the revision number that precedes REV for FILE, or nil if no such
-;; revision exists.
-;;
-;; - next-revision (file rev)
-;;
-;; Return the revision number that follows REV for FILE, or nil if no such
-;; revision exists.
-;;
-;; - log-edit-mode ()
-;;
-;; Turn on the mode used for editing the check in log. This
-;; defaults to `log-edit-mode'. If changed, it should use a mode
-;; derived from`log-edit-mode'.
-;;
-;; - check-headers ()
-;;
-;; Return non-nil if the current buffer contains any version headers.
-;;
-;; - clear-headers ()
-;;
-;; In the current buffer, reset all version headers to their unexpanded
-;; form. This function should be provided if the state-querying code
-;; for this backend uses the version headers to determine the state of
-;; a file. This function will then be called whenever VC changes the
-;; version control state in such a way that the headers would give
-;; wrong information.
-;;
-;; - delete-file (file)
-;;
-;; Delete FILE and mark it as deleted in the repository. If this
-;; function is not provided, the command `vc-delete-file' will
-;; signal an error.
-;;
-;; - rename-file (old new)
-;;
-;; Rename file OLD to NEW, both in the working area and in the
-;; repository. If this function is not provided, the renaming
-;; will be done by (vc-delete-file old) and (vc-register new).
-;;
-;; - find-file-hook ()
-;;
-;; Operation called in current buffer when opening a file. This can
-;; be used by the backend to setup some local variables it might need.
-;;
-;; - extra-menu ()
-;;
-;; Return a menu keymap, the items in the keymap will appear at the
-;; end of the Version Control menu. The goal is to allow backends
-;; to specify extra menu items that appear in the VC menu. This way
-;; you can provide menu entries for functionality that is specific
-;; to your backend and which does not map to any of the VC generic
-;; concepts.
-;;
-;; - extra-dir-menu ()
-;;
-;; Return a menu keymap, the items in the keymap will appear at the
-;; end of the VC Status menu. The goal is to allow backends to
-;; specify extra menu items that appear in the VC Status menu. This
-;; makes it possible to provide menu entries for functionality that
-;; is specific to a backend and which does not map to any of the VC
-;; generic concepts.
-;;
-;; - conflicted-files (dir)
-;;
-;; Return the list of files where conflict resolution is needed in
-;; the project that contains DIR.
-;; FIXME: what should it do with non-text conflicts?
-
-;;; Todo:
-
-;; - Get rid of the "master file" terminology.
-
-;; - Add key-binding for vc-delete-file.
-
-;;;; New Primitives:
-;;
-;; - deal with push/pull operations.
-;;
-;; - add a mechanism for editing the underlying VCS's list of files
-;; to be ignored, when that's possible.
-;;
-;;;; Primitives that need changing:
-;;
-;; - vc-update/vc-merge should deal with VC systems that don't
-;; update/merge on a file basis, but on a whole repository basis.
-;; vc-update and vc-merge assume the arguments are always files,
-;; they don't deal with directories. Make sure the *vc-dir* buffer
-;; is updated after these operations.
-;; At least bzr, git and hg should benefit from this.
-;;
-;;;; Improved branch and tag handling:
-;;
-;; - add a generic mechanism for remembering the current branch names,
-;; display the branch name in the mode-line. Replace
-;; vc-cvs-sticky-tag with that.
-;;
-;;;; Internal cleanups:
-;;
-;; - backends that care about vc-stay-local should try to take it into
-;; account for vc-dir. Is this likely to be useful??? YES!
-;;
-;; - vc-expand-dirs should take a backend parameter and only look for
-;; files managed by that backend.
-;;
-;; - Another important thing: merge all the status-like backend operations.
-;; We should remove dir-status, state, and dir-status-files, and
-;; replace them with just `status' which takes a fileset and a continuation
-;; (like dir-status) and returns a buffer in which the process(es) are run
-;; (or nil if it worked synchronously). Hopefully we can define the old
-;; 4 operations in term of this one.
-;;
-;;;; Other
-;;
-;; - when a file is in `conflict' state, turn on smerge-mode.
-;;
-;; - figure out what to do with conflicts that are not caused by the
-;; file contents, but by metadata or other causes. Example: File A
-;; gets renamed to B in one branch and to C in another and you merge
-;; the two branches. Or you locally add file FOO and then pull a
-;; change that also adds a new file FOO, ...
-;;
-;; - make it easier to write logs. Maybe C-x 4 a should add to the log
-;; buffer, if one is present, instead of adding to the ChangeLog.
-;;
-;; - When vc-next-action calls vc-checkin it could pre-fill the
-;; *VC-log* buffer with some obvious items: the list of files that
-;; were added, the list of files that were removed. If the diff is
-;; available, maybe it could even call something like
-;; `diff-add-change-log-entries-other-window' to create a detailed
-;; skeleton for the log...
-;;
-;; - most vc-dir backends need more work. They might need to
-;; provide custom headers, use the `extra' field and deal with all
-;; possible VC states.
-;;
-;; - add a function that calls vc-dir to `find-directory-functions'.
-;;
-;; - vc-diff, vc-annotate, etc. need to deal better with unregistered
-;; files. Now that unregistered and ignored files are shown in
-;; vc-dir, it is possible that these commands are called
-;; for unregistered/ignored files.
-;;
-;; - vc-next-action needs work in order to work with multiple
-;; backends: `vc-state' returns the state for the default backend,
-;; not for the backend in the current *vc-dir* buffer.
-;;
-;; - vc-dir-kill-dir-status-process should not be specific to dir-status,
-;; it should work for other async commands done through vc-do-command
-;; as well,
-;;
-;; - vc-dir toolbar needs more icons.
-;;
-;; - The backends should avoid using `vc-file-setprop' and `vc-file-getprop'.
-;;
-;;; Code:
-
-(require 'vc-hooks)
-(require 'vc-dispatcher)
-
-(eval-when-compile
- (require 'cl)
- (require 'dired))
-
-(unless (assoc 'vc-parent-buffer minor-mode-alist)
- (setq minor-mode-alist
- (cons '(vc-parent-buffer vc-parent-buffer-name)
- minor-mode-alist)))
-
-;; General customization
-
-(defgroup vc nil
- "Version-control system in Emacs."
- :group 'tools)
-
-(defcustom vc-initial-comment nil
- "If non-nil, prompt for initial comment when a file is registered."
- :type 'boolean
- :group 'vc)
-
-(defcustom vc-default-init-revision "1.1"
- "A string used as the default revision number when a new file is registered.
-This can be overridden by giving a prefix argument to \\[vc-register]. This
-can also be overridden by a particular VC backend."
- :type 'string
- :group 'vc
- :version "20.3")
-
-(defcustom vc-checkin-switches nil
- "A string or list of strings specifying extra switches for checkin.
-These are passed to the checkin program by \\[vc-checkin]."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List"
- :value ("")
- string))
- :group 'vc)
-
-(defcustom vc-checkout-switches nil
- "A string or list of strings specifying extra switches for checkout.
-These are passed to the checkout program by \\[vc-checkout]."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List"
- :value ("")
- string))
- :group 'vc)
-
-(defcustom vc-register-switches nil
- "A string or list of strings; extra switches for registering a file.
-These are passed to the checkin program by \\[vc-register]."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List"
- :value ("")
- string))
- :group 'vc)
-
-(defcustom vc-diff-switches nil
- "A string or list of strings specifying switches for diff under VC.
-When running diff under a given BACKEND, VC uses the first
-non-nil value of `vc-BACKEND-diff-switches', `vc-diff-switches',
-and `diff-switches', in that order. Since nil means to check the
-next variable in the sequence, either of the first two may use
-the value t to mean no switches at all. `vc-diff-switches'
-should contain switches that are specific to version control, but
-not specific to any particular backend."
- :type '(choice (const :tag "Unspecified" nil)
- (const :tag "None" t)
- (string :tag "Argument String")
- (repeat :tag "Argument List" :value ("") string))
- :group 'vc
- :version "21.1")
-
-(defcustom vc-diff-knows-L nil
- "Indicates whether diff understands the -L option.
-The value is either `yes', `no', or nil. If it is nil, VC tries
-to use -L and sets this variable to remember whether it worked."
- :type '(choice (const :tag "Work out" nil) (const yes) (const no))
- :group 'vc)
-
-(defcustom vc-log-show-limit 2000
- "Limit the number of items shown by the VC log commands.
-Zero means unlimited.
-Not all VC backends are able to support this feature."
- :type 'integer
- :group 'vc)
-
-(defcustom vc-allow-async-revert nil
- "Specifies whether the diff during \\[vc-revert] may be asynchronous.
-Enabling this option means that you can confirm a revert operation even
-if the local changes in the file have not been found and displayed yet."
- :type '(choice (const :tag "No" nil)
- (const :tag "Yes" t))
- :group 'vc
- :version "22.1")
-
-;;;###autoload
-(defcustom vc-checkout-hook nil
- "Normal hook (list of functions) run after checking out a file.
-See `run-hooks'."
- :type 'hook
- :group 'vc
- :version "21.1")
-
-;;;###autoload
-(defcustom vc-checkin-hook nil
- "Normal hook (list of functions) run after commit or file checkin.
-See also `log-edit-done-hook'."
- :type 'hook
- :options '(log-edit-comment-to-change-log)
- :group 'vc)
-
-;;;###autoload
-(defcustom vc-before-checkin-hook nil
- "Normal hook (list of functions) run before a commit or a file checkin.
-See `run-hooks'."
- :type 'hook
- :group 'vc)
-
-;; Header-insertion hair
-
-(defcustom vc-static-header-alist
- '(("\\.c\\'" .
- "\n#ifndef lint\nstatic char vcid[] = \"\%s\";\n#endif /* lint */\n"))
- "Associate static header string templates with file types.
-A \%s in the template is replaced with the first string associated with
-the file's version control type in `vc-header-alist'."
- :type '(repeat (cons :format "%v"
- (regexp :tag "File Type")
- (string :tag "Header String")))
- :group 'vc)
-
-(defcustom vc-comment-alist
- '((nroff-mode ".\\\"" ""))
- "Special comment delimiters for generating VC headers.
-Add an entry in this list if you need to override the normal `comment-start'
-and `comment-end' variables. This will only be necessary if the mode language
-is sensitive to blank lines."
- :type '(repeat (list :format "%v"
- (symbol :tag "Mode")
- (string :tag "Comment Start")
- (string :tag "Comment End")))
- :group 'vc)
-
-(defcustom vc-checkout-carefully (= (user-uid) 0)
- "Non-nil means be extra-careful in checkout.
-Verify that the file really is not locked
-and that its contents match what the repository version says."
- :type 'boolean
- :group 'vc)
-(make-obsolete-variable 'vc-checkout-carefully
- "the corresponding checks are always done now."
- "21.1")
-
-\f
-;; Variables users don't need to see
-
-(defvar vc-disable-async-diff nil
- "VC sets this to t locally to disable some async diff operations.
-Backends that offer asynchronous diffs should respect this variable
-in their implementation of vc-BACKEND-diff.")
-
-;; File property caching
-
-(defun vc-clear-context ()
- "Clear all cached file properties."
- (interactive)
- (fillarray vc-file-prop-obarray 0))
-
-(defmacro with-vc-properties (files form settings)
- "Execute FORM, then maybe set per-file properties for FILES.
-If any of FILES is actually a directory, then do the same for all
-buffers for files in that directory.
-SETTINGS is an association list of property/value pairs. After
-executing FORM, set those properties from SETTINGS that have not yet
-been updated to their corresponding values."
- (declare (debug t))
- `(let ((vc-touched-properties (list t))
- (flist nil))
- (dolist (file ,files)
- (if (file-directory-p file)
- (dolist (buffer (buffer-list))
- (let ((fname (buffer-file-name buffer)))
- (when (and fname (vc-string-prefix-p file fname))
- (push fname flist))))
- (push file flist)))
- ,form
- (dolist (file flist)
- (dolist (setting ,settings)
- (let ((property (car setting)))
- (unless (memq property vc-touched-properties)
- (put (intern file vc-file-prop-obarray)
- property (cdr setting))))))))
-
-;;; Code for deducing what fileset and backend to assume
-
-(defun vc-backend-for-registration (file)
- "Return a backend that can be used for registering FILE.
-
-If no backend declares itself responsible for FILE, then FILE
-must not be in a version controlled directory, so try to create a
-repository, prompting for the directory and the VC backend to
-use."
- (catch 'found
- ;; First try: find a responsible backend, it must be a backend
- ;; under which FILE is not yet registered.
- (dolist (backend vc-handled-backends)
- (and (not (vc-call-backend backend 'registered file))
- (vc-call-backend backend 'responsible-p file)
- (throw 'found backend)))
- ;; no responsible backend
- (let* ((possible-backends
- (let (pos)
- (dolist (crt vc-handled-backends)
- (when (vc-find-backend-function crt 'create-repo)
- (push crt pos)))
- pos))
- (bk
- (intern
- ;; Read the VC backend from the user, only
- ;; complete with the backends that have the
- ;; 'create-repo method.
- (completing-read
- (format "%s is not in a version controlled directory.\nUse VC backend: " file)
- (mapcar 'symbol-name possible-backends) nil t)))
- (repo-dir
- (let ((def-dir (file-name-directory file)))
- ;; read the directory where to create the
- ;; repository, make sure it's a parent of
- ;; file.
- (read-file-name
- (format "create %s repository in: " bk)
- default-directory def-dir t nil
- (lambda (arg)
- (message "arg %s" arg)
- (and (file-directory-p arg)
- (vc-string-prefix-p (expand-file-name arg) def-dir)))))))
- (let ((default-directory repo-dir))
- (vc-call-backend bk 'create-repo))
- (throw 'found bk))))
-
-(defun vc-responsible-backend (file)
- "Return the name of a backend system that is responsible for FILE.
-
-If FILE is already registered, return the
-backend of FILE. If FILE is not registered, then the
-first backend in `vc-handled-backends' that declares itself
-responsible for FILE is returned."
- (or (and (not (file-directory-p file)) (vc-backend file))
- (catch 'found
- ;; First try: find a responsible backend. If this is for registration,
- ;; it must be a backend under which FILE is not yet registered.
- (dolist (backend vc-handled-backends)
- (and (vc-call-backend backend 'responsible-p file)
- (throw 'found backend))))
- (error "No VC backend is responsible for %s" file)))
-
-(defun vc-expand-dirs (file-or-dir-list)
- "Expands directories in a file list specification.
-Within directories, only files already under version control are noticed."
- (let ((flattened '()))
- (dolist (node file-or-dir-list)
- (when (file-directory-p node)
- (vc-file-tree-walk
- node (lambda (f) (when (vc-backend f) (push f flattened)))))
- (unless (file-directory-p node) (push node flattened)))
- (nreverse flattened)))
-
-(defvar vc-dir-backend)
-
-(declare-function vc-dir-current-file "vc-dir" ())
-(declare-function vc-dir-deduce-fileset "vc-dir" (&optional state-model-only-files))
-
-(defun vc-deduce-fileset (&optional observer allow-unregistered
- state-model-only-files)
- "Deduce a set of files and a backend to which to apply an operation.
-
-Return (BACKEND FILESET FILESET-ONLY-FILES STATE CHECKOUT-MODEL).
-If we're in VC-dir mode, the fileset is the list of marked files.
-Otherwise, if we're looking at a buffer visiting a version-controlled file,
-the fileset is a singleton containing this file.
-If none of these conditions is met, but ALLOW_UNREGISTERED is on and the
-visited file is not registered, return a singleton fileset containing it.
-Otherwise, throw an error.
-
-STATE-MODEL-ONLY-FILES if non-nil, means that the caller needs
-the FILESET-ONLY-FILES STATE and MODEL info. Otherwise, that
-part may be skipped.
-BEWARE: this function may change the
-current buffer."
- ;; FIXME: OBSERVER is unused. The name is not intuitive and is not
- ;; documented. It's set to t when called from diff and print-log.
- (let (backend)
- (cond
- ((derived-mode-p 'vc-dir-mode)
- (vc-dir-deduce-fileset state-model-only-files))
- ((derived-mode-p 'dired-mode)
- (if observer
- (vc-dired-deduce-fileset)
- (error "State changing VC operations not supported in `dired-mode'")))
- ((setq backend (vc-backend buffer-file-name))
- (if state-model-only-files
- (list backend (list buffer-file-name)
- (list buffer-file-name)
- (vc-state buffer-file-name)
- (vc-checkout-model backend buffer-file-name))
- (list backend (list buffer-file-name))))
- ((and (buffer-live-p vc-parent-buffer)
- ;; FIXME: Why this test? --Stef
- (or (buffer-file-name vc-parent-buffer)
- (with-current-buffer vc-parent-buffer
- (derived-mode-p 'vc-dir-mode))))
- (progn ;FIXME: Why not `with-current-buffer'? --Stef.
- (set-buffer vc-parent-buffer)
- (vc-deduce-fileset observer allow-unregistered state-model-only-files)))
- ((not buffer-file-name)
- (error "Buffer %s is not associated with a file" (buffer-name)))
- ((and allow-unregistered (not (vc-registered buffer-file-name)))
- (if state-model-only-files
- (list (vc-backend-for-registration (buffer-file-name))
- (list buffer-file-name)
- (list buffer-file-name)
- (when state-model-only-files 'unregistered)
- nil)
- (list (vc-backend-for-registration (buffer-file-name))
- (list buffer-file-name))))
- (t (error "No fileset is available here")))))
-
-(defun vc-dired-deduce-fileset ()
- (let ((backend (vc-responsible-backend default-directory)))
- (unless backend (error "Directory not under VC"))
- (list backend
- (dired-map-over-marks (dired-get-filename nil t) nil))))
-
-(defun vc-ensure-vc-buffer ()
- "Make sure that the current buffer visits a version-controlled file."
- (cond
- ((derived-mode-p 'vc-dir-mode)
- (set-buffer (find-file-noselect (vc-dir-current-file))))
- (t
- (while (and vc-parent-buffer
- (buffer-live-p vc-parent-buffer)
- ;; Avoid infinite looping when vc-parent-buffer and
- ;; current buffer are the same buffer.
- (not (eq vc-parent-buffer (current-buffer))))
- (set-buffer vc-parent-buffer))
- (if (not buffer-file-name)
- (error "Buffer %s is not associated with a file" (buffer-name))
- (unless (vc-backend buffer-file-name)
- (error "File %s is not under version control" buffer-file-name))))))
-
-;;; Support for the C-x v v command.
-;; This is where all the single-file-oriented code from before the fileset
-;; rewrite lives.
-
-(defsubst vc-editable-p (file)
- "Return non-nil if FILE can be edited."
- (let ((backend (vc-backend file)))
- (and backend
- (or (eq (vc-checkout-model backend (list file)) 'implicit)
- (memq (vc-state file) '(edited needs-merge conflict))))))
-
-(defun vc-compatible-state (p q)
- "Controls which states can be in the same commit."
- (or
- (eq p q)
- (and (member p '(edited added removed)) (member q '(edited added removed)))))
-
-;; Here's the major entry point.
-
-;;;###autoload
-(defun vc-next-action (verbose)
- "Do the next logical version control operation on the current fileset.
-This requires that all files in the fileset be in the same state.
-
-For locking systems:
- If every file is not already registered, this registers each for version
-control.
- If every file is registered and not locked by anyone, this checks out
-a writable and locked file of each ready for editing.
- If every file is checked out and locked by the calling user, this
-first checks to see if each file has changed since checkout. If not,
-it performs a revert on that file.
- If every file has been changed, this pops up a buffer for entry
-of a log message; when the message has been entered, it checks in the
-resulting changes along with the log message as change commentary. If
-the variable `vc-keep-workfiles' is non-nil (which is its default), a
-read-only copy of each changed file is left in place afterwards.
- If the affected file is registered and locked by someone else, you are
-given the option to steal the lock(s).
-
-For merging systems:
- If every file is not already registered, this registers each one for version
-control. This does an add, but not a commit.
- If every file is added but not committed, each one is committed.
- If every working file is changed, but the corresponding repository file is
-unchanged, this pops up a buffer for entry of a log message; when the
-message has been entered, it checks in the resulting changes along
-with the logmessage as change commentary. A writable file is retained.
- If the repository file is changed, you are asked if you want to
-merge in the changes into your working copy."
- (interactive "P")
- (let* ((vc-fileset (vc-deduce-fileset nil t 'state-model-only-files))
- (backend (car vc-fileset))
- (files (nth 1 vc-fileset))
- (fileset-only-files (nth 2 vc-fileset))
- ;; FIXME: We used to call `vc-recompute-state' here.
- (state (nth 3 vc-fileset))
- ;; The backend should check that the checkout-model is consistent
- ;; among all the `files'.
- (model (nth 4 vc-fileset)))
-
- ;; Do the right thing
- (cond
- ((eq state 'missing)
- (error "Fileset files are missing, so cannot be operated on"))
- ((eq state 'ignored)
- (error "Fileset files are ignored by the version-control system"))
- ((or (null state) (eq state 'unregistered))
- (vc-register nil vc-fileset))
- ;; Files are up-to-date, or need a merge and user specified a revision
- ((or (eq state 'up-to-date) (and verbose (eq state 'needs-update)))
- (cond
- (verbose
- ;; go to a different revision
- (let* ((revision
- (read-string "Branch, revision, or backend to move to: "))
- (revision-downcase (downcase revision)))
- (if (member
- revision-downcase
- (mapcar (lambda (arg) (downcase (symbol-name arg)))
- vc-handled-backends))
- (let ((vsym (intern-soft revision-downcase)))
- (dolist (file files) (vc-transfer-file file vsym)))
- (dolist (file files)
- (vc-checkout file (eq model 'implicit) revision)))))
- ((not (eq model 'implicit))
- ;; check the files out
- (dolist (file files) (vc-checkout file t)))
- (t
- ;; do nothing
- (message "Fileset is up-to-date"))))
- ;; Files have local changes
- ((vc-compatible-state state 'edited)
- (let ((ready-for-commit files))
- ;; If files are edited but read-only, give user a chance to correct
- (dolist (file files)
- (unless (file-writable-p file)
- ;; Make the file+buffer read-write.
- (unless (y-or-n-p (format "%s is edited but read-only; make it writable and continue?" file))
- (error "Aborted"))
- (set-file-modes file (logior (file-modes file) 128))
- (let ((visited (get-file-buffer file)))
- (when visited
- (with-current-buffer visited
- (toggle-read-only -1))))))
- ;; Allow user to revert files with no changes
- (save-excursion
- (dolist (file files)
- (let ((visited (get-file-buffer file)))
- ;; For files with locking, if the file does not contain
- ;; any changes, just let go of the lock, i.e. revert.
- (when (and (not (eq model 'implicit))
- (vc-workfile-unchanged-p file)
- ;; If buffer is modified, that means the user just
- ;; said no to saving it; in that case, don't revert,
- ;; because the user might intend to save after
- ;; finishing the log entry and committing.
- (not (and visited (buffer-modified-p))))
- (vc-revert-file file)
- (setq ready-for-commit (delete file ready-for-commit))))))
- ;; Remaining files need to be committed
- (if (not ready-for-commit)
- (message "No files remain to be committed")
- (if (not verbose)
- (vc-checkin ready-for-commit backend)
- (let* ((revision (read-string "New revision or backend: "))
- (revision-downcase (downcase revision)))
- (if (member
- revision-downcase
- (mapcar (lambda (arg) (downcase (symbol-name arg)))
- vc-handled-backends))
- (let ((vsym (intern revision-downcase)))
- (dolist (file files) (vc-transfer-file file vsym)))
- (vc-checkin ready-for-commit backend revision)))))))
- ;; locked by somebody else (locking VCSes only)
- ((stringp state)
- ;; In the old days, we computed the revision once and used it on
- ;; the single file. Then, for the 2007-2008 fileset rewrite, we
- ;; computed the revision once (incorrectly, using a free var) and
- ;; used it on all files. To fix the free var bug, we can either
- ;; use `(car files)' or do what we do here: distribute the
- ;; revision computation among `files'. Although this may be
- ;; tedious for those backends where a "revision" is a trans-file
- ;; concept, it is nonetheless correct for both those and (more
- ;; importantly) for those where "revision" is a per-file concept.
- ;; If the intersection of the former group and "locking VCSes" is
- ;; non-empty [I vaguely doubt it --ttn], we can reinstate the
- ;; pre-computation approach of yore.
- (dolist (file files)
- (vc-steal-lock
- file (if verbose
- (read-string (format "%s revision to steal: " file))
- (vc-working-revision file))
- state)))
- ;; conflict
- ((eq state 'conflict)
- ;; FIXME: Is it really the UI we want to provide?
- ;; In my experience, the conflicted files should be marked as resolved
- ;; one-by-one when saving the file after resolving the conflicts.
- ;; I.e. stating explicitly that the conflicts are resolved is done
- ;; very rarely.
- (vc-mark-resolved backend files))
- ;; needs-update
- ((eq state 'needs-update)
- (dolist (file files)
- (if (yes-or-no-p (format
- "%s is not up-to-date. Get latest revision? "
- (file-name-nondirectory file)))
- (vc-checkout file (eq model 'implicit) t)
- (when (and (not (eq model 'implicit))
- (yes-or-no-p "Lock this revision? "))
- (vc-checkout file t)))))
- ;; needs-merge
- ((eq state 'needs-merge)
- (dolist (file files)
- (when (yes-or-no-p (format
- "%s is not up-to-date. Merge in changes now? "
- (file-name-nondirectory file)))
- (vc-maybe-resolve-conflicts
- file (vc-call-backend backend 'merge-news file)))))
-
- ;; unlocked-changes
- ((eq state 'unlocked-changes)
- (dolist (file files)
- (when (not (equal buffer-file-name file))
- (find-file-other-window file))
- (if (save-window-excursion
- (vc-diff-internal nil
- (cons (car vc-fileset) (cons (cadr vc-fileset) (list file)))
- (vc-working-revision file) nil)
- (goto-char (point-min))
- (let ((inhibit-read-only t))
- (insert
- (format "Changes to %s since last lock:\n\n" file)))
- (not (beep))
- (yes-or-no-p (concat "File has unlocked changes. "
- "Claim lock retaining changes? ")))
- (progn (vc-call-backend backend 'steal-lock file)
- (clear-visited-file-modtime)
- ;; Must clear any headers here because they wouldn't
- ;; show that the file is locked now.
- (vc-clear-headers file)
- (write-file buffer-file-name)
- (vc-mode-line file backend))
- (if (not (yes-or-no-p
- "Revert to checked-in revision, instead? "))
- (error "Checkout aborted")
- (vc-revert-buffer-internal t t)
- (vc-checkout file t)))))
- ;; Unknown fileset state
- (t
- (error "Fileset is in an unknown state %s" state)))))
-
-(defun vc-create-repo (backend)
- "Create an empty repository in the current directory."
- (interactive
- (list
- (intern
- (upcase
- (completing-read
- "Create repository for: "
- (mapcar (lambda (b) (list (downcase (symbol-name b)))) vc-handled-backends)
- nil t)))))
- (vc-call-backend backend 'create-repo))
-
-(declare-function vc-dir-move-to-goal-column "vc-dir" ())
-
-;;;###autoload
-(defun vc-register (&optional set-revision vc-fileset comment)
- "Register into a version control system.
-If VC-FILESET is given, register the files in that fileset.
-Otherwise register the current file.
-With prefix argument SET-REVISION, allow user to specify initial revision
-level. If COMMENT is present, use that as an initial comment.
-
-The version control system to use is found by cycling through the list
-`vc-handled-backends'. The first backend in that list which declares
-itself responsible for the file (usually because other files in that
-directory are already registered under that backend) will be used to
-register the file. If no backend declares itself responsible, the
-first backend that could register the file is used."
- (interactive "P")
- (let* ((fileset-arg (or vc-fileset (vc-deduce-fileset nil t)))
- (backend (car fileset-arg))
- (files (nth 1 fileset-arg)))
- ;; We used to operate on `only-files', but VC wants to provide the
- ;; possibility to register directories rather than files only, since
- ;; many VCS allow that as well.
- (dolist (fname files)
- (let ((bname (get-file-buffer fname)))
- (unless fname (setq fname buffer-file-name))
- (when (vc-backend fname)
- (if (vc-registered fname)
- (error "This file is already registered")
- (unless (y-or-n-p "Previous master file has vanished. Make a new one? ")
- (error "Aborted"))))
- ;; Watch out for new buffers of size 0: the corresponding file
- ;; does not exist yet, even though buffer-modified-p is nil.
- (when bname
- (with-current-buffer bname
- (when (and (not (buffer-modified-p))
- (zerop (buffer-size))
- (not (file-exists-p buffer-file-name)))
- (set-buffer-modified-p t))
- (vc-buffer-sync)))))
- (message "Registering %s... " files)
- (mapc 'vc-file-clearprops files)
- (vc-call-backend backend 'register files
- (if set-revision
- (read-string (format "Initial revision level for %s: " files))
- (vc-call-backend backend 'init-revision))
- comment)
- (mapc
- (lambda (file)
- (vc-file-setprop file 'vc-backend backend)
- ;; FIXME: This is wrong: it should set `backup-inhibited' in all
- ;; the buffers visiting files affected by this `vc-register', not
- ;; in the current-buffer.
- ;; (unless vc-make-backup-files
- ;; (make-local-variable 'backup-inhibited)
- ;; (setq backup-inhibited t))
-
- (vc-resynch-buffer file vc-keep-workfiles t))
- files)
- (when (derived-mode-p 'vc-dir-mode)
- (vc-dir-move-to-goal-column))
- (message "Registering %s... done" files)))
-
-(defun vc-register-with (backend)
- "Register the current file with a specified back end."
- (interactive "SBackend: ")
- (when (not (member backend vc-handled-backends))
- (error "Unknown back end"))
- (let ((vc-handled-backends (list backend)))
- (call-interactively 'vc-register)))
-
-(defun vc-checkout (file &optional writable rev)
- "Retrieve a copy of the revision REV of FILE.
-If WRITABLE is non-nil, make sure the retrieved file is writable.
-REV defaults to the latest revision.
-
-After check-out, runs the normal hook `vc-checkout-hook'."
- (and writable
- (not rev)
- (vc-call make-version-backups-p file)
- (vc-up-to-date-p file)
- (vc-make-version-backup file))
- (let ((backend (vc-backend file)))
- (with-vc-properties (list file)
- (condition-case err
- (vc-call-backend backend 'checkout file writable rev)
- (file-error
- ;; Maybe the backend is not installed ;-(
- (when writable
- (let ((buf (get-file-buffer file)))
- (when buf (with-current-buffer buf (toggle-read-only -1)))))
- (signal (car err) (cdr err))))
- `((vc-state . ,(if (or (eq (vc-checkout-model backend (list file)) 'implicit)
- (not writable))
- (if (vc-call-backend backend 'latest-on-branch-p file)
- 'up-to-date
- 'needs-update)
- 'edited))
- (vc-checkout-time . ,(nth 5 (file-attributes file))))))
- (vc-resynch-buffer file t t)
- (run-hooks 'vc-checkout-hook))
-
-(defun vc-mark-resolved (backend files)
- (prog1 (with-vc-properties
- files
- (vc-call-backend backend 'mark-resolved files)
- ;; FIXME: Is this TRTD? Might not be.
- `((vc-state . edited)))
- (message
- (substitute-command-keys
- "Conflicts have been resolved in %s. \
-Type \\[vc-next-action] to check in changes.")
- (if (> (length files) 1)
- (format "%d files" (length files))
- "this file"))))
-
-(defun vc-steal-lock (file rev owner)
- "Steal the lock on FILE."
- (let (file-description)
- (if rev
- (setq file-description (format "%s:%s" file rev))
- (setq file-description file))
- (when (not (yes-or-no-p (format "Steal the lock on %s from %s? "
- file-description owner)))
- (error "Steal canceled"))
- (message "Stealing lock on %s..." file)
- (with-vc-properties
- (list file)
- (vc-call steal-lock file rev)
- `((vc-state . edited)))
- (vc-resynch-buffer file t t)
- (message "Stealing lock on %s...done" file)
- ;; Write mail after actually stealing, because if the stealing
- ;; goes wrong, we don't want to send any mail.
- (compose-mail owner (format "Stolen lock on %s" file-description))
- (setq default-directory (expand-file-name "~/"))
- (goto-char (point-max))
- (insert
- (format "I stole the lock on %s, " file-description)
- (current-time-string)
- ".\n")
- (message "Please explain why you stole the lock. Type C-c C-c when done.")))
-
-(defun vc-checkin (files backend &optional rev comment initial-contents)
- "Check in FILES.
-The optional argument REV may be a string specifying the new revision
-level (strongly deprecated). COMMENT is a comment
-string; if omitted, a buffer is popped up to accept a comment. If
-INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial contents
-of the log entry buffer.
-
-If `vc-keep-workfiles' is nil, FILE is deleted afterwards, provided
-that the version control system supports this mode of operation.
-
-Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'."
- (when vc-before-checkin-hook
- (run-hooks 'vc-before-checkin-hook))
- (lexical-let
- ((backend backend))
- (vc-start-logentry
- files comment initial-contents
- "Enter a change comment."
- "*VC-log*"
- (lambda ()
- (vc-call-backend backend 'log-edit-mode))
- (lexical-let ((rev rev))
- (lambda (files comment)
- (message "Checking in %s..." (vc-delistify files))
- ;; "This log message intentionally left almost blank".
- ;; RCS 5.7 gripes about white-space-only comments too.
- (or (and comment (string-match "[^\t\n ]" comment))
- (setq comment "*** empty log message ***"))
- (with-vc-properties
- files
- ;; We used to change buffers to get local value of
- ;; vc-checkin-switches, but 'the' local buffer is
- ;; not a well-defined concept for filesets.
- (progn
- (vc-call-backend backend 'checkin files rev comment)
- (mapc 'vc-delete-automatic-version-backups files))
- `((vc-state . up-to-date)
- (vc-checkout-time . ,(nth 5 (file-attributes file)))
- (vc-working-revision . nil)))
- (message "Checking in %s...done" (vc-delistify files))))
- 'vc-checkin-hook)))
-
-;;; Additional entry points for examining version histories
-
-;; (defun vc-default-diff-tree (backend dir rev1 rev2)
-;; "List differences for all registered files at and below DIR.
-;; The meaning of REV1 and REV2 is the same as for `vc-revision-diff'."
-;; ;; This implementation does an explicit tree walk, and calls
-;; ;; vc-BACKEND-diff directly for each file. An optimization
-;; ;; would be to use `vc-diff-internal', so that diffs can be local,
-;; ;; and to call it only for files that are actually changed.
-;; ;; However, this is expensive for some backends, and so it is left
-;; ;; to backend-specific implementations.
-;; (setq default-directory dir)
-;; (vc-file-tree-walk
-;; default-directory
-;; (lambda (f)
-;; (vc-exec-after
-;; `(let ((coding-system-for-read (vc-coding-system-for-diff ',f)))
-;; (message "Looking at %s" ',f)
-;; (vc-call-backend ',(vc-backend f)
-;; 'diff (list ',f) ',rev1 ',rev2))))))
-
-(defun vc-coding-system-for-diff (file)
- "Return the coding system for reading diff output for FILE."
- (or coding-system-for-read
- ;; if we already have this file open,
- ;; use the buffer's coding system
- (let ((buf (find-buffer-visiting file)))
- (when buf (with-current-buffer buf
- buffer-file-coding-system)))
- ;; otherwise, try to find one based on the file name
- (car (find-operation-coding-system 'insert-file-contents file))
- ;; and a final fallback
- 'undecided))
-
-(defun vc-switches (backend op)
- "Return a list of vc-BACKEND switches for operation OP.
-BACKEND is a symbol such as `CVS', which will be downcased.
-OP is a symbol such as `diff'.
-
-In decreasing order of preference, return the value of:
-vc-BACKEND-OP-switches (e.g. `vc-cvs-diff-switches');
-vc-OP-switches (e.g. `vc-diff-switches'); or, in the case of
-diff only, `diff-switches'.
-
-If the chosen value is not a string or a list, return nil.
-This is so that you may set, e.g. `vc-svn-diff-switches' to t in order
-to override the value of `vc-diff-switches' and `diff-switches'."
- (let ((switches
- (or (when backend
- (let ((sym (vc-make-backend-sym
- backend (intern (concat (symbol-name op)
- "-switches")))))
- (when (boundp sym) (symbol-value sym))))
- (let ((sym (intern (format "vc-%s-switches" (symbol-name op)))))
- (when (boundp sym) (symbol-value sym)))
- (cond
- ((eq op 'diff) diff-switches)))))
- (if (stringp switches) (list switches)
- ;; If not a list, return nil.
- ;; This is so we can set vc-diff-switches to t to override
- ;; any switches in diff-switches.
- (when (listp switches) switches))))
-
-;; Old def for compatibility with Emacs-21.[123].
-(defmacro vc-diff-switches-list (backend) `(vc-switches ',backend 'diff))
-(make-obsolete 'vc-diff-switches-list 'vc-switches "22.1")
-
-(defun vc-diff-finish (buffer messages)
- ;; The empty sync output case has already been handled, so the only
- ;; possibility of an empty output is for an async process.
- (when (buffer-live-p buffer)
- (let ((window (get-buffer-window buffer t))
- (emptyp (zerop (buffer-size buffer))))
- (with-current-buffer buffer
- (and messages emptyp
- (let ((inhibit-read-only t))
- (insert (cdr messages) ".\n")
- (message "%s" (cdr messages))))
- (goto-char (point-min))
- (when window
- (shrink-window-if-larger-than-buffer window)))
- (when (and messages (not emptyp))
- (message "%sdone" (car messages))))))
-
-(defvar vc-diff-added-files nil
- "If non-nil, diff added files by comparing them to /dev/null.")
-
-(defun vc-diff-internal (async vc-fileset rev1 rev2 &optional verbose)
- "Report diffs between two revisions of a fileset.
-Diff output goes to the *vc-diff* buffer. The function
-returns t if the buffer had changes, nil otherwise."
- (let* ((files (cadr vc-fileset))
- (messages (cons (format "Finding changes in %s..."
- (vc-delistify files))
- (format "No changes between %s and %s"
- (or rev1 "working revision")
- (or rev2 "workfile"))))
- ;; Set coding system based on the first file. It's a kluge,
- ;; but the only way to set it for each file included would
- ;; be to call the back end separately for each file.
- (coding-system-for-read
- (if files (vc-coding-system-for-diff (car files)) 'undecided)))
- (vc-setup-buffer "*vc-diff*")
- (message "%s" (car messages))
- ;; Many backends don't handle well the case of a file that has been
- ;; added but not yet committed to the repo (notably CVS and Subversion).
- ;; Do that work here so the backends don't have to futz with it. --ESR
- ;;
- ;; Actually most backends (including CVS) have options to control the
- ;; behavior since which one is better depends on the user and on the
- ;; situation). Worse yet: this code does not handle the case where
- ;; `file' is a directory which contains added files.
- ;; I made it conditional on vc-diff-added-files but it should probably
- ;; just be removed (or copied/moved to specific backends). --Stef.
- (when vc-diff-added-files
- (let ((filtered '())
- process-file-side-effects)
- (dolist (file files)
- (if (or (file-directory-p file)
- (not (string= (vc-working-revision file) "0")))
- (push file filtered)
- ;; This file is added but not yet committed;
- ;; there is no repository version to diff against.
- (if (or rev1 rev2)
- (error "No revisions of %s exist" file)
- ;; We regard this as "changed".
- ;; Diff it against /dev/null.
- (apply 'vc-do-command "*vc-diff*"
- 1 "diff" file
- (append (vc-switches nil 'diff) '("/dev/null"))))))
- (setq files (nreverse filtered))))
- (let ((vc-disable-async-diff (not async)))
- (vc-call-backend (car vc-fileset) 'diff files rev1 rev2 "*vc-diff*"))
- (set-buffer "*vc-diff*")
- (if (and (zerop (buffer-size))
- (not (get-buffer-process (current-buffer))))
- ;; Treat this case specially so as not to pop the buffer.
- (progn
- (message "%s" (cdr messages))
- nil)
- (diff-mode)
- ;; Make the *vc-diff* buffer read only, the diff-mode key
- ;; bindings are nicer for read only buffers. pcl-cvs does the
- ;; same thing.
- (setq buffer-read-only t)
- (vc-exec-after `(vc-diff-finish ,(current-buffer) ',(when verbose
- messages)))
- ;; Display the buffer, but at the end because it can change point.
- (pop-to-buffer (current-buffer))
- ;; In the async case, we return t even if there are no differences
- ;; because we don't know that yet.
- t)))
-
-(defun vc-read-revision (prompt &optional files backend default initial-input)
- (cond
- ((null files)
- (let ((vc-fileset (vc-deduce-fileset t))) ;FIXME: why t? --Stef
- (setq files (cadr vc-fileset))
- (setq backend (car vc-fileset))))
- ((null backend) (setq backend (vc-backend (car files)))))
- (let ((completion-table
- (vc-call-backend backend 'revision-completion-table files)))
- (if completion-table
- (completing-read prompt completion-table
- nil nil initial-input nil default)
- (read-string prompt initial-input nil default))))
-
-;;;###autoload
-(defun vc-version-diff (files rev1 rev2)
- "Report diffs between revisions of the fileset in the repository history."
- (interactive
- (let* ((vc-fileset (vc-deduce-fileset t)) ;FIXME: why t? --Stef
- (files (cadr vc-fileset))
- (backend (car vc-fileset))
- (first (car files))
- (rev1-default nil)
- (rev2-default nil))
- (cond
- ;; someday we may be able to do revision completion on non-singleton
- ;; filesets, but not yet.
- ((/= (length files) 1)
- nil)
- ;; if it's a directory, don't supply any revision default
- ((file-directory-p first)
- nil)
- ;; if the file is not up-to-date, use working revision as older revision
- ((not (vc-up-to-date-p first))
- (setq rev1-default (vc-working-revision first)))
- ;; if the file is not locked, use last and previous revisions as defaults
- (t
- (setq rev1-default (vc-call-backend backend 'previous-revision first
- (vc-working-revision first)))
- (when (string= rev1-default "") (setq rev1-default nil))
- (setq rev2-default (vc-working-revision first))))
- ;; construct argument list
- (let* ((rev1-prompt (if rev1-default
- (concat "Older revision (default "
- rev1-default "): ")
- "Older revision: "))
- (rev2-prompt (concat "Newer revision (default "
- (or rev2-default "current source") "): "))
- (rev1 (vc-read-revision rev1-prompt files backend rev1-default))
- (rev2 (vc-read-revision rev2-prompt files backend rev2-default)))
- (when (string= rev1 "") (setq rev1 nil))
- (when (string= rev2 "") (setq rev2 nil))
- (list files rev1 rev2))))
- ;; All that was just so we could do argument completion!
- (when (and (not rev1) rev2)
- (error "Not a valid revision range"))
- ;; Yes, it's painful to call (vc-deduce-fileset) again. Alas, the
- ;; placement rules for (interactive) don't actually leave us a choice.
- (vc-diff-internal t (vc-deduce-fileset t) rev1 rev2
- (called-interactively-p 'interactive)))
-
-;;;###autoload
-(defun vc-diff (historic &optional not-urgent)
- "Display diffs between file revisions.
-Normally this compares the currently selected fileset with their
-working revisions. With a prefix argument HISTORIC, it reads two revision
-designators specifying which revisions to compare.
-
-The optional argument NOT-URGENT non-nil means it is ok to say no to
-saving the buffer."
- (interactive (list current-prefix-arg t))
- (if historic
- (call-interactively 'vc-version-diff)
- (when buffer-file-name (vc-buffer-sync not-urgent))
- (vc-diff-internal t (vc-deduce-fileset t) nil nil
- (called-interactively-p 'interactive))))
-
-;;;###autoload
-(defun vc-root-diff (historic &optional not-urgent)
- "Display diffs between VC-controlled whole tree revisions.
-Normally, this compares the tree corresponding to the current
-fileset with the working revision.
-With a prefix argument HISTORIC, prompt for two revision
-designators specifying which revisions to compare.
-
-The optional argument NOT-URGENT non-nil means it is ok to say no to
-saving the buffer."
- (interactive (list current-prefix-arg t))
- (if historic
- ;; FIXME: this does not work right, `vc-version-diff' ends up
- ;; calling `vc-deduce-fileset' to find the files to diff, and
- ;; that's not what we want here, we want the diff for the VC root dir.
- (call-interactively 'vc-version-diff)
- (when buffer-file-name (vc-buffer-sync not-urgent))
- (let ((backend
- (cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
- ((derived-mode-p 'dired-mode) (vc-responsible-backend default-directory))
- (vc-mode (vc-backend buffer-file-name))))
- rootdir working-revision)
- (unless backend
- (error "Buffer is not version controlled"))
- (setq rootdir (vc-call-backend backend 'root default-directory))
- (setq working-revision (vc-working-revision rootdir))
- ;; VC diff for the root directory produces output that is
- ;; relative to it. Bind default-directory to the root directory
- ;; here, this way the *vc-diff* buffer is setup correctly, so
- ;; relative file names work.
- (let ((default-directory rootdir))
- (vc-diff-internal
- t (list backend (list rootdir) working-revision) nil nil
- (called-interactively-p 'interactive))))))
-
-;;;###autoload
-(defun vc-revision-other-window (rev)
- "Visit revision REV of the current file in another window.
-If the current file is named `F', the revision is named `F.~REV~'.
-If `F.~REV~' already exists, use it instead of checking it out again."
- (interactive
- (save-current-buffer
- (vc-ensure-vc-buffer)
- (list
- (vc-read-revision "Revision to visit (default is working revision): "
- (list buffer-file-name)))))
- (vc-ensure-vc-buffer)
- (let* ((file buffer-file-name)
- (revision (if (string-equal rev "")
- (vc-working-revision file)
- rev)))
- (switch-to-buffer-other-window (vc-find-revision file revision))))
-
-(defun vc-find-revision (file revision)
- "Read REVISION of FILE into a buffer and return the buffer."
- (let ((automatic-backup (vc-version-backup-file-name file revision))
- (filebuf (or (get-file-buffer file) (current-buffer)))
- (filename (vc-version-backup-file-name file revision 'manual)))
- (unless (file-exists-p filename)
- (if (file-exists-p automatic-backup)
- (rename-file automatic-backup filename nil)
- (message "Checking out %s..." filename)
- (with-current-buffer filebuf
- (let ((failed t))
- (unwind-protect
- (let ((coding-system-for-read 'no-conversion)
- (coding-system-for-write 'no-conversion))
- (with-temp-file filename
- (let ((outbuf (current-buffer)))
- ;; Change buffer to get local value of
- ;; vc-checkout-switches.
- (with-current-buffer filebuf
- (vc-call find-revision file revision outbuf))))
- (setq failed nil))
- (when (and failed (file-exists-p filename))
- (delete-file filename))))
- (vc-mode-line file))
- (message "Checking out %s...done" filename)))
- (let ((result-buf (find-file-noselect filename)))
- (with-current-buffer result-buf
- ;; Set the parent buffer so that things like
- ;; C-x v g, C-x v l, ... etc work.
- (set (make-local-variable 'vc-parent-buffer) filebuf))
- result-buf)))
-
-;; Header-insertion code
-
-;;;###autoload
-(defun vc-insert-headers ()
- "Insert headers into a file for use with a version control system.
-Headers desired are inserted at point, and are pulled from
-the variable `vc-BACKEND-header'."
- (interactive)
- (vc-ensure-vc-buffer)
- (save-excursion
- (save-restriction
- (widen)
- (when (or (not (vc-check-headers))
- (y-or-n-p "Version headers already exist. Insert another set? "))
- (let* ((delims (cdr (assq major-mode vc-comment-alist)))
- (comment-start-vc (or (car delims) comment-start "#"))
- (comment-end-vc (or (car (cdr delims)) comment-end ""))
- (hdsym (vc-make-backend-sym (vc-backend buffer-file-name)
- 'header))
- (hdstrings (and (boundp hdsym) (symbol-value hdsym))))
- (dolist (s hdstrings)
- (insert comment-start-vc "\t" s "\t"
- comment-end-vc "\n"))
- (when vc-static-header-alist
- (dolist (f vc-static-header-alist)
- (when (string-match (car f) buffer-file-name)
- (insert (format (cdr f) (car hdstrings)))))))))))
-
-(defun vc-clear-headers (&optional file)
- "Clear all version headers in the current buffer (or FILE).
-The headers are reset to their non-expanded form."
- (let* ((filename (or file buffer-file-name))
- (visited (find-buffer-visiting filename))
- (backend (vc-backend filename)))
- (when (vc-find-backend-function backend 'clear-headers)
- (if visited
- (let ((context (vc-buffer-context)))
- ;; save-excursion may be able to relocate point and mark
- ;; properly. If it fails, vc-restore-buffer-context
- ;; will give it a second try.
- (save-excursion
- (vc-call-backend backend 'clear-headers))
- (vc-restore-buffer-context context))
- (set-buffer (find-file-noselect filename))
- (vc-call-backend backend 'clear-headers)
- (kill-buffer filename)))))
-
-(defun vc-modify-change-comment (files rev oldcomment)
- "Edit the comment associated with the given files and revision."
- ;; Less of a kluge than it looks like; log-view mode only passes
- ;; this function a singleton list. Arguments left in this form in
- ;; case the more general operation ever becomes meaningful.
- (let ((backend (vc-responsible-backend (car files))))
- (vc-start-logentry
- files oldcomment t
- "Enter a replacement change comment."
- "*VC-log*"
- (lambda () (vc-call-backend backend 'log-edit-mode))
- (lexical-let ((rev rev))
- (lambda (files comment)
- (vc-call-backend backend
- 'modify-change-comment files rev comment))))))
-
-;;;###autoload
-(defun vc-merge ()
- "Merge changes between two revisions into the current buffer's file.
-This asks for two revisions to merge from in the minibuffer. If the
-first revision is a branch number, then merge all changes from that
-branch. If the first revision is empty, merge news, i.e. recent changes
-from the current branch.
-
-See Info node `Merging'."
- (interactive)
- (vc-ensure-vc-buffer)
- (vc-buffer-sync)
- (let* ((file buffer-file-name)
- (backend (vc-backend file))
- (state (vc-state file))
- first-revision second-revision status)
- (cond
- ((stringp state) ;; Locking VCses only
- (error "File is locked by %s" state))
- ((not (vc-editable-p file))
- (if (y-or-n-p
- "File must be checked out for merging. Check out now? ")
- (vc-checkout file t)
- (error "Merge aborted"))))
- (setq first-revision
- (vc-read-revision
- (concat "Branch or revision to merge from "
- "(default news on current branch): ")
- (list file)
- backend))
- (if (string= first-revision "")
- (setq status (vc-call-backend backend 'merge-news file))
- (if (not (vc-find-backend-function backend 'merge))
- (error "Sorry, merging is not implemented for %s" backend)
- (if (not (vc-branch-p first-revision))
- (setq second-revision
- (vc-read-revision
- "Second revision: "
- (list file) backend nil
- ;; FIXME: This is CVS/RCS/SCCS specific.
- (concat (vc-branch-part first-revision) ".")))
- ;; We want to merge an entire branch. Set revisions
- ;; accordingly, so that vc-BACKEND-merge understands us.
- (setq second-revision first-revision)
- ;; first-revision must be the starting point of the branch
- (setq first-revision (vc-branch-part first-revision)))
- (setq status (vc-call-backend backend 'merge file
- first-revision second-revision))))
- (vc-maybe-resolve-conflicts file status "WORKFILE" "MERGE SOURCE")))
-
-(defun vc-maybe-resolve-conflicts (file status &optional name-A name-B)
- (vc-resynch-buffer file t (not (buffer-modified-p)))
- (if (zerop status) (message "Merge successful")
- (smerge-mode 1)
- (message "File contains conflicts.")))
-
-;;;###autoload
-(defalias 'vc-resolve-conflicts 'smerge-ediff)
-
-;; TODO: This is OK but maybe we could integrate it better.
-;; E.g. it could be run semi-automatically (via a prompt?) when saving a file
-;; that was conflicted (i.e. upon mark-resolved).
-;; FIXME: should we add an "other-window" version? Or maybe we should
-;; hook it inside find-file so it automatically works for
-;; find-file-other-window as well. E.g. find-file could use a new
-;; `default-next-file' variable for its default file (M-n), and
-;; we could then set it upon mark-resolve, so C-x C-s C-x C-f M-n would
-;; automatically offer the next conflicted file.
-(defun vc-find-conflicted-file ()
- "Visit the next conflicted file in the current project."
- (interactive)
- (let* ((backend (or (if buffer-file-name (vc-backend buffer-file-name))
- (vc-responsible-backend default-directory)
- (error "No VC backend")))
- (files (vc-call-backend backend
- 'conflicted-files default-directory)))
- ;; Don't try and visit the current file.
- (if (equal (car files) buffer-file-name) (pop files))
- (if (null files)
- (message "No more conflicted files")
- (find-file (pop files))
- (message "%s more conflicted files after this one"
- (if files (length files) "No")))))
-
-;; Named-configuration entry points
-
-(defun vc-tag-precondition (dir)
- "Scan the tree below DIR, looking for files not up-to-date.
-If any file is not up-to-date, return the name of the first such file.
-\(This means, neither tag creation nor retrieval is allowed.\)
-If one or more of the files are currently visited, return `visited'.
-Otherwise, return nil."
- (let ((status nil))
- (catch 'vc-locked-example
- (vc-file-tree-walk
- dir
- (lambda (f)
- (if (not (vc-up-to-date-p f)) (throw 'vc-locked-example f)
- (when (get-file-buffer f) (setq status 'visited)))))
- status)))
-
-;;;###autoload
-(defun vc-create-tag (dir name branchp)
- "Descending recursively from DIR, make a tag called NAME.
-For each registered file, the working revision becomes part of
-the named configuration. If the prefix argument BRANCHP is
-given, the tag is made as a new branch and the files are
-checked out in that new branch."
- (interactive
- (let ((granularity
- (vc-call-backend (vc-responsible-backend default-directory)
- 'revision-granularity)))
- (list
- (if (eq granularity 'repository)
- ;; For VC's that do not work at file level, it's pointless
- ;; to ask for a directory, branches are created at repository level.
- default-directory
- (read-file-name "Directory: " default-directory default-directory t))
- (read-string (if current-prefix-arg "New branch name: " "New tag name: "))
- current-prefix-arg)))
- (message "Making %s... " (if branchp "branch" "tag"))
- (when (file-directory-p dir) (setq dir (file-name-as-directory dir)))
- (vc-call-backend (vc-responsible-backend dir)
- 'create-tag dir name branchp)
- (vc-resynch-buffer dir t t t)
- (message "Making %s... done" (if branchp "branch" "tag")))
-
-;;;###autoload
-(defun vc-retrieve-tag (dir name)
- "Descending recursively from DIR, retrieve the tag called NAME.
-If NAME is empty, it refers to the latest revisions.
-If locking is used for the files in DIR, then there must not be any
-locked files at or below DIR (but if NAME is empty, locked files are
-allowed and simply skipped)."
- (interactive
- (let ((granularity
- (vc-call-backend (vc-responsible-backend default-directory)
- 'revision-granularity)))
- (list
- (if (eq granularity 'repository)
- ;; For VC's that do not work at file level, it's pointless
- ;; to ask for a directory, branches are created at repository level.
- default-directory
- (read-file-name "Directory: " default-directory default-directory t))
- (read-string "Tag name to retrieve (default latest revisions): "))))
- (let ((update (yes-or-no-p "Update any affected buffers? "))
- (msg (if (or (not name) (string= name ""))
- (format "Updating %s... " (abbreviate-file-name dir))
- (format "Retrieving tag into %s... "
- (abbreviate-file-name dir)))))
- (message "%s" msg)
- (vc-call-backend (vc-responsible-backend dir)
- 'retrieve-tag dir name update)
- (vc-resynch-buffer dir t t t)
- (message "%s" (concat msg "done"))))
-
-
-;; Miscellaneous other entry points
-
-;; FIXME: this should be a defcustom
-;; FIXME: maybe add another choice:
-;; `root-directory' (or somesuch), which would mean show a short log
-;; for the root directory.
-(defvar vc-log-short-style '(directory)
- "Whether or not to show a short log.
-If it contains `directory' then if the fileset contains a directory show a short log.
-If it contains `file' then show short logs for files.
-Not all VC backends support short logs!")
-
-(defvar log-view-vc-backend)
-(defvar log-view-vc-fileset)
-
-(defun vc-print-log-setup-buttons (working-revision is-start-revision limit pl-return)
- (when (and limit (not (eq 'limit-unsupported pl-return))
- (not is-start-revision))
- (goto-char (point-max))
- (lexical-let ((working-revision working-revision)
- (limit limit))
- (widget-create 'push-button
- :notify (lambda (&rest ignore)
- (vc-print-log-internal
- log-view-vc-backend log-view-vc-fileset
- working-revision nil (* 2 limit)))
- :help-echo "Show the log again, and double the number of log entries shown"
- "Show 2X entries")
- (widget-insert " ")
- (widget-create 'push-button
- :notify (lambda (&rest ignore)
- (vc-print-log-internal
- log-view-vc-backend log-view-vc-fileset
- working-revision nil nil))
- :help-echo "Show the log again, showing all entries"
- "Show unlimited entries"))
- (widget-setup)))
-
-(defun vc-print-log-internal (backend files working-revision
- &optional is-start-revision limit)
- ;; Don't switch to the output buffer before running the command,
- ;; so that any buffer-local settings in the vc-controlled
- ;; buffer can be accessed by the command.
- (let ((dir-present nil)
- (vc-short-log nil)
- (buffer-name "*vc-change-log*")
- type
- pl-return)
- (dolist (file files)
- (when (file-directory-p file)
- (setq dir-present t)))
- (setq vc-short-log
- (not (null (if dir-present
- (memq 'directory vc-log-short-style)
- (memq 'file vc-log-short-style)))))
- (setq type (if vc-short-log 'short 'long))
- (lexical-let
- ((working-revision working-revision)
- (limit limit)
- (shortlog vc-short-log)
- (is-start-revision is-start-revision))
- (vc-log-internal-common
- backend buffer-name files type
- (lambda (bk buf type-arg files-arg)
- (vc-call-backend bk 'print-log files-arg buf
- shortlog (when is-start-revision working-revision) limit))
- (lambda (bk files-arg ret)
- (vc-print-log-setup-buttons working-revision
- is-start-revision limit ret))
- (lambda (bk)
- (vc-call-backend bk 'show-log-entry working-revision))))))
-
-(defvar vc-log-view-type nil
- "Set this to differentiate the different types of logs.")
-(put 'vc-log-view-type 'permanent-local t)
-
-(defun vc-log-internal-common (backend
- buffer-name
- files
- type
- backend-func
- setup-buttons-func
- goto-location-func)
- (let (retval)
- (with-current-buffer (get-buffer-create buffer-name)
- (set (make-local-variable 'vc-log-view-type) type))
- (setq retval (funcall backend-func backend buffer-name type files))
- (pop-to-buffer buffer-name)
- (let ((inhibit-read-only t))
- ;; log-view-mode used to be called with inhibit-read-only bound
- ;; to t, so let's keep doing it, just in case.
- (vc-call-backend backend 'log-view-mode)
- (set (make-local-variable 'log-view-vc-backend) backend)
- (set (make-local-variable 'log-view-vc-fileset) files))
- (vc-exec-after
- `(let ((inhibit-read-only t))
- (funcall ',setup-buttons-func ',backend ',files ',retval)
- (shrink-window-if-larger-than-buffer)
- (funcall ',goto-location-func ',backend)
- (setq vc-sentinel-movepoint (point))
- (set-buffer-modified-p nil)))))
-
-(defun vc-incoming-outgoing-internal (backend remote-location buffer-name type)
- (vc-log-internal-common
- backend buffer-name nil type
- (lexical-let
- ((remote-location remote-location))
- (lambda (bk buf type-arg files)
- (vc-call-backend bk type-arg buf remote-location)))
- (lambda (bk files-arg ret))
- (lambda (bk)
- (goto-char (point-min)))))
-
-;;;###autoload
-(defun vc-print-log (&optional working-revision limit)
- "List the change log of the current fileset in a window.
-If WORKING-REVISION is non-nil, leave point at that revision.
-If LIMIT is non-nil, it should be a number specifying the maximum
-number of revisions to show; the default is `vc-log-show-limit'.
-
-When called interactively with a prefix argument, prompt for
-WORKING-REVISION and LIMIT."
- (interactive
- (cond
- (current-prefix-arg
- (let ((rev (read-from-minibuffer "Log from revision (default: last revision): " nil
- nil nil nil))
- (lim (string-to-number
- (read-from-minibuffer
- "Limit display (unlimited: 0): "
- (format "%s" vc-log-show-limit)
- nil nil nil))))
- (when (string= rev "") (setq rev nil))
- (when (<= lim 0) (setq lim nil))
- (list rev lim)))
- (t
- (list nil (when (> vc-log-show-limit 0) vc-log-show-limit)))))
- (let* ((vc-fileset (vc-deduce-fileset t)) ;FIXME: Why t? --Stef
- (backend (car vc-fileset))
- (files (cadr vc-fileset))
- (working-revision (or working-revision (vc-working-revision (car files)))))
- (vc-print-log-internal backend files working-revision nil limit)))
-
-;;;###autoload
-(defun vc-print-root-log (&optional limit)
- "List the change log for the current VC controlled tree in a window.
-If LIMIT is non-nil, it should be a number specifying the maximum
-number of revisions to show; the default is `vc-log-show-limit'.
-When called interactively with a prefix argument, prompt for LIMIT."
- (interactive
- (cond
- (current-prefix-arg
- (let ((lim (string-to-number
- (read-from-minibuffer
- "Limit display (unlimited: 0): "
- (format "%s" vc-log-show-limit)
- nil nil nil))))
- (when (<= lim 0) (setq lim nil))
- (list lim)))
- (t
- (list (when (> vc-log-show-limit 0) vc-log-show-limit)))))
- (let ((backend
- (cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
- ((derived-mode-p 'dired-mode) (vc-responsible-backend default-directory))
- (vc-mode (vc-backend buffer-file-name))))
- rootdir working-revision)
- (unless backend
- (error "Buffer is not version controlled"))
- (setq rootdir (vc-call-backend backend 'root default-directory))
- (setq working-revision (vc-working-revision rootdir))
- (vc-print-log-internal backend (list rootdir) working-revision nil limit)))
-
-;;;###autoload
-(defun vc-log-incoming (&optional remote-location)
- "Show a log of changes that will be received with a pull operation from REMOTE-LOCATION."
- (interactive "sRemote location (empty for default): ")
- (let ((backend
- (cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
- ((derived-mode-p 'dired-mode) (vc-responsible-backend default-directory))
- (vc-mode (vc-backend buffer-file-name))))
- rootdir working-revision)
- (unless backend
- (error "Buffer is not version controlled"))
- (vc-incoming-outgoing-internal backend remote-location "*vc-incoming*" 'log-incoming)))
-
-;;;###autoload
-(defun vc-log-outgoing (&optional remote-location)
- "Show a log of changes that will be sent with a push operation to REMOTE-LOCATION."
- (interactive "sRemote location (empty for default): ")
- (let ((backend
- (cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
- ((derived-mode-p 'dired-mode) (vc-responsible-backend default-directory))
- (vc-mode (vc-backend buffer-file-name))))
- rootdir working-revision)
- (unless backend
- (error "Buffer is not version controlled"))
- (vc-incoming-outgoing-internal backend remote-location "*vc-outgoing*" 'log-outgoing)))
-
-;;;###autoload
-(defun vc-revert ()
- "Revert working copies of the selected fileset to their repository contents.
-This asks for confirmation if the buffer contents are not identical
-to the working revision (except for keyword expansion)."
- (interactive)
- (let* ((vc-fileset (vc-deduce-fileset))
- (files (cadr vc-fileset)))
- ;; If any of the files is visited by the current buffer, make
- ;; sure buffer is saved. If the user says `no', abort since
- ;; we cannot show the changes and ask for confirmation to
- ;; discard them.
- (when (or (not files) (memq (buffer-file-name) files))
- (vc-buffer-sync nil))
- (dolist (file files)
- (let ((buf (get-file-buffer file)))
- (when (and buf (buffer-modified-p buf))
- (error "Please kill or save all modified buffers before reverting")))
- (when (vc-up-to-date-p file)
- (unless (yes-or-no-p (format "%s seems up-to-date. Revert anyway? " file))
- (error "Revert canceled"))))
- (when (vc-diff-internal vc-allow-async-revert vc-fileset nil nil)
- (unless (yes-or-no-p
- (format "Discard changes in %s? "
- (let ((str (vc-delistify files))
- (nfiles (length files)))
- (if (< (length str) 50)
- str
- (format "%d file%s" nfiles
- (if (= nfiles 1) "" "s"))))))
- (error "Revert canceled"))
- (delete-windows-on "*vc-diff*")
- (kill-buffer "*vc-diff*"))
- (dolist (file files)
- (message "Reverting %s..." (vc-delistify files))
- (vc-revert-file file)
- (message "Reverting %s...done" (vc-delistify files)))))
-
-;;;###autoload
-(defun vc-rollback ()
- "Roll back (remove) the most recent changeset committed to the repository.
-This may be either a file-level or a repository-level operation,
-depending on the underlying version-control system."
- (interactive)
- (let* ((vc-fileset (vc-deduce-fileset))
- (backend (car vc-fileset))
- (files (cadr vc-fileset))
- (granularity (vc-call-backend backend 'revision-granularity)))
- (unless (vc-find-backend-function backend 'rollback)
- (error "Rollback is not supported in %s" backend))
- (when (and (not (eq granularity 'repository)) (/= (length files) 1))
- (error "Rollback requires a singleton fileset or repository versioning"))
- ;; FIXME: latest-on-branch-p should take the fileset.
- (when (not (vc-call-backend backend 'latest-on-branch-p (car files)))
- (error "Rollback is only possible at the tip revision"))
- ;; If any of the files is visited by the current buffer, make
- ;; sure buffer is saved. If the user says `no', abort since
- ;; we cannot show the changes and ask for confirmation to
- ;; discard them.
- (when (or (not files) (memq (buffer-file-name) files))
- (vc-buffer-sync nil))
- (dolist (file files)
- (when (buffer-modified-p (get-file-buffer file))
- (error "Please kill or save all modified buffers before rollback"))
- (when (not (vc-up-to-date-p file))
- (error "Please revert all modified workfiles before rollback")))
- ;; Accumulate changes associated with the fileset
- (vc-setup-buffer "*vc-diff*")
- (not-modified)
- (message "Finding changes...")
- (let* ((tip (vc-working-revision (car files)))
- ;; FIXME: `previous-revision' should take the fileset.
- (previous (vc-call-backend backend 'previous-revision
- (car files) tip)))
- (vc-diff-internal nil vc-fileset previous tip))
- ;; Display changes
- (unless (yes-or-no-p "Discard these revisions? ")
- (error "Rollback canceled"))
- (delete-windows-on "*vc-diff*")
- (kill-buffer"*vc-diff*")
- ;; Do the actual reversions
- (message "Rolling back %s..." (vc-delistify files))
- (with-vc-properties
- files
- (vc-call-backend backend 'rollback files)
- `((vc-state . ,'up-to-date)
- (vc-checkout-time . , (nth 5 (file-attributes file)))
- (vc-working-revision . nil)))
- (dolist (f files) (vc-resynch-buffer f t t))
- (message "Rolling back %s...done" (vc-delistify files))))
-
-;;;###autoload
-(define-obsolete-function-alias 'vc-revert-buffer 'vc-revert "23.1")
-
-;;;###autoload
-(defun vc-update ()
- "Update the current fileset's files to their tip revisions.
-For each one that contains no changes, and is not locked, then this simply
-replaces the work file with the latest revision on its branch. If the file
-contains changes, and the backend supports merging news, then any recent
-changes from the current branch are merged into the working file."
- (interactive)
- (let* ((vc-fileset (vc-deduce-fileset))
- (backend (car vc-fileset))
- (files (cadr vc-fileset)))
- (save-some-buffers ; save buffers visiting files
- nil (lambda ()
- (and (buffer-modified-p)
- (let ((file (buffer-file-name)))
- (and file (member file files))))))
- (dolist (file files)
- (if (vc-up-to-date-p file)
- (vc-checkout file nil t)
- (if (eq (vc-checkout-model backend (list file)) 'locking)
- (if (eq (vc-state file) 'edited)
- (error "%s"
- (substitute-command-keys
- "File is locked--type \\[vc-revert] to discard changes"))
- (error "Unexpected file state (%s) -- type %s"
- (vc-state file)
- (substitute-command-keys
- "\\[vc-next-action] to correct")))
- (vc-maybe-resolve-conflicts
- file (vc-call-backend backend 'merge-news file)))))))
-
-(defun vc-version-backup-file (file &optional rev)
- "Return name of backup file for revision REV of FILE.
-If version backups should be used for FILE, and there exists
-such a backup for REV or the working revision of file, return
-its name; otherwise return nil."
- (when (vc-call make-version-backups-p file)
- (let ((backup-file (vc-version-backup-file-name file rev)))
- (if (file-exists-p backup-file)
- backup-file
- ;; there is no automatic backup, but maybe the user made one manually
- (setq backup-file (vc-version-backup-file-name file rev 'manual))
- (when (file-exists-p backup-file)
- backup-file)))))
-
-(defun vc-revert-file (file)
- "Revert FILE back to the repository working revision it was based on."
- (with-vc-properties
- (list file)
- (let ((backup-file (vc-version-backup-file file)))
- (when backup-file
- (copy-file backup-file file 'ok-if-already-exists 'keep-date)
- (vc-delete-automatic-version-backups file))
- (vc-call revert file backup-file))
- `((vc-state . up-to-date)
- (vc-checkout-time . ,(nth 5 (file-attributes file)))))
- (vc-resynch-buffer file t t))
-
-;;;###autoload
-(defun vc-switch-backend (file backend)
- "Make BACKEND the current version control system for FILE.
-FILE must already be registered in BACKEND. The change is not
-permanent, only for the current session. This function only changes
-VC's perspective on FILE, it does not register or unregister it.
-By default, this command cycles through the registered backends.
-To get a prompt, use a prefix argument."
- (interactive
- (list
- (or buffer-file-name
- (error "There is no version-controlled file in this buffer"))
- (let ((crt-bk (vc-backend buffer-file-name))
- (backends nil))
- (unless crt-bk
- (error "File %s is not under version control" buffer-file-name))
- ;; Find the registered backends.
- (dolist (crt vc-handled-backends)
- (when (and (vc-call-backend crt 'registered buffer-file-name)
- (not (eq crt-bk crt)))
- (push crt backends)))
- ;; Find the next backend.
- (let ((def (car backends))
- (others backends))
- (cond
- ((null others) (error "No other backend to switch to"))
- (current-prefix-arg
- (intern
- (upcase
- (completing-read
- (format "Switch to backend [%s]: " def)
- (mapcar (lambda (b) (list (downcase (symbol-name b)))) backends)
- nil t nil nil (downcase (symbol-name def))))))
- (t def))))))
- (unless (eq backend (vc-backend file))
- (vc-file-clearprops file)
- (vc-file-setprop file 'vc-backend backend)
- ;; Force recomputation of the state
- (unless (vc-call-backend backend 'registered file)
- (vc-file-clearprops file)
- (error "%s is not registered in %s" file backend))
- (vc-mode-line file)))
-
-;;;###autoload
-(defun vc-transfer-file (file new-backend)
- "Transfer FILE to another version control system NEW-BACKEND.
-If NEW-BACKEND has a higher precedence than FILE's current backend
-\(i.e. it comes earlier in `vc-handled-backends'), then register FILE in
-NEW-BACKEND, using the revision number from the current backend as the
-base level. If NEW-BACKEND has a lower precedence than the current
-backend, then commit all changes that were made under the current
-backend to NEW-BACKEND, and unregister FILE from the current backend.
-\(If FILE is not yet registered under NEW-BACKEND, register it.)"
- (let* ((old-backend (vc-backend file))
- (edited (memq (vc-state file) '(edited needs-merge)))
- (registered (vc-call-backend new-backend 'registered file))
- (move
- (and registered ; Never move if not registered in new-backend yet.
- ;; move if new-backend comes later in vc-handled-backends
- (or (memq new-backend (memq old-backend vc-handled-backends))
- (y-or-n-p "Final transfer? "))))
- (comment nil))
- (when (eq old-backend new-backend)
- (error "%s is the current backend of %s" new-backend file))
- (if registered
- (set-file-modes file (logior (file-modes file) 128))
- ;; `registered' might have switched under us.
- (vc-switch-backend file old-backend)
- (let* ((rev (vc-working-revision file))
- (modified-file (and edited (make-temp-file file)))
- (unmodified-file (and modified-file (vc-version-backup-file file))))
- ;; Go back to the base unmodified file.
- (unwind-protect
- (progn
- (when modified-file
- (copy-file file modified-file 'ok-if-already-exists)
- ;; If we have a local copy of the unmodified file, handle that
- ;; here and not in vc-revert-file because we don't want to
- ;; delete that copy -- it is still useful for OLD-BACKEND.
- (if unmodified-file
- (copy-file unmodified-file file
- 'ok-if-already-exists 'keep-date)
- (when (y-or-n-p "Get base revision from repository? ")
- (vc-revert-file file))))
- (vc-call-backend new-backend 'receive-file file rev))
- (when modified-file
- (vc-switch-backend file new-backend)
- (unless (eq (vc-checkout-model new-backend (list file)) 'implicit)
- (vc-checkout file t nil))
- (rename-file modified-file file 'ok-if-already-exists)
- (vc-file-setprop file 'vc-checkout-time nil)))))
- (when move
- (vc-switch-backend file old-backend)
- (setq comment (vc-call-backend old-backend 'comment-history file))
- (vc-call-backend old-backend 'unregister file))
- (vc-switch-backend file new-backend)
- (when (or move edited)
- (vc-file-setprop file 'vc-state 'edited)
- (vc-mode-line file new-backend)
- (vc-checkin file new-backend nil comment (stringp comment)))))
-
-(defun vc-rename-master (oldmaster newfile templates)
- "Rename OLDMASTER to be the master file for NEWFILE based on TEMPLATES."
- (let* ((dir (file-name-directory (expand-file-name oldmaster)))
- (newdir (or (file-name-directory newfile) ""))
- (newbase (file-name-nondirectory newfile))
- (masters
- ;; List of potential master files for `newfile'
- (mapcar
- (lambda (s) (vc-possible-master s newdir newbase))
- templates)))
- (when (or (file-symlink-p oldmaster)
- (file-symlink-p (file-name-directory oldmaster)))
- (error "This is unsafe in the presence of symbolic links"))
- (rename-file
- oldmaster
- (catch 'found
- ;; If possible, keep the master file in the same directory.
- (dolist (f masters)
- (when (and f (string= (file-name-directory (expand-file-name f)) dir))
- (throw 'found f)))
- ;; If not, just use the first possible place.
- (dolist (f masters)
- (and f (or (not (setq dir (file-name-directory f)))
- (file-directory-p dir))
- (throw 'found f)))
- (error "New file lacks a version control directory")))))
-
-;;;###autoload
-(defun vc-delete-file (file)
- "Delete file and mark it as such in the version control system."
- (interactive "fVC delete file: ")
- (setq file (expand-file-name file))
- (let ((buf (get-file-buffer file))
- (backend (vc-backend file)))
- (unless backend
- (error "File %s is not under version control"
- (file-name-nondirectory file)))
- (unless (vc-find-backend-function backend 'delete-file)
- (error "Deleting files under %s is not supported in VC" backend))
- (when (and buf (buffer-modified-p buf))
- (error "Please save or undo your changes before deleting %s" file))
- (let ((state (vc-state file)))
- (when (eq state 'edited)
- (error "Please commit or undo your changes before deleting %s" file))
- (when (eq state 'conflict)
- (error "Please resolve the conflicts before deleting %s" file)))
- (unless (y-or-n-p (format "Really want to delete %s? "
- (file-name-nondirectory file)))
- (error "Abort!"))
- (unless (or (file-directory-p file) (null make-backup-files)
- (not (file-exists-p file)))
- (with-current-buffer (or buf (find-file-noselect file))
- (let ((backup-inhibited nil))
- (backup-buffer))))
- ;; Bind `default-directory' so that the command that the backend
- ;; runs to remove the file is invoked in the correct context.
- (let ((default-directory (file-name-directory file)))
- (vc-call-backend backend 'delete-file file))
- ;; If the backend hasn't deleted the file itself, let's do it for him.
- (when (file-exists-p file) (delete-file file))
- ;; Forget what VC knew about the file.
- (vc-file-clearprops file)
- ;; Make sure the buffer is deleted and the *vc-dir* buffers are
- ;; updated after this.
- (vc-resynch-buffer file nil t)))
-
-;;;###autoload
-(defun vc-rename-file (old new)
- "Rename file OLD to NEW in both work area and repository."
- (interactive "fVC rename file: \nFRename to: ")
- ;; in CL I would have said (setq new (merge-pathnames new old))
- (let ((old-base (file-name-nondirectory old)))
- (when (and (not (string= "" old-base))
- (string= "" (file-name-nondirectory new)))
- (setq new (concat new old-base))))
- (let ((oldbuf (get-file-buffer old)))
- (when (and oldbuf (buffer-modified-p oldbuf))
- (error "Please save files before moving them"))
- (when (get-file-buffer new)
- (error "Already editing new file name"))
- (when (file-exists-p new)
- (error "New file already exists"))
- (let ((state (vc-state old)))
- (unless (memq state '(up-to-date edited))
- (error "Please %s files before moving them"
- (if (stringp state) "check in" "update"))))
- (vc-call rename-file old new)
- (vc-file-clearprops old)
- ;; Move the actual file (unless the backend did it already)
- (when (file-exists-p old) (rename-file old new))
- ;; ?? Renaming a file might change its contents due to keyword expansion.
- ;; We should really check out a new copy if the old copy was precisely equal
- ;; to some checked-in revision. However, testing for this is tricky....
- (when oldbuf
- (with-current-buffer oldbuf
- (let ((buffer-read-only buffer-read-only))
- (set-visited-file-name new))
- (vc-mode-line new (vc-backend new))
- (set-buffer-modified-p nil)))))
-
-;;;###autoload
-(defun vc-update-change-log (&rest args)
- "Find change log file and add entries from recent version control logs.
-Normally, find log entries for all registered files in the default
-directory.
-
-With prefix arg of \\[universal-argument], only find log entries for the current buffer's file.
-
-With any numeric prefix arg, find log entries for all currently visited
-files that are under version control. This puts all the entries in the
-log for the default directory, which may not be appropriate.
-
-From a program, any ARGS are assumed to be filenames for which
-log entries should be gathered."
- (interactive
- (cond ((consp current-prefix-arg) ;C-u
- (list buffer-file-name))
- (current-prefix-arg ;Numeric argument.
- (let ((files nil)
- (buffers (buffer-list))
- file)
- (while buffers
- (setq file (buffer-file-name (car buffers)))
- (and file (vc-backend file)
- (setq files (cons file files)))
- (setq buffers (cdr buffers)))
- files))
- (t
- ;; Don't supply any filenames to backend; this means
- ;; it should find all relevant files relative to
- ;; the default-directory.
- nil)))
- (vc-call-backend (vc-responsible-backend default-directory)
- 'update-changelog args))
-
-;; functions that operate on RCS revision numbers. This code should
-;; also be moved into the backends. It stays for now, however, since
-;; it is used in code below.
-(defun vc-branch-p (rev)
- "Return t if REV is a branch revision."
- (not (eq nil (string-match "\\`[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*\\'" rev))))
-
-;;;###autoload
-(defun vc-branch-part (rev)
- "Return the branch part of a revision number REV."
- (let ((index (string-match "\\.[0-9]+\\'" rev)))
- (when index
- (substring rev 0 index))))
-
-(define-obsolete-function-alias
- 'vc-default-previous-version 'vc-default-previous-revision "23.1")
-
-(defun vc-default-responsible-p (backend file)
- "Indicate whether BACKEND is reponsible for FILE.
-The default is to return nil always."
- nil)
-
-(defun vc-default-could-register (backend file)
- "Return non-nil if BACKEND could be used to register FILE.
-The default implementation returns t for all files."
- t)
-
-(defun vc-default-latest-on-branch-p (backend file)
- "Return non-nil if FILE is the latest on its branch.
-This default implementation always returns non-nil, which means that
-editing non-current revisions is not supported by default."
- t)
-
-(defun vc-default-init-revision (backend) vc-default-init-revision)
-
-(defun vc-default-find-revision (backend file rev buffer)
- "Provide the new `find-revision' op based on the old `checkout' op.
-This is only for compatibility with old backends. They should be updated
-to provide the `find-revision' operation instead."
- (let ((tmpfile (make-temp-file (expand-file-name file))))
- (unwind-protect
- (progn
- (vc-call-backend backend 'checkout file nil rev tmpfile)
- (with-current-buffer buffer
- (insert-file-contents-literally tmpfile)))
- (delete-file tmpfile))))
-
-(defun vc-default-rename-file (backend old new)
- (condition-case nil
- (add-name-to-file old new)
- (error (rename-file old new)))
- (vc-delete-file old)
- (with-current-buffer (find-file-noselect new)
- (vc-register)))
-
-(defalias 'vc-default-check-headers 'ignore)
-
-(declare-function log-edit-mode "log-edit" ())
-
-(defun vc-default-log-edit-mode (backend) (log-edit-mode))
-
-(defun vc-default-log-view-mode (backend) (log-view-mode))
-
-(defun vc-default-show-log-entry (backend rev)
- (with-no-warnings
- (log-view-goto-rev rev)))
-
-(defun vc-default-comment-history (backend file)
- "Return a string with all log entries stored in BACKEND for FILE."
- (when (vc-find-backend-function backend 'print-log)
- (with-current-buffer "*vc*"
- (vc-call-backend backend 'print-log (list file))
- (buffer-string))))
-
-(defun vc-default-receive-file (backend file rev)
- "Let BACKEND receive FILE from another version control system."
- (vc-call-backend backend 'register (list file) rev ""))
-
-(defun vc-default-retrieve-tag (backend dir name update)
- (if (string= name "")
- (progn
- (vc-file-tree-walk
- dir
- (lambda (f) (and
- (vc-up-to-date-p f)
- (vc-error-occurred
- (vc-call-backend backend 'checkout f nil "")
- (when update (vc-resynch-buffer f t t)))))))
- (let ((result (vc-tag-precondition dir)))
- (if (stringp result)
- (error "File %s is locked" result)
- (setq update (and (eq result 'visited) update))
- (vc-file-tree-walk
- dir
- (lambda (f) (vc-error-occurred
- (vc-call-backend backend 'checkout f nil name)
- (when update (vc-resynch-buffer f t t)))))))))
-
-(defun vc-default-revert (backend file contents-done)
- (unless contents-done
- (let ((rev (vc-working-revision file))
- (file-buffer (or (get-file-buffer file) (current-buffer))))
- (message "Checking out %s..." file)
- (let ((failed t)
- (backup-name (car (find-backup-file-name file))))
- (when backup-name
- (copy-file file backup-name 'ok-if-already-exists 'keep-date)
- (unless (file-writable-p file)
- (set-file-modes file (logior (file-modes file) 128))))
- (unwind-protect
- (let ((coding-system-for-read 'no-conversion)
- (coding-system-for-write 'no-conversion))
- (with-temp-file file
- (let ((outbuf (current-buffer)))
- ;; Change buffer to get local value of vc-checkout-switches.
- (with-current-buffer file-buffer
- (let ((default-directory (file-name-directory file)))
- (vc-call-backend backend 'find-revision
- file rev outbuf)))))
- (setq failed nil))
- (when backup-name
- (if failed
- (rename-file backup-name file 'ok-if-already-exists)
- (and (not vc-make-backup-files) (delete-file backup-name))))))
- (message "Checking out %s...done" file))))
-
-(defalias 'vc-default-revision-completion-table 'ignore)
-(defalias 'vc-default-mark-resolved 'ignore)
-
-(defun vc-default-dir-status-files (backend dir files default-state update-function)
- (funcall update-function
- (mapcar (lambda (file) (list file default-state)) files)))
-
-(defun vc-check-headers ()
- "Check if the current file has any headers in it."
- (interactive)
- (vc-call-backend (vc-backend buffer-file-name) 'check-headers))
-
-\f
-
-;; These things should probably be generally available
-
-(defun vc-string-prefix-p (prefix string)
- (let ((lpref (length prefix)))
- (and (>= (length string) lpref)
- (eq t (compare-strings prefix nil nil string nil lpref)))))
-
-(defun vc-file-tree-walk (dirname func &rest args)
- "Walk recursively through DIRNAME.
-Invoke FUNC f ARGS on each VC-managed file f underneath it."
- (vc-file-tree-walk-internal (expand-file-name dirname) func args)
- (message "Traversing directory %s...done" dirname))
-
-(defun vc-file-tree-walk-internal (file func args)
- (if (not (file-directory-p file))
- (when (vc-backend file) (apply func file args))
- (message "Traversing directory %s..." (abbreviate-file-name file))
- (let ((dir (file-name-as-directory file)))
- (mapcar
- (lambda (f) (or
- (string-equal f ".")
- (string-equal f "..")
- (member f vc-directory-exclusion-list)
- (let ((dirf (expand-file-name f dir)))
- (or
- (file-symlink-p dirf) ;; Avoid possible loops.
- (vc-file-tree-walk-internal dirf func args)))))
- (directory-files dir)))))
-
-(provide 'vc)
-
-;; arch-tag: ca82c1de-3091-4e26-af92-460abc6213a6
-;;; vc.el ends here
--- /dev/null
+;;; add-log.el --- change log maintenance commands for Emacs
+
+;; Copyright (C) 1985, 1986, 1988, 1993, 1994, 1997, 1998, 2000, 2001,
+;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This facility is documented in the Emacs Manual.
+
+;; Todo:
+
+;; - Find/use/create _MTN/log if there's a _MTN directory.
+;; - Find/use/create ++log.* if there's an {arch} directory.
+;; - Use an open *VC-Log* or *cvs-commit* buffer if it's related to the
+;; source file.
+;; - Don't add TAB indents (and username?) if inserting entries in those
+;; special places.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'timezone))
+
+(defgroup change-log nil
+ "Change log maintenance."
+ :group 'tools
+ :link '(custom-manual "(emacs)Change Log")
+ :prefix "change-log-"
+ :prefix "add-log-")
+
+
+(defcustom change-log-default-name nil
+ "Name of a change log file for \\[add-change-log-entry]."
+ :type '(choice (const :tag "default" nil)
+ string)
+ :group 'change-log)
+;;;###autoload
+(put 'change-log-default-name 'safe-local-variable 'string-or-null-p)
+
+(defcustom change-log-mode-hook nil
+ "Normal hook run by `change-log-mode'."
+ :type 'hook
+ :group 'change-log)
+
+;; Many modes set this variable, so avoid warnings.
+;;;###autoload
+(defcustom add-log-current-defun-function nil
+ "If non-nil, function to guess name of surrounding function.
+It is used by `add-log-current-defun' in preference to built-in rules.
+Returns function's name as a string, or nil if outside a function."
+ :type '(choice (const nil) function)
+ :group 'change-log)
+
+;;;###autoload
+(defcustom add-log-full-name nil
+ "Full name of user, for inclusion in ChangeLog daily headers.
+This defaults to the value returned by the function `user-full-name'."
+ :type '(choice (const :tag "Default" nil)
+ string)
+ :group 'change-log)
+
+;;;###autoload
+(defcustom add-log-mailing-address nil
+ "Email addresses of user, for inclusion in ChangeLog headers.
+This defaults to the value of `user-mail-address'. In addition to
+being a simple string, this value can also be a list. All elements
+will be recognized as referring to the same user; when creating a new
+ChangeLog entry, one element will be chosen at random."
+ :type '(choice (const :tag "Default" nil)
+ (string :tag "String")
+ (repeat :tag "List of Strings" string))
+ :group 'change-log)
+
+(defcustom add-log-time-format 'add-log-iso8601-time-string
+ "Function that defines the time format.
+For example, `add-log-iso8601-time-string', which gives the
+date in international ISO 8601 format,
+and `current-time-string' are two valid values."
+ :type '(radio (const :tag "International ISO 8601 format"
+ add-log-iso8601-time-string)
+ (const :tag "Old format, as returned by `current-time-string'"
+ current-time-string)
+ (function :tag "Other"))
+ :group 'change-log)
+
+(defcustom add-log-keep-changes-together nil
+ "If non-nil, normally keep day's log entries for one file together.
+
+Log entries for a given file made with \\[add-change-log-entry] or
+\\[add-change-log-entry-other-window] will only be added to others \
+for that file made
+today if this variable is non-nil or that file comes first in today's
+entries. Otherwise another entry for that file will be started. An
+original log:
+
+ * foo (...): ...
+ * bar (...): change 1
+
+in the latter case, \\[add-change-log-entry-other-window] in a \
+buffer visiting `bar', yields:
+
+ * bar (...): -!-
+ * foo (...): ...
+ * bar (...): change 1
+
+and in the former:
+
+ * foo (...): ...
+ * bar (...): change 1
+ (...): -!-
+
+The NEW-ENTRY arg to `add-change-log-entry' can override the effect of
+this variable."
+ :version "20.3"
+ :type 'boolean
+ :group 'change-log)
+
+(defcustom add-log-always-start-new-record nil
+ "If non-nil, `add-change-log-entry' will always start a new record."
+ :version "22.1"
+ :type 'boolean
+ :group 'change-log)
+
+(defcustom add-log-buffer-file-name-function nil
+ "If non-nil, function to call to identify the full filename of a buffer.
+This function is called with no argument. If this is nil, the default is to
+use `buffer-file-name'."
+ :type '(choice (const nil) function)
+ :group 'change-log)
+
+(defcustom add-log-file-name-function nil
+ "If non-nil, function to call to identify the filename for a ChangeLog entry.
+This function is called with one argument, the value of variable
+`buffer-file-name' in that buffer. If this is nil, the default is to
+use the file's name relative to the directory of the change log file."
+ :type '(choice (const nil) function)
+ :group 'change-log)
+
+
+(defcustom change-log-version-info-enabled nil
+ "If non-nil, enable recording version numbers with the changes."
+ :version "21.1"
+ :type 'boolean
+ :group 'change-log)
+
+(defcustom change-log-version-number-regexp-list
+ (let ((re "\\([0-9]+\.[0-9.]+\\)"))
+ (list
+ ;; (defconst ad-version "2.15"
+ (concat "^(def[^ \t\n]+[ \t]+[^ \t\n][ \t]\"" re)
+ ;; Revision: pcl-cvs.el,v 1.72 1999/09/05 20:21:54 monnier Exp
+ (concat "^;+ *Revision: +[^ \t\n]+[ \t]+" re)))
+ "List of regexps to search for version number.
+The version number must be in group 1.
+Note: The search is conducted only within 10%, at the beginning of the file."
+ :version "21.1"
+ :type '(repeat regexp)
+ :group 'change-log)
+
+(defface change-log-date
+ '((t (:inherit font-lock-string-face)))
+ "Face used to highlight dates in date lines."
+ :version "21.1"
+ :group 'change-log)
+(define-obsolete-face-alias 'change-log-date-face 'change-log-date "22.1")
+
+(defface change-log-name
+ '((t (:inherit font-lock-constant-face)))
+ "Face for highlighting author names."
+ :version "21.1"
+ :group 'change-log)
+(define-obsolete-face-alias 'change-log-name-face 'change-log-name "22.1")
+
+(defface change-log-email
+ '((t (:inherit font-lock-variable-name-face)))
+ "Face for highlighting author email addresses."
+ :version "21.1"
+ :group 'change-log)
+(define-obsolete-face-alias 'change-log-email-face 'change-log-email "22.1")
+
+(defface change-log-file
+ '((t (:inherit font-lock-function-name-face)))
+ "Face for highlighting file names."
+ :version "21.1"
+ :group 'change-log)
+(define-obsolete-face-alias 'change-log-file-face 'change-log-file "22.1")
+
+(defface change-log-list
+ '((t (:inherit font-lock-keyword-face)))
+ "Face for highlighting parenthesized lists of functions or variables."
+ :version "21.1"
+ :group 'change-log)
+(define-obsolete-face-alias 'change-log-list-face 'change-log-list "22.1")
+
+(defface change-log-conditionals
+ '((t (:inherit font-lock-variable-name-face)))
+ "Face for highlighting conditionals of the form `[...]'."
+ :version "21.1"
+ :group 'change-log)
+(define-obsolete-face-alias 'change-log-conditionals-face
+ 'change-log-conditionals "22.1")
+
+(defface change-log-function
+ '((t (:inherit font-lock-variable-name-face)))
+ "Face for highlighting items of the form `<....>'."
+ :version "21.1"
+ :group 'change-log)
+(define-obsolete-face-alias 'change-log-function-face
+ 'change-log-function "22.1")
+
+(defface change-log-acknowledgement
+ '((t (:inherit font-lock-comment-face)))
+ "Face for highlighting acknowledgments."
+ :version "21.1"
+ :group 'change-log)
+(define-obsolete-face-alias 'change-log-acknowledgement-face
+ 'change-log-acknowledgement "22.1")
+
+(defconst change-log-file-names-re "^\\( +\\|\t\\)\\* \\([^ ,:([\n]+\\)")
+(defconst change-log-start-entry-re "^\\sw.........[0-9:+ ]*")
+
+(defvar change-log-font-lock-keywords
+ `(;;
+ ;; Date lines, new (2000-01-01) and old (Sat Jan 1 00:00:00 2000) styles.
+ ;; Fixme: this regepx is just an approximate one and may match
+ ;; wrongly with a non-date line existing as a random note. In
+ ;; addition, using any kind of fixed setting like this doesn't
+ ;; work if a user customizes add-log-time-format.
+ ("^[0-9-]+ +\\|^ \\{11,\\}\\|^\\(Sun\\|Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\) [A-z][a-z][a-z] [0-9:+ ]+"
+ (0 'change-log-date-face)
+ ;; Name and e-mail; some people put e-mail in parens, not angles.
+ ("\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" nil nil
+ (1 'change-log-name)
+ (2 'change-log-email)))
+ ;;
+ ;; File names.
+ (,change-log-file-names-re
+ (2 'change-log-file)
+ ;; Possibly further names in a list:
+ ("\\=, \\([^ ,:([\n]+\\)" nil nil (1 'change-log-file))
+ ;; Possibly a parenthesized list of names:
+ ("\\= (\\([^(),\n]+\\|(\\(setf\\|SETF\\) [^() ,\n]+)\\)"
+ nil nil (1 'change-log-list))
+ ("\\=, *\\([^(),\n]+\\|(\\(setf\\|SETF\\) [^() ,\n]+)\\)"
+ nil nil (1 'change-log-list)))
+ ;;
+ ;; Function or variable names.
+ ("^\\( +\\|\t\\)(\\([^(),\n]+\\|(\\(setf\\|SETF\\) [^() ,\n]+)\\)"
+ (2 'change-log-list)
+ ("\\=, *\\([^(),\n]+\\|(\\(setf\\|SETF\\) [^() ,\n]+)\\)" nil nil
+ (1 'change-log-list)))
+ ;;
+ ;; Conditionals.
+ ("\\[!?\\([^]\n]+\\)\\]\\(:\\| (\\)" (1 'change-log-conditionals))
+ ;;
+ ;; Function of change.
+ ("<\\([^>\n]+\\)>\\(:\\| (\\)" (1 'change-log-function))
+ ;;
+ ;; Acknowledgements.
+ ;; Don't include plain "From" because that is vague;
+ ;; we want to encourage people to say something more specific.
+ ;; Note that the FSF does not use "Patches by"; our convention
+ ;; is to put the name of the author of the changes at the top
+ ;; of the change log entry.
+ ("\\(^\\( +\\|\t\\)\\| \\)\\(Patch\\(es\\)? by\\|Report\\(ed by\\| from\\)\\|Suggest\\(ed by\\|ion from\\)\\)"
+ 3 'change-log-acknowledgement))
+ "Additional expressions to highlight in Change Log mode.")
+
+(defun change-log-search-file-name (where)
+ "Return the file-name for the change under point."
+ (save-excursion
+ (goto-char where)
+ (beginning-of-line 1)
+ (if (looking-at change-log-start-entry-re)
+ ;; We are at the start of an entry, search forward for a file
+ ;; name.
+ (progn
+ (re-search-forward change-log-file-names-re nil t)
+ (match-string-no-properties 2))
+ (if (looking-at change-log-file-names-re)
+ ;; We found a file name.
+ (match-string-no-properties 2)
+ ;; Look backwards for either a file name or the log entry start.
+ (if (re-search-backward
+ (concat "\\(" change-log-start-entry-re
+ "\\)\\|\\("
+ change-log-file-names-re "\\)") nil t)
+ (if (match-beginning 1)
+ ;; We got the start of the entry, look forward for a
+ ;; file name.
+ (progn
+ (re-search-forward change-log-file-names-re nil t)
+ (match-string-no-properties 2))
+ (match-string-no-properties 4))
+ ;; We must be before any file name, look forward.
+ (re-search-forward change-log-file-names-re nil t)
+ (match-string-no-properties 2))))))
+
+(defun change-log-find-file ()
+ "Visit the file for the change under point."
+ (interactive)
+ (let ((file (change-log-search-file-name (point))))
+ (if (and file (file-exists-p file))
+ (find-file file)
+ (message "No such file or directory: %s" file))))
+
+(defun change-log-search-tag-name-1 (&optional from)
+ "Search for a tag name within subexpression 1 of last match.
+Optional argument FROM specifies a buffer position where the tag
+name should be located. Return value is a cons whose car is the
+string representing the tag and whose cdr is the position where
+the tag was found."
+ (save-restriction
+ (narrow-to-region (match-beginning 1) (match-end 1))
+ (when from (goto-char from))
+ ;; The regexp below skips any symbol near `point' (FROM) followed by
+ ;; whitespace and another symbol. This should skip, for example,
+ ;; "struct" in a specification like "(struct buffer)" and move to
+ ;; "buffer". A leading paren is ignored.
+ (when (looking-at
+ "[(]?\\(?:\\(?:\\sw\\|\\s_\\)+\\(?:[ \t]+\\(\\sw\\|\\s_\\)+\\)\\)")
+ (goto-char (match-beginning 1)))
+ (cons (find-tag-default) (point))))
+
+(defconst change-log-tag-re
+ "(\\(\\(?:\\sw\\|\\s_\\)+\\(?:[, \t]+\\(?:\\sw\\|\\s_\\)+\\)*\\))"
+ "Regexp matching a tag name in change log entries.")
+
+(defun change-log-search-tag-name (&optional at)
+ "Search for a tag name near `point'.
+Optional argument AT non-nil means search near buffer position AT.
+Return value is a cons whose car is the string representing
+the tag and whose cdr is the position where the tag was found."
+ (save-excursion
+ (goto-char (setq at (or at (point))))
+ (save-restriction
+ (widen)
+ (or (condition-case nil
+ ;; Within parenthesized list?
+ (save-excursion
+ (backward-up-list)
+ (when (looking-at change-log-tag-re)
+ (change-log-search-tag-name-1 at)))
+ (error nil))
+ (condition-case nil
+ ;; Before parenthesized list on same line?
+ (save-excursion
+ (when (and (skip-chars-forward " \t")
+ (looking-at change-log-tag-re))
+ (change-log-search-tag-name-1)))
+ (error nil))
+ (condition-case nil
+ ;; Near file name?
+ (save-excursion
+ (when (and (progn
+ (beginning-of-line)
+ (looking-at change-log-file-names-re))
+ (goto-char (match-end 0))
+ (skip-syntax-forward " ")
+ (looking-at change-log-tag-re))
+ (change-log-search-tag-name-1)))
+ (error nil))
+ (condition-case nil
+ ;; Anywhere else within current entry?
+ (let ((from
+ (save-excursion
+ (end-of-line)
+ (if (re-search-backward change-log-start-entry-re nil t)
+ (match-beginning 0)
+ (point-min))))
+ (to
+ (save-excursion
+ (end-of-line)
+ (if (re-search-forward change-log-start-entry-re nil t)
+ (match-beginning 0)
+ (point-max)))))
+ (when (and (< from to) (<= from at) (<= at to))
+ (save-restriction
+ ;; Narrow to current change log entry.
+ (narrow-to-region from to)
+ (cond
+ ((re-search-backward change-log-tag-re nil t)
+ (narrow-to-region (match-beginning 1) (match-end 1))
+ (goto-char (point-max))
+ (cons (find-tag-default) (point-max)))
+ ((re-search-forward change-log-tag-re nil t)
+ (narrow-to-region (match-beginning 1) (match-end 1))
+ (goto-char (point-min))
+ (cons (find-tag-default) (point-min)))))))
+ (error nil))))))
+
+(defvar change-log-find-head nil)
+(defvar change-log-find-tail nil)
+(defvar change-log-find-window nil)
+
+(defun change-log-goto-source-1 (tag regexp file buffer
+ &optional window first last)
+ "Search for tag TAG in buffer BUFFER visiting file FILE.
+REGEXP is a regular expression for TAG. The remaining arguments
+are optional: WINDOW denotes the window to display the results of
+the search. FIRST is a position in BUFFER denoting the first
+match from previous searches for TAG. LAST is the position in
+BUFFER denoting the last match for TAG in the last search."
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (if last
+ (progn
+ ;; When LAST is set make sure we continue from the next
+ ;; line end to not find the same tag again.
+ (goto-char last)
+ (end-of-line)
+ (condition-case nil
+ ;; Try to go to the end of the current defun to avoid
+ ;; false positives within the current defun's body
+ ;; since these would match `add-log-current-defun'.
+ (end-of-defun)
+ ;; Don't fall behind when `end-of-defun' fails.
+ (error (progn (goto-char last) (end-of-line))))
+ (setq last nil))
+ ;; When LAST was not set start at beginning of BUFFER.
+ (goto-char (point-min)))
+ (let (current-defun)
+ (while (and (not last) (re-search-forward regexp nil t))
+ ;; Verify that `add-log-current-defun' invoked at the end
+ ;; of the match returns TAG. This heuristic works well
+ ;; whenever the name of the defun occurs within the first
+ ;; line of the defun.
+ (setq current-defun (add-log-current-defun))
+ (when (and current-defun (string-equal current-defun tag))
+ ;; Record this as last match.
+ (setq last (line-beginning-position))
+ ;; Record this as first match when there's none.
+ (unless first (setq first last)))))))
+ (if (or last first)
+ (with-selected-window
+ (setq change-log-find-window (or window (display-buffer buffer)))
+ (if last
+ (progn
+ (when (or (< last (point-min)) (> last (point-max)))
+ ;; Widen to show TAG.
+ (widen))
+ (push-mark)
+ (goto-char last))
+ ;; When there are no more matches go (back) to FIRST.
+ (message "No more matches for tag `%s' in file `%s'" tag file)
+ (setq last first)
+ (goto-char first))
+ ;; Return new "tail".
+ (list (selected-window) first last))
+ (message "Source location of tag `%s' not found in file `%s'" tag file)
+ nil)))
+
+(defun change-log-goto-source ()
+ "Go to source location of \"change log tag\" near `point'.
+A change log tag is a symbol within a parenthesized,
+comma-separated list. If no suitable tag can be found nearby,
+try to visit the file for the change under `point' instead."
+ (interactive)
+ (if (and (eq last-command 'change-log-goto-source)
+ change-log-find-tail)
+ (setq change-log-find-tail
+ (condition-case nil
+ (apply 'change-log-goto-source-1
+ (append change-log-find-head change-log-find-tail))
+ (error
+ (format "Cannot find more matches for tag `%s' in file `%s'"
+ (car change-log-find-head)
+ (nth 2 change-log-find-head)))))
+ (save-excursion
+ (let* ((at (point))
+ (tag-at (change-log-search-tag-name))
+ (tag (car tag-at))
+ (file (when tag-at (change-log-search-file-name (cdr tag-at))))
+ (file-at (when file (match-beginning 2)))
+ ;; `file-2' is the file `change-log-search-file-name' finds
+ ;; at `point'. We use `file-2' as a fallback when `tag' or
+ ;; `file' are not suitable for some reason.
+ (file-2 (change-log-search-file-name at))
+ (file-2-at (when file-2 (match-beginning 2))))
+ (cond
+ ((and (or (not tag) (not file) (not (file-exists-p file)))
+ (or (not file-2) (not (file-exists-p file-2))))
+ (error "Cannot find tag or file near `point'"))
+ ((and file-2 (file-exists-p file-2)
+ (or (not tag) (not file) (not (file-exists-p file))
+ (and (or (and (< file-at file-2-at) (<= file-2-at at))
+ (and (<= at file-2-at) (< file-2-at file-at))))))
+ ;; We either have not found a suitable file name or `file-2'
+ ;; provides a "better" file name wrt `point'. Go to the
+ ;; buffer of `file-2' instead.
+ (setq change-log-find-window
+ (display-buffer (find-file-noselect file-2))))
+ (t
+ (setq change-log-find-head
+ (list tag (concat "\\_<" (regexp-quote tag) "\\_>")
+ file (find-file-noselect file)))
+ (condition-case nil
+ (setq change-log-find-tail
+ (apply 'change-log-goto-source-1 change-log-find-head))
+ (error
+ (format "Cannot find matches for tag `%s' in file `%s'"
+ tag file)))))))))
+
+(defun change-log-next-error (&optional argp reset)
+ "Move to the Nth (default 1) next match in a ChangeLog buffer.
+Compatibility function for \\[next-error] invocations."
+ (interactive "p")
+ (let* ((argp (or argp 0))
+ (count (abs argp)) ; how many cycles
+ (down (< argp 0)) ; are we going down? (is argp negative?)
+ (up (not down))
+ (search-function (if up 're-search-forward 're-search-backward)))
+
+ ;; set the starting position
+ (goto-char (cond (reset (point-min))
+ (down (line-beginning-position))
+ (up (line-end-position))
+ ((point))))
+
+ (funcall search-function change-log-file-names-re nil t count))
+
+ (beginning-of-line)
+ ;; if we found a place to visit...
+ (when (looking-at change-log-file-names-re)
+ (let (change-log-find-window)
+ (change-log-goto-source)
+ (when change-log-find-window
+ ;; Select window displaying source file.
+ (select-window change-log-find-window)))))
+
+(defvar change-log-mode-map
+ (let ((map (make-sparse-keymap))
+ (menu-map (make-sparse-keymap)))
+ (define-key map [?\C-c ?\C-p] 'add-log-edit-prev-comment)
+ (define-key map [?\C-c ?\C-n] 'add-log-edit-next-comment)
+ (define-key map [?\C-c ?\C-f] 'change-log-find-file)
+ (define-key map [?\C-c ?\C-c] 'change-log-goto-source)
+ (define-key map [menu-bar changelog] (cons "ChangeLog" menu-map))
+ (define-key menu-map [gs]
+ '(menu-item "Go To Source" change-log-goto-source
+ :help "Go to source location of ChangeLog tag near point"))
+ (define-key menu-map [ff]
+ '(menu-item "Find File" change-log-find-file
+ :help "Visit the file for the change under point"))
+ (define-key menu-map [sep] '("--"))
+ (define-key menu-map [nx]
+ '(menu-item "Next Log-Edit Comment" add-log-edit-next-comment
+ :help "Cycle forward through Log-Edit mode comment history"))
+ (define-key menu-map [pr]
+ '(menu-item "Previous Log-Edit Comment" add-log-edit-prev-comment
+ :help "Cycle backward through Log-Edit mode comment history"))
+ map)
+ "Keymap for Change Log major mode.")
+
+;; It used to be called change-log-time-zone-rule but really should be
+;; called add-log-time-zone-rule since it's only used from add-log-* code.
+(defvaralias 'change-log-time-zone-rule 'add-log-time-zone-rule)
+(defvar add-log-time-zone-rule nil
+ "Time zone used for calculating change log time stamps.
+It takes the same format as the TZ argument of `set-time-zone-rule'.
+If nil, use local time.
+If t, use universal time.")
+(put 'add-log-time-zone-rule 'safe-local-variable
+ '(lambda (x) (or (booleanp x) (stringp x))))
+
+(defun add-log-iso8601-time-zone (&optional time)
+ (let* ((utc-offset (or (car (current-time-zone time)) 0))
+ (sign (if (< utc-offset 0) ?- ?+))
+ (sec (abs utc-offset))
+ (ss (% sec 60))
+ (min (/ sec 60))
+ (mm (% min 60))
+ (hh (/ min 60)))
+ (format (cond ((not (zerop ss)) "%c%02d:%02d:%02d")
+ ((not (zerop mm)) "%c%02d:%02d")
+ (t "%c%02d"))
+ sign hh mm ss)))
+
+(defvar add-log-iso8601-with-time-zone nil)
+
+(defun add-log-iso8601-time-string ()
+ (let ((time (format-time-string "%Y-%m-%d"
+ nil (eq t add-log-time-zone-rule))))
+ (if add-log-iso8601-with-time-zone
+ (concat time " " (add-log-iso8601-time-zone))
+ time)))
+
+(defun change-log-name ()
+ "Return (system-dependent) default name for a change log file."
+ (or change-log-default-name
+ "ChangeLog"))
+
+(defun add-log-edit-prev-comment (arg)
+ "Cycle backward through Log-Edit mode comment history.
+With a numeric prefix ARG, go back ARG comments."
+ (interactive "*p")
+ (save-restriction
+ (narrow-to-region (point)
+ (if (memq last-command '(add-log-edit-prev-comment
+ add-log-edit-next-comment))
+ (mark) (point)))
+ (when (fboundp 'log-edit-previous-comment)
+ (log-edit-previous-comment arg)
+ (indent-region (point-min) (point-max))
+ (goto-char (point-min))
+ (unless (save-restriction (widen) (bolp))
+ (delete-region (point) (progn (skip-chars-forward " \t\n") (point))))
+ (set-mark (point-min))
+ (goto-char (point-max))
+ (delete-region (point) (progn (skip-chars-backward " \t\n") (point))))))
+
+(defun add-log-edit-next-comment (arg)
+ "Cycle forward through Log-Edit mode comment history.
+With a numeric prefix ARG, go back ARG comments."
+ (interactive "*p")
+ (add-log-edit-prev-comment (- arg)))
+
+;;;###autoload
+(defun prompt-for-change-log-name ()
+ "Prompt for a change log name."
+ (let* ((default (change-log-name))
+ (name (expand-file-name
+ (read-file-name (format "Log file (default %s): " default)
+ nil default))))
+ ;; Handle something that is syntactically a directory name.
+ ;; Look for ChangeLog or whatever in that directory.
+ (if (string= (file-name-nondirectory name) "")
+ (expand-file-name (file-name-nondirectory default)
+ name)
+ ;; Handle specifying a file that is a directory.
+ (if (file-directory-p name)
+ (expand-file-name (file-name-nondirectory default)
+ (file-name-as-directory name))
+ name))))
+
+(defun change-log-version-number-search ()
+ "Return version number of current buffer's file.
+This is the value returned by `vc-working-revision' or, if that is
+nil, by matching `change-log-version-number-regexp-list'."
+ (let* ((size (buffer-size))
+ (limit
+ ;; The version number can be anywhere in the file, but
+ ;; restrict search to the file beginning: 10% should be
+ ;; enough to prevent some mishits.
+ ;;
+ ;; Apply percentage only if buffer size is bigger than
+ ;; approx 100 lines.
+ (if (> size (* 100 80)) (+ (point) (/ size 10)))))
+ (or (and buffer-file-name (vc-working-revision buffer-file-name))
+ (save-restriction
+ (widen)
+ (let ((regexps change-log-version-number-regexp-list)
+ version)
+ (while regexps
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward (pop regexps) limit t)
+ (setq version (match-string 1)
+ regexps nil))))
+ version)))))
+
+(declare-function diff-find-source-location "diff-mode"
+ (&optional other-file reverse noprompt))
+
+;;;###autoload
+(defun find-change-log (&optional file-name buffer-file)
+ "Find a change log file for \\[add-change-log-entry] and return the name.
+
+Optional arg FILE-NAME specifies the file to use.
+If FILE-NAME is nil, use the value of `change-log-default-name'.
+If `change-log-default-name' is nil, behave as though it were 'ChangeLog'
+\(or whatever we use on this operating system).
+
+If `change-log-default-name' contains a leading directory component, then
+simply find it in the current directory. Otherwise, search in the current
+directory and its successive parents for a file so named.
+
+Once a file is found, `change-log-default-name' is set locally in the
+current buffer to the complete file name.
+Optional arg BUFFER-FILE overrides `buffer-file-name'."
+ ;; If we are called from a diff, first switch to the source buffer;
+ ;; in order to respect buffer-local settings of change-log-default-name, etc.
+ (with-current-buffer (let ((buff (if (eq major-mode 'diff-mode)
+ (car (ignore-errors
+ (diff-find-source-location))))))
+ (if (buffer-live-p buff) buff
+ (current-buffer)))
+ ;; If user specified a file name or if this buffer knows which one to use,
+ ;; just use that.
+ (or file-name
+ (setq file-name (and change-log-default-name
+ (file-name-directory change-log-default-name)
+ change-log-default-name))
+ (progn
+ ;; Chase links in the source file
+ ;; and use the change log in the dir where it points.
+ (setq file-name (or (and (or buffer-file buffer-file-name)
+ (file-name-directory
+ (file-chase-links
+ (or buffer-file buffer-file-name))))
+ default-directory))
+ (if (file-directory-p file-name)
+ (setq file-name (expand-file-name (change-log-name) file-name)))
+ ;; Chase links before visiting the file.
+ ;; This makes it easier to use a single change log file
+ ;; for several related directories.
+ (setq file-name (file-chase-links file-name))
+ (setq file-name (expand-file-name file-name))
+ ;; Move up in the dir hierarchy till we find a change log file.
+ (let ((file1 file-name)
+ parent-dir)
+ (while (and (not (or (get-file-buffer file1) (file-exists-p file1)))
+ (progn (setq parent-dir
+ (file-name-directory
+ (directory-file-name
+ (file-name-directory file1))))
+ ;; Give up if we are already at the root dir.
+ (not (string= (file-name-directory file1)
+ parent-dir))))
+ ;; Move up to the parent dir and try again.
+ (setq file1 (expand-file-name
+ (file-name-nondirectory (change-log-name))
+ parent-dir)))
+ ;; If we found a change log in a parent, use that.
+ (if (or (get-file-buffer file1) (file-exists-p file1))
+ (setq file-name file1)))))
+ ;; Make a local variable in this buffer so we needn't search again.
+ (set (make-local-variable 'change-log-default-name) file-name))
+ file-name)
+
+(defun add-log-file-name (buffer-file log-file)
+ ;; Never want to add a change log entry for the ChangeLog file itself.
+ (unless (or (null buffer-file) (string= buffer-file log-file))
+ (if add-log-file-name-function
+ (funcall add-log-file-name-function buffer-file)
+ (setq buffer-file
+ (file-relative-name buffer-file (file-name-directory log-file)))
+ ;; If we have a backup file, it's presumably because we're
+ ;; comparing old and new versions (e.g. for deleted
+ ;; functions) and we'll want to use the original name.
+ (if (backup-file-name-p buffer-file)
+ (file-name-sans-versions buffer-file)
+ buffer-file))))
+
+;;;###autoload
+(defun add-change-log-entry (&optional whoami file-name other-window new-entry
+ put-new-entry-on-new-line)
+ "Find change log file, and add an entry for today and an item for this file.
+Optional arg WHOAMI (interactive prefix) non-nil means prompt for user
+name and email (stored in `add-log-full-name' and `add-log-mailing-address').
+
+Second arg FILE-NAME is file name of the change log.
+If nil, use the value of `change-log-default-name'.
+
+Third arg OTHER-WINDOW non-nil means visit in other window.
+
+Fourth arg NEW-ENTRY non-nil means always create a new entry at the front;
+never append to an existing entry. Option `add-log-keep-changes-together'
+otherwise affects whether a new entry is created.
+
+Fifth arg PUT-NEW-ENTRY-ON-NEW-LINE non-nil means that if a new
+entry is created, put it on a new line by itself, do not put it
+after a comma on an existing line.
+
+Option `add-log-always-start-new-record' non-nil means always create a
+new record, even when the last record was made on the same date and by
+the same person.
+
+The change log file can start with a copyright notice and a copying
+permission notice. The first blank line indicates the end of these
+notices.
+
+Today's date is calculated according to `add-log-time-zone-rule' if
+non-nil, otherwise in local time."
+ (interactive (list current-prefix-arg
+ (prompt-for-change-log-name)))
+ (let* ((defun (add-log-current-defun))
+ (version (and change-log-version-info-enabled
+ (change-log-version-number-search)))
+ (buf-file-name (if add-log-buffer-file-name-function
+ (funcall add-log-buffer-file-name-function)
+ buffer-file-name))
+ (buffer-file (if buf-file-name (expand-file-name buf-file-name)))
+ (file-name (expand-file-name (find-change-log file-name buffer-file)))
+ ;; Set ITEM to the file name to use in the new item.
+ (item (add-log-file-name buffer-file file-name)))
+
+ (unless (equal file-name buffer-file-name)
+ (cond
+ ((equal file-name (buffer-file-name (window-buffer (selected-window))))
+ ;; If the selected window already shows the desired buffer don't show
+ ;; it again (particularly important if other-window is true).
+ ;; This is important for diff-add-change-log-entries-other-window.
+ (set-buffer (window-buffer (selected-window))))
+ ((or other-window (window-dedicated-p (selected-window)))
+ (find-file-other-window file-name))
+ (t (find-file file-name))))
+ (or (derived-mode-p 'change-log-mode)
+ (change-log-mode))
+ (undo-boundary)
+ (goto-char (point-min))
+
+ (let ((full-name (or add-log-full-name (user-full-name)))
+ (mailing-address (or add-log-mailing-address user-mail-address)))
+
+ (when whoami
+ (setq full-name (read-string "Full name: " full-name))
+ ;; Note that some sites have room and phone number fields in
+ ;; full name which look silly when inserted. Rather than do
+ ;; anything about that here, let user give prefix argument so that
+ ;; s/he can edit the full name field in prompter if s/he wants.
+ (setq mailing-address
+ (read-string "Mailing address: " mailing-address)))
+
+ ;; If file starts with a copyright and permission notice, skip them.
+ ;; Assume they end at first blank line.
+ (when (looking-at "Copyright")
+ (search-forward "\n\n")
+ (skip-chars-forward "\n"))
+
+ ;; Advance into first entry if it is usable; else make new one.
+ (let ((new-entries
+ (mapcar (lambda (addr)
+ (concat
+ (if (stringp add-log-time-zone-rule)
+ (let ((tz (getenv "TZ")))
+ (unwind-protect
+ (progn
+ (set-time-zone-rule add-log-time-zone-rule)
+ (funcall add-log-time-format))
+ (set-time-zone-rule tz)))
+ (funcall add-log-time-format))
+ " " full-name
+ " <" addr ">"))
+ (if (consp mailing-address)
+ mailing-address
+ (list mailing-address)))))
+ (if (and (not add-log-always-start-new-record)
+ (let ((hit nil))
+ (dolist (entry new-entries hit)
+ (when (looking-at (regexp-quote entry))
+ (setq hit t)))))
+ (forward-line 1)
+ (insert (nth (random (length new-entries))
+ new-entries)
+ (if use-hard-newlines hard-newline "\n")
+ (if use-hard-newlines hard-newline "\n"))
+ (forward-line -1))))
+
+ ;; Determine where we should stop searching for a usable
+ ;; item to add to, within this entry.
+ (let ((bound
+ (save-excursion
+ (if (looking-at "\n*[^\n* \t]")
+ (skip-chars-forward "\n")
+ (if add-log-keep-changes-together
+ (forward-page) ; page delimits entries for date
+ (forward-paragraph))) ; paragraph delimits entries for file
+ (point))))
+
+ ;; Now insert the new line for this item.
+ (cond ((re-search-forward "^\\s *\\*\\s *$" bound t)
+ ;; Put this file name into the existing empty item.
+ (if item
+ (insert item)))
+ ((and (not new-entry)
+ (let (case-fold-search)
+ (re-search-forward
+ (concat (regexp-quote (concat "* " item))
+ ;; Don't accept `foo.bar' when
+ ;; looking for `foo':
+ "\\(\\s \\|[(),:]\\)")
+ bound t)))
+ ;; Add to the existing item for the same file.
+ (re-search-forward "^\\s *$\\|^\\s \\*")
+ (goto-char (match-beginning 0))
+ ;; Delete excess empty lines; make just 2.
+ (while (and (not (eobp)) (looking-at "^\\s *$"))
+ (delete-region (point) (line-beginning-position 2)))
+ (insert (if use-hard-newlines hard-newline "\n")
+ (if use-hard-newlines hard-newline "\n"))
+ (forward-line -2)
+ (indent-relative-maybe))
+ (t
+ ;; Make a new item.
+ (while (looking-at "\\sW")
+ (forward-line 1))
+ (while (and (not (eobp)) (looking-at "^\\s *$"))
+ (delete-region (point) (line-beginning-position 2)))
+ (insert (if use-hard-newlines hard-newline "\n")
+ (if use-hard-newlines hard-newline "\n")
+ (if use-hard-newlines hard-newline "\n"))
+ (forward-line -2)
+ (indent-to left-margin)
+ (insert "* ")
+ (if item (insert item)))))
+ ;; Now insert the function name, if we have one.
+ ;; Point is at the item for this file,
+ ;; either at the end of the line or at the first blank line.
+ (if (not defun)
+ ;; No function name, so put in a colon unless we have just a star.
+ (unless (save-excursion
+ (beginning-of-line 1)
+ (looking-at "\\s *\\(\\*\\s *\\)?$"))
+ (insert ": ")
+ (if version (insert version ?\s)))
+ ;; Make it easy to get rid of the function name.
+ (undo-boundary)
+ (unless (save-excursion
+ (beginning-of-line 1)
+ (looking-at "\\s *$"))
+ (insert ?\s))
+ ;; See if the prev function name has a message yet or not.
+ ;; If not, merge the two items.
+ (let ((pos (point-marker)))
+ (skip-syntax-backward " ")
+ (skip-chars-backward "):")
+ (if (and (not put-new-entry-on-new-line)
+ (looking-at "):")
+ (let ((pos (save-excursion (backward-sexp 1) (point))))
+ (when (equal (buffer-substring pos (point)) defun)
+ (delete-region pos (point)))
+ (> fill-column (+ (current-column) (length defun) 4))))
+ (progn (skip-chars-backward ", ")
+ (delete-region (point) pos)
+ (unless (memq (char-before) '(?\()) (insert ", ")))
+ (when (and (not put-new-entry-on-new-line) (looking-at "):"))
+ (delete-region (+ 1 (point)) (line-end-position)))
+ (goto-char pos)
+ (insert "("))
+ (set-marker pos nil))
+ (insert defun "): ")
+ (if version (insert version ?\s)))))
+
+;;;###autoload
+(defun add-change-log-entry-other-window (&optional whoami file-name)
+ "Find change log file in other window and add entry and item.
+This is just like `add-change-log-entry' except that it displays
+the change log file in another window."
+ (interactive (if current-prefix-arg
+ (list current-prefix-arg
+ (prompt-for-change-log-name))))
+ (add-change-log-entry whoami file-name t))
+
+
+(defvar change-log-indent-text 0)
+
+(defun change-log-fill-parenthesized-list ()
+ ;; Fill parenthesized lists of names according to GNU standards.
+ ;; * file-name.ext (very-long-foo, very-long-bar, very-long-foobar):
+ ;; should be filled as
+ ;; * file-name.ext (very-long-foo, very-long-bar)
+ ;; (very-long-foobar):
+ (save-excursion
+ (end-of-line 0)
+ (skip-chars-backward " \t")
+ (when (and (equal (char-before) ?\,)
+ (> (point) (1+ (point-min))))
+ (condition-case nil
+ (when (save-excursion
+ (and (prog2
+ (up-list -1)
+ (equal (char-after) ?\()
+ (skip-chars-backward " \t"))
+ (or (bolp)
+ ;; Skip everything but a whitespace or asterisk.
+ (and (not (zerop (skip-chars-backward "^ \t\n*")))
+ (skip-chars-backward " \t")
+ ;; We want one asterisk here.
+ (= (skip-chars-backward "*") -1)
+ (skip-chars-backward " \t")
+ (bolp)))))
+ ;; Delete the comma.
+ (delete-char -1)
+ ;; Close list on previous line.
+ (insert ")")
+ (skip-chars-forward " \t\n")
+ ;; Start list on new line.
+ (insert-before-markers "("))
+ (error nil)))))
+
+(defun change-log-indent ()
+ (change-log-fill-parenthesized-list)
+ (let* ((indent
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ (cond
+ ((and (looking-at "\\(.*\\) [^ \n].*[^ \n] <.*>\\(?: +(.*)\\)? *$")
+ ;; Matching the output of add-log-time-format is difficult,
+ ;; but I'll get it has at least two adjacent digits.
+ (string-match "[[:digit:]][[:digit:]]" (match-string 1)))
+ 0)
+ ((looking-at "[^*(]")
+ (+ (current-left-margin) change-log-indent-text))
+ (t (current-left-margin)))))
+ (pos (save-excursion (indent-line-to indent) (point))))
+ (if (> pos (point)) (goto-char pos))))
+
+
+(defvar smerge-resolve-function)
+(defvar copyright-at-end-flag)
+
+;;;###autoload
+(define-derived-mode change-log-mode text-mode "Change Log"
+ "Major mode for editing change logs; like Indented Text mode.
+Prevents numeric backups and sets `left-margin' to 8 and `fill-column' to 74.
+New log entries are usually made with \\[add-change-log-entry] or \\[add-change-log-entry-other-window].
+Each entry behaves as a paragraph, and the entries for one day as a page.
+Runs `change-log-mode-hook'.
+\n\\{change-log-mode-map}"
+ (setq left-margin 8
+ fill-column 74
+ indent-tabs-mode t
+ tab-width 8
+ show-trailing-whitespace t)
+ (set (make-local-variable 'fill-forward-paragraph-function)
+ 'change-log-fill-forward-paragraph)
+ ;; Make sure we call `change-log-indent' when filling.
+ (set (make-local-variable 'fill-indent-according-to-mode) t)
+ ;; Avoid that filling leaves behind a single "*" on a line.
+ (add-hook 'fill-nobreak-predicate
+ '(lambda ()
+ (looking-back "^\\s *\\*\\s *" (line-beginning-position)))
+ nil t)
+ (set (make-local-variable 'indent-line-function) 'change-log-indent)
+ (set (make-local-variable 'tab-always-indent) nil)
+ (set (make-local-variable 'copyright-at-end-flag) t)
+ ;; We really do want "^" in paragraph-start below: it is only the
+ ;; lines that begin at column 0 (despite the left-margin of 8) that
+ ;; we are looking for. Adding `* ' allows eliding the blank line
+ ;; between entries for different files.
+ (set (make-local-variable 'paragraph-start) "\\s *$\\|\f\\|^\\<")
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ ;; Match null string on the date-line so that the date-line
+ ;; is grouped with what follows.
+ (set (make-local-variable 'page-delimiter) "^\\<\\|^\f")
+ (set (make-local-variable 'version-control) 'never)
+ (set (make-local-variable 'smerge-resolve-function)
+ 'change-log-resolve-conflict)
+ (set (make-local-variable 'adaptive-fill-regexp) "\\s *")
+ (set (make-local-variable 'font-lock-defaults)
+ '(change-log-font-lock-keywords t nil nil backward-paragraph))
+ (set (make-local-variable 'multi-isearch-next-buffer-function)
+ 'change-log-next-buffer)
+ (set (make-local-variable 'beginning-of-defun-function)
+ 'change-log-beginning-of-defun)
+ (set (make-local-variable 'end-of-defun-function)
+ 'change-log-end-of-defun)
+ ;; next-error function glue
+ (setq next-error-function 'change-log-next-error)
+ (setq next-error-last-buffer (current-buffer)))
+
+(defun change-log-next-buffer (&optional buffer wrap)
+ "Return the next buffer in the series of ChangeLog file buffers.
+This function is used for multiple buffers isearch.
+A sequence of buffers is formed by ChangeLog files with decreasing
+numeric file name suffixes in the directory of the initial ChangeLog
+file were isearch was started."
+ (let* ((name (change-log-name))
+ (files (cons name (sort (file-expand-wildcards
+ (concat name "[-.][0-9]*"))
+ (lambda (a b)
+ ;; The file's extension may not have a valid
+ ;; version form (e.g. VC backup revisions).
+ (ignore-errors
+ (version< (substring b (length name))
+ (substring a (length name))))))))
+ (files (if isearch-forward files (reverse files))))
+ (find-file-noselect
+ (if wrap
+ (car files)
+ (cadr (member (file-name-nondirectory (buffer-file-name buffer))
+ files))))))
+
+(defun change-log-fill-forward-paragraph (n)
+ "Cut paragraphs so filling preserves open parentheses at beginning of lines."
+ (let (;; Add lines starting with whitespace followed by a left paren or an
+ ;; asterisk.
+ (paragraph-start (concat paragraph-start "\\|\\s *\\(?:\\s(\\|\\*\\)")))
+ (forward-paragraph n)))
+\f
+(defcustom add-log-current-defun-header-regexp
+ "^\\([[:upper:]][[:upper:]_ ]*[[:upper:]_]\\|[-_[:alpha:]]+\\)[ \t]*[:=]"
+ "Heuristic regexp used by `add-log-current-defun' for unknown major modes.
+The regexp's first submatch is placed in the ChangeLog entry, in
+parentheses."
+ :type 'regexp
+ :group 'change-log)
+
+;;;###autoload
+(defvar add-log-lisp-like-modes
+ '(emacs-lisp-mode lisp-mode scheme-mode dsssl-mode lisp-interaction-mode)
+ "*Modes that look like Lisp to `add-log-current-defun'.")
+
+;;;###autoload
+(defvar add-log-c-like-modes
+ '(c-mode c++-mode c++-c-mode objc-mode)
+ "*Modes that look like C to `add-log-current-defun'.")
+
+;;;###autoload
+(defvar add-log-tex-like-modes
+ '(TeX-mode plain-TeX-mode LaTeX-mode tex-mode)
+ "*Modes that look like TeX to `add-log-current-defun'.")
+
+(declare-function c-cpp-define-name "cc-cmds" ())
+(declare-function c-defun-name "cc-cmds" ())
+
+;;;###autoload
+(defun add-log-current-defun ()
+ "Return name of function definition point is in, or nil.
+
+Understands C, Lisp, LaTeX (\"functions\" are chapters, sections, ...),
+Texinfo (@node titles) and Perl.
+
+Other modes are handled by a heuristic that looks in the 10K before
+point for uppercase headings starting in the first column or
+identifiers followed by `:' or `='. See variables
+`add-log-current-defun-header-regexp' and
+`add-log-current-defun-function'.
+
+Has a preference of looking backwards."
+ (condition-case nil
+ (save-excursion
+ (let ((location (point)))
+ (cond (add-log-current-defun-function
+ (funcall add-log-current-defun-function))
+ ((apply 'derived-mode-p add-log-lisp-like-modes)
+ ;; If we are now precisely at the beginning of a defun,
+ ;; make sure beginning-of-defun finds that one
+ ;; rather than the previous one.
+ (or (eobp) (forward-char 1))
+ (beginning-of-defun)
+ ;; Make sure we are really inside the defun found,
+ ;; not after it.
+ (when (and (looking-at "\\s(")
+ (progn (end-of-defun)
+ (< location (point)))
+ (progn (forward-sexp -1)
+ (>= location (point))))
+ (if (looking-at "\\s(")
+ (forward-char 1))
+ ;; Skip the defining construct name, typically "defun"
+ ;; or "defvar".
+ (forward-sexp 1)
+ ;; The second element is usually a symbol being defined.
+ ;; If it is not, use the first symbol in it.
+ (skip-chars-forward " \t\n'(")
+ (buffer-substring-no-properties (point)
+ (progn (forward-sexp 1)
+ (point)))))
+ ((apply 'derived-mode-p add-log-c-like-modes)
+ (or (c-cpp-define-name)
+ (c-defun-name)))
+ ((memq major-mode add-log-tex-like-modes)
+ (if (re-search-backward
+ "\\\\\\(sub\\)*\\(section\\|paragraph\\|chapter\\)"
+ nil t)
+ (progn
+ (goto-char (match-beginning 0))
+ (buffer-substring-no-properties
+ (1+ (point)) ; without initial backslash
+ (line-end-position)))))
+ ((derived-mode-p 'texinfo-mode)
+ (if (re-search-backward "^@node[ \t]+\\([^,\n]+\\)" nil t)
+ (match-string-no-properties 1)))
+ ((derived-mode-p 'perl-mode 'cperl-mode)
+ (if (re-search-backward "^sub[ \t]+\\([^({ \t\n]+\\)" nil t)
+ (match-string-no-properties 1)))
+ ;; Emacs's autoconf-mode installs its own
+ ;; `add-log-current-defun-function'. This applies to
+ ;; a different mode apparently for editing .m4
+ ;; autoconf source.
+ ((derived-mode-p 'autoconf-mode)
+ (if (re-search-backward
+ "^\\(\\(m4_\\)?define\\|A._DEFUN\\)(\\[?\\([A-Za-z0-9_]+\\)" nil t)
+ (match-string-no-properties 3)))
+ (t
+ ;; If all else fails, try heuristics
+ (let (case-fold-search
+ result)
+ (end-of-line)
+ (when (re-search-backward
+ add-log-current-defun-header-regexp
+ (- (point) 10000)
+ t)
+ (setq result (or (match-string-no-properties 1)
+ (match-string-no-properties 0)))
+ ;; Strip whitespace away
+ (when (string-match "\\([^ \t\n\r\f].*[^ \t\n\r\f]\\)"
+ result)
+ (setq result (match-string-no-properties 1 result)))
+ result))))))
+ (error nil)))
+
+(defvar change-log-get-method-definition-md)
+
+;; Subroutine used within change-log-get-method-definition.
+;; Add the last match in the buffer to the end of `md',
+;; followed by the string END; move to the end of that match.
+(defun change-log-get-method-definition-1 (end)
+ (setq change-log-get-method-definition-md
+ (concat change-log-get-method-definition-md
+ (match-string 1)
+ end))
+ (goto-char (match-end 0)))
+
+(defun change-log-get-method-definition ()
+"For Objective C, return the method name if we are in a method."
+ (let ((change-log-get-method-definition-md "["))
+ (save-excursion
+ (if (re-search-backward "^@implementation\\s-*\\([A-Za-z_]*\\)" nil t)
+ (change-log-get-method-definition-1 " ")))
+ (save-excursion
+ (cond
+ ((re-search-forward "^\\([-+]\\)[ \t\n\f\r]*\\(([^)]*)\\)?\\s-*" nil t)
+ (change-log-get-method-definition-1 "")
+ (while (not (looking-at "[{;]"))
+ (looking-at
+ "\\([A-Za-z_]*:?\\)\\s-*\\(([^)]*)\\)?[A-Za-z_]*[ \t\n\f\r]*")
+ (change-log-get-method-definition-1 ""))
+ (concat change-log-get-method-definition-md "]"))))))
+\f
+(defun change-log-sortable-date-at ()
+ "Return date of log entry in a consistent form for sorting.
+Point is assumed to be at the start of the entry."
+ (require 'timezone)
+ (if (looking-at change-log-start-entry-re)
+ (let ((date (match-string-no-properties 0)))
+ (if date
+ (if (string-match "\\(....\\)-\\(..\\)-\\(..\\)\\s-+" date)
+ (concat (match-string 1 date) (match-string 2 date)
+ (match-string 3 date))
+ (condition-case nil
+ (timezone-make-date-sortable date)
+ (error nil)))))
+ (error "Bad date")))
+
+(defun change-log-resolve-conflict ()
+ "Function to be used in `smerge-resolve-function'."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (match-beginning 0) (match-end 0))
+ (let ((mb1 (match-beginning 1))
+ (me1 (match-end 1))
+ (mb3 (match-beginning 3))
+ (me3 (match-end 3))
+ (tmp1 (generate-new-buffer " *changelog-resolve-1*"))
+ (tmp2 (generate-new-buffer " *changelog-resolve-2*")))
+ (unwind-protect
+ (let ((buf (current-buffer)))
+ (with-current-buffer tmp1
+ (change-log-mode)
+ (insert-buffer-substring buf mb1 me1))
+ (with-current-buffer tmp2
+ (change-log-mode)
+ (insert-buffer-substring buf mb3 me3)
+ ;; Do the merge here instead of inside `buf' so as to be
+ ;; more robust in case change-log-merge fails.
+ (change-log-merge tmp1))
+ (goto-char (point-max))
+ (delete-region (point-min)
+ (prog1 (point)
+ (insert-buffer-substring tmp2))))
+ (kill-buffer tmp1)
+ (kill-buffer tmp2))))))
+
+;;;###autoload
+(defun change-log-merge (other-log)
+ "Merge the contents of change log file OTHER-LOG with this buffer.
+Both must be found in Change Log mode (since the merging depends on
+the appropriate motion commands). OTHER-LOG can be either a file name
+or a buffer.
+
+Entries are inserted in chronological order. Both the current and
+old-style time formats for entries are supported."
+ (interactive "*fLog file name to merge: ")
+ (if (not (derived-mode-p 'change-log-mode))
+ (error "Not in Change Log mode"))
+ (let ((other-buf (if (bufferp other-log) other-log
+ (find-file-noselect other-log)))
+ (buf (current-buffer))
+ date1 start end)
+ (save-excursion
+ (goto-char (point-min))
+ (set-buffer other-buf)
+ (goto-char (point-min))
+ (if (not (derived-mode-p 'change-log-mode))
+ (error "%s not found in Change Log mode" other-log))
+ ;; Loop through all the entries in OTHER-LOG.
+ (while (not (eobp))
+ (setq date1 (change-log-sortable-date-at))
+ (setq start (point)
+ end (progn (forward-page) (point)))
+ ;; Look for an entry in original buffer that isn't later.
+ (with-current-buffer buf
+ (while (and (not (eobp))
+ (string< date1 (change-log-sortable-date-at)))
+ (forward-page))
+ (if (not (eobp))
+ (insert-buffer-substring other-buf start end)
+ ;; At the end of the original buffer, insert a newline to
+ ;; separate entries and then the rest of the file being
+ ;; merged.
+ (unless (or (bobp)
+ (and (= ?\n (char-before))
+ (or (<= (1- (point)) (point-min))
+ (= ?\n (char-before (1- (point)))))))
+ (insert (if use-hard-newlines hard-newline "\n")))
+ ;; Move to the end of it to terminate outer loop.
+ (with-current-buffer other-buf
+ (goto-char (point-max)))
+ (insert-buffer-substring other-buf start)))))))
+
+(defun change-log-beginning-of-defun ()
+ (re-search-backward change-log-start-entry-re nil 'move))
+
+(defun change-log-end-of-defun ()
+ ;; Look back and if there is no entry there it means we are before
+ ;; the first ChangeLog entry, so go forward until finding one.
+ (unless (save-excursion (re-search-backward change-log-start-entry-re nil t))
+ (re-search-forward change-log-start-entry-re nil t))
+
+ ;; In case we are at the end of log entry going forward a line will
+ ;; make us find the next entry when searching. If we are inside of
+ ;; an entry going forward a line will still keep the point inside
+ ;; the same entry.
+ (forward-line 1)
+
+ ;; In case we are at the beginning of an entry, move past it.
+ (when (looking-at change-log-start-entry-re)
+ (goto-char (match-end 0))
+ (forward-line 1))
+
+ ;; Search for the start of the next log entry. Go to the end of the
+ ;; buffer if we could not find a next entry.
+ (when (re-search-forward change-log-start-entry-re nil 'move)
+ (goto-char (match-beginning 0))
+ (forward-line -1)))
+
+(provide 'add-log)
+
+;; arch-tag: 81eee6fc-088f-4372-a37f-80ad9620e762
+;;; add-log.el ends here
--- /dev/null
+;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*-
+
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: pcl-cvs cvs status tree tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Todo:
+
+;; - Somehow allow cvs-status-tree to work on-the-fly
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'pcvs-util)
+
+;;;
+
+(defgroup cvs-status nil
+ "Major mode for browsing `cvs status' output."
+ :group 'pcl-cvs
+ :prefix "cvs-status-")
+
+(easy-mmode-defmap cvs-status-mode-map
+ '(("n" . next-line)
+ ("p" . previous-line)
+ ("N" . cvs-status-next)
+ ("P" . cvs-status-prev)
+ ("\M-n" . cvs-status-next)
+ ("\M-p" . cvs-status-prev)
+ ("t" . cvs-status-cvstrees)
+ ("T" . cvs-status-trees)
+ (">" . cvs-mode-checkout))
+ "CVS-Status' keymap."
+ :group 'cvs-status
+ :inherit 'cvs-mode-map)
+
+;;(easy-menu-define cvs-status-menu cvs-status-mode-map
+;; "Menu for `cvs-status-mode'."
+;; '("CVS-Status"
+;; ["Show Tag Trees" cvs-status-tree t]
+;; ))
+
+(defvar cvs-status-mode-hook nil
+ "Hook run at the end of `cvs-status-mode'.")
+
+(defconst cvs-status-tags-leader-re "^ Existing Tags:$")
+(defconst cvs-status-entry-leader-re
+ "^File:\\s-+\\(?:no file \\)?\\(.*\\S-\\)\\s-+Status: \\(.+\\)$")
+(defconst cvs-status-dir-re "^cvs[.ex]* [a-z]+: Examining \\(.+\\)$")
+(defconst cvs-status-rev-re "[0-9][.0-9]*\\.[.0-9]*[0-9]")
+(defconst cvs-status-tag-re "[ \t]\\([a-zA-Z][^ \t\n.]*\\)")
+
+(defconst cvs-status-font-lock-keywords
+ `((,cvs-status-entry-leader-re
+ (1 'cvs-filename)
+ (2 'cvs-need-action))
+ (,cvs-status-tags-leader-re
+ (,cvs-status-rev-re
+ (save-excursion (re-search-forward "^\n" nil 'move) (point))
+ (progn (re-search-backward cvs-status-tags-leader-re nil t)
+ (forward-line 1))
+ (0 font-lock-comment-face))
+ (,cvs-status-tag-re
+ (save-excursion (re-search-forward "^\n" nil 'move) (point))
+ (progn (re-search-backward cvs-status-tags-leader-re nil t)
+ (forward-line 1))
+ (1 font-lock-function-name-face)))))
+(defconst cvs-status-font-lock-defaults
+ '(cvs-status-font-lock-keywords t nil nil nil (font-lock-multiline . t)))
+
+(defvar cvs-minor-wrap-function)
+(put 'cvs-status-mode 'mode-class 'special)
+;;;###autoload
+(define-derived-mode cvs-status-mode fundamental-mode "CVS-Status"
+ "Mode used for cvs status output."
+ (set (make-local-variable 'font-lock-defaults) cvs-status-font-lock-defaults)
+ (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-status-minor-wrap))
+
+;; Define cvs-status-next and cvs-status-prev
+(easy-mmode-define-navigation cvs-status cvs-status-entry-leader-re "entry")
+
+(defun cvs-status-current-file ()
+ (save-excursion
+ (forward-line 1)
+ (or (re-search-backward cvs-status-entry-leader-re nil t)
+ (re-search-forward cvs-status-entry-leader-re))
+ (let* ((file (match-string 1))
+ (cvsdir (and (re-search-backward cvs-status-dir-re nil t)
+ (match-string 1)))
+ (pcldir (and (if (boundp 'cvs-pcl-cvs-dirchange-re)
+ (re-search-backward cvs-pcl-cvs-dirchange-re nil t))
+ (match-string 1)))
+ (dir ""))
+ (let ((default-directory ""))
+ (when pcldir (setq dir (expand-file-name pcldir dir)))
+ (when cvsdir (setq dir (expand-file-name cvsdir dir)))
+ (expand-file-name file dir)))))
+
+(defun cvs-status-current-tag ()
+ (save-excursion
+ (let ((pt (point))
+ (col (current-column))
+ (start (progn (re-search-backward cvs-status-tags-leader-re nil t) (point)))
+ (end (progn (re-search-forward "^$" nil t) (point))))
+ (when (and (< start pt) (> end pt))
+ (goto-char pt)
+ (end-of-line)
+ (let ((tag nil) (dist pt) (end (point)))
+ (beginning-of-line)
+ (while (re-search-forward cvs-status-tag-re end t)
+ (let* ((cole (current-column))
+ (colb (save-excursion
+ (goto-char (match-beginning 1)) (current-column)))
+ (ndist (min (abs (- cole col)) (abs (- colb col)))))
+ (when (< ndist dist)
+ (setq dist ndist)
+ (setq tag (match-string 1)))))
+ tag)))))
+
+(defun cvs-status-minor-wrap (buf f)
+ (let ((data (with-current-buffer buf
+ (cons
+ (cons (cvs-status-current-file)
+ (cvs-status-current-tag))
+ (when mark-active
+ (save-excursion
+ (goto-char (mark))
+ (cons (cvs-status-current-file)
+ (cvs-status-current-tag))))))))
+ (let ((cvs-branch-prefix (cdar data))
+ (cvs-secondary-branch-prefix (and (cdar data) (cddr data)))
+ (cvs-minor-current-files
+ (cons (caar data)
+ (when (and (cadr data) (not (equal (caar data) (cadr data))))
+ (list (cadr data)))))
+ ;; FIXME: I need to force because the fileinfos are UNKNOWN
+ (cvs-force-command "/F"))
+ (funcall f))))
+
+;;
+;; Tagelt, tag element
+;;
+
+(defstruct (cvs-tag
+ (:constructor nil)
+ (:constructor cvs-tag-make
+ (vlist &optional name type))
+ (:conc-name cvs-tag->))
+ vlist
+ name
+ type)
+
+(defsubst cvs-status-vl-to-str (vl) (mapconcat 'number-to-string vl "."))
+
+(defun cvs-tag->string (tag)
+ (if (stringp tag) tag
+ (let ((name (cvs-tag->name tag))
+ (vl (cvs-tag->vlist tag)))
+ (if (null name) (cvs-status-vl-to-str vl)
+ (let ((rev (if vl (concat " (" (cvs-status-vl-to-str vl) ")") "")))
+ (if (consp name) (mapcar (lambda (name) (concat name rev)) name)
+ (concat name rev)))))))
+
+(defun cvs-tag-compare-1 (vl1 vl2)
+ (cond
+ ((and (null vl1) (null vl2)) 'equal)
+ ((null vl1) 'more2)
+ ((null vl2) 'more1)
+ (t (let ((v1 (car vl1))
+ (v2 (car vl2)))
+ (cond
+ ((> v1 v2) 'more1)
+ ((< v1 v2) 'more2)
+ (t (cvs-tag-compare-1 (cdr vl1) (cdr vl2))))))))
+
+(defsubst cvs-tag-compare (tag1 tag2)
+ (cvs-tag-compare-1 (cvs-tag->vlist tag1) (cvs-tag->vlist tag2)))
+
+(defun cvs-tag-merge (tag1 tag2)
+ "Merge TAG1 and TAG2 into one."
+ (let ((type1 (cvs-tag->type tag1))
+ (type2 (cvs-tag->type tag2))
+ (name1 (cvs-tag->name tag1))
+ (name2 (cvs-tag->name tag2)))
+ (unless (equal (cvs-tag->vlist tag1) (cvs-tag->vlist tag2))
+ (setf (cvs-tag->vlist tag1) nil))
+ (if type1
+ (unless (or (not type2) (equal type1 type2))
+ (setf (cvs-tag->type tag1) nil))
+ (setf (cvs-tag->type tag1) type2))
+ (if name1
+ (setf (cvs-tag->name tag1) (cvs-append name1 name2))
+ (setf (cvs-tag->name tag1) name2))
+ tag1))
+
+(defun cvs-tree-print (tags printer column)
+ "Print the tree of TAGS where each tag's string is given by PRINTER.
+PRINTER should accept both a tag (in which case it should return a string)
+or a string (in which case it should simply return its argument).
+A tag cannot be a CONS. The return value can also be a list of strings,
+if several nodes where merged into one.
+The tree will be printed no closer than column COLUMN."
+
+ (let* ((eol (save-excursion (end-of-line) (current-column)))
+ (column (max (+ eol 2) column)))
+ (if (null tags) column
+ ;;(move-to-column-force column)
+ (let* ((rev (cvs-car tags))
+ (name (funcall printer (cvs-car rev)))
+ (rest (append (cvs-cdr name) (cvs-cdr tags)))
+ (prefix
+ (save-excursion
+ (or (= (forward-line 1) 0) (insert "\n"))
+ (cvs-tree-print rest printer column))))
+ (assert (>= prefix column))
+ (move-to-column prefix t)
+ (assert (eolp))
+ (insert (cvs-car name))
+ (dolist (br (cvs-cdr rev))
+ (let* ((column (current-column))
+ (brrev (funcall printer (cvs-car br)))
+ (brlength (length (cvs-car brrev)))
+ (brfill (concat (make-string (/ brlength 2) ? ) "|"))
+ (prefix
+ (save-excursion
+ (insert " -- ")
+ (cvs-tree-print (cvs-append brrev brfill (cvs-cdr br))
+ printer (current-column)))))
+ (delete-region (save-excursion (move-to-column prefix) (point))
+ (point))
+ (insert " " (make-string (- prefix column 2) ?-) " ")
+ (end-of-line)))
+ prefix))))
+
+(defun cvs-tree-merge (tree1 tree2)
+ "Merge tags trees TREE1 and TREE2 into one.
+BEWARE: because of stability issues, this is not a symetric operation."
+ (assert (and (listp tree1) (listp tree2)))
+ (cond
+ ((null tree1) tree2)
+ ((null tree2) tree1)
+ (t
+ (let* ((rev1 (car tree1))
+ (tag1 (cvs-car rev1))
+ (vl1 (cvs-tag->vlist tag1))
+ (l1 (length vl1))
+ (rev2 (car tree2))
+ (tag2 (cvs-car rev2))
+ (vl2 (cvs-tag->vlist tag2))
+ (l2 (length vl2)))
+ (cond
+ ((= l1 l2)
+ (case (cvs-tag-compare tag1 tag2)
+ (more1 (list* rev2 (cvs-tree-merge tree1 (cdr tree2))))
+ (more2 (list* rev1 (cvs-tree-merge (cdr tree1) tree2)))
+ (equal
+ (cons (cons (cvs-tag-merge tag1 tag2)
+ (cvs-tree-merge (cvs-cdr rev1) (cvs-cdr rev2)))
+ (cvs-tree-merge (cdr tree1) (cdr tree2))))))
+ ((> l1 l2)
+ (cvs-tree-merge
+ (list (cons (cvs-tag-make (butlast vl1)) tree1)) tree2))
+ ((< l1 l2)
+ (cvs-tree-merge
+ tree1 (list (cons (cvs-tag-make (butlast vl2)) tree2)))))))))
+
+(defun cvs-tag-make-tag (tag)
+ (let ((vl (mapcar 'string-to-number (split-string (nth 2 tag) "\\."))))
+ (cvs-tag-make vl (nth 0 tag) (intern (nth 1 tag)))))
+
+(defun cvs-tags->tree (tags)
+ "Make a tree out of a list of TAGS."
+ (let ((tags
+ (mapcar
+ (lambda (tag)
+ (let ((tag (cvs-tag-make-tag tag)))
+ (list (if (not (eq (cvs-tag->type tag) 'branch)) tag
+ (list (cvs-tag-make (butlast (cvs-tag->vlist tag)))
+ tag)))))
+ tags)))
+ (while (cdr tags)
+ (let (tl)
+ (while tags
+ (push (cvs-tree-merge (pop tags) (pop tags)) tl))
+ (setq tags (nreverse tl))))
+ (car tags)))
+
+(defun cvs-status-get-tags ()
+ "Look for a list of tags, read them in and delete them.
+Return nil if there was an empty list of tags and t if there wasn't
+even a list. Else, return the list of tags where each element of
+the list is a three-string list TAG, KIND, REV."
+ (let ((tags nil))
+ (if (not (re-search-forward cvs-status-tags-leader-re nil t)) t
+ (forward-char 1)
+ (let ((pt (point))
+ (lastrev nil)
+ (case-fold-search t))
+ (or
+ (looking-at "\\s-+no\\s-+tags")
+
+ (progn ; normal listing
+ (while (looking-at "^[ \t]+\\([^ \t\n]+\\)[ \t]+(\\([a-z]+\\): \\(.+\\))$")
+ (push (list (match-string 1) (match-string 2) (match-string 3)) tags)
+ (forward-line 1))
+ (unless (looking-at "^$") (setq tags nil) (goto-char pt))
+ tags)
+
+ (progn ; cvstree-style listing
+ (while (or (looking-at "^ .+\\(.\\) \\([0-9.]+\\): \\([^\n\t .0-9][^\n\t ]*\\)?$")
+ (and lastrev
+ (looking-at "^ .+\\(\\) \\(8\\)? \\([^\n\t .0-9][^\n\t ]*\\)$")))
+ (setq lastrev (or (match-string 2) lastrev))
+ (push (list (match-string 3)
+ (if (equal (match-string 1) " ") "branch" "revision")
+ lastrev) tags)
+ (forward-line 1))
+ (unless (looking-at "^$") (setq tags nil) (goto-char pt))
+ (setq tags (nreverse tags)))
+
+ (progn ; new tree style listing
+ (let* ((re-lead "[ \t]*\\(-+\\)?\\(|\n?[ \t]+\\)*")
+ (re3 (concat re-lead "\\(\\.\\)?\\(" cvs-status-rev-re "\\)"))
+ (re2 (concat re-lead cvs-status-tag-re "\\(\\)"))
+ (re1 (concat re-lead cvs-status-tag-re
+ " (\\(" cvs-status-rev-re "\\))")))
+ (while (or (looking-at re1) (looking-at re2) (looking-at re3))
+ (push (list (match-string 3)
+ (if (match-string 1) "branch" "revision")
+ (match-string 4)) tags)
+ (goto-char (match-end 0))
+ (when (eolp) (forward-char 1))))
+ (unless (looking-at "^$") (setq tags nil) (goto-char pt))
+ (setq tags (nreverse tags))))
+
+ (delete-region pt (point)))
+ tags)))
+
+(defvar font-lock-mode)
+;; (defun cvs-refontify (beg end)
+;; (when (and (boundp 'font-lock-mode)
+;; font-lock-mode
+;; (fboundp 'font-lock-fontify-region))
+;; (font-lock-fontify-region (1- beg) (1+ end))))
+
+(defun cvs-status-trees ()
+ "Look for a lists of tags, and replace them with trees."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ (tags nil))
+ (while (listp (setq tags (cvs-status-get-tags)))
+ ;;(let ((pt (save-excursion (forward-line -1) (point))))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ ;;(newline)
+ (combine-after-change-calls
+ (cvs-tree-print (cvs-tags->tree tags) 'cvs-tag->string 3)))
+ ;;(cvs-refontify pt (point))
+ ;;(sit-for 0)
+ ;;)
+ ))))
+
+;;;;
+;;;; CVSTree-style trees
+;;;;
+
+(defvar cvs-tree-use-jisx0208 nil) ;Old compat var.
+(defvar cvs-tree-use-charset
+ (cond
+ (cvs-tree-use-jisx0208 'jisx0208)
+ ((char-displayable-p ?━) 'unicode)
+ ((char-displayable-p (make-char 'japanese-jisx0208 40 44)) 'jisx0208))
+ "*Non-nil if we should use the graphical glyphs from `japanese-jisx0208'.
+Otherwise, default to ASCII chars like +, - and |.")
+
+(defconst cvs-tree-char-space
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 33 33))
+ (unicode " ")
+ (t " ")))
+(defconst cvs-tree-char-hbar
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 44))
+ (unicode "━")
+ (t "--")))
+(defconst cvs-tree-char-vbar
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 45))
+ (unicode "┃")
+ (t "| ")))
+(defconst cvs-tree-char-branch
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 50))
+ (unicode "┣")
+ (t "+-")))
+(defconst cvs-tree-char-eob ;end of branch
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 49))
+ (unicode "┗")
+ (t "`-")))
+(defconst cvs-tree-char-bob ;beginning of branch
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 51))
+ (unicode "┳")
+ (t "+-")))
+
+(defun cvs-tag-lessp (tag1 tag2)
+ (eq (cvs-tag-compare tag1 tag2) 'more2))
+
+(defvar cvs-tree-nomerge nil)
+
+(defun cvs-status-cvstrees (&optional arg)
+ "Look for a list of tags, and replace it with a tree.
+Optional prefix ARG chooses between two representations."
+ (interactive "P")
+ (when (and cvs-tree-use-charset
+ (not enable-multibyte-characters))
+ ;; We need to convert the buffer from unibyte to multibyte
+ ;; since we'll use multibyte chars for the tree.
+ (let ((modified (buffer-modified-p))
+ (inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (unwind-protect
+ (progn
+ (decode-coding-region (point-min) (point-max) 'undecided)
+ (set-buffer-multibyte t))
+ (restore-buffer-modified-p modified))))
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ (tags nil)
+ (cvs-tree-nomerge (if arg (not cvs-tree-nomerge) cvs-tree-nomerge)))
+ (while (listp (setq tags (cvs-status-get-tags)))
+ (let ((tags (mapcar 'cvs-tag-make-tag tags))
+ ;;(pt (save-excursion (forward-line -1) (point)))
+ )
+ (setq tags (sort tags 'cvs-tag-lessp))
+ (let* ((first (car tags))
+ (prev (if (cvs-tag-p first)
+ (list (car (cvs-tag->vlist first))) nil)))
+ (combine-after-change-calls
+ (cvs-tree-tags-insert tags prev))
+ ;;(cvs-refontify pt (point))
+ ;;(sit-for 0)
+ ))))))
+
+(defun cvs-tree-tags-insert (tags prev)
+ (when tags
+ (let* ((tag (car tags))
+ (vlist (cvs-tag->vlist tag))
+ (nprev ;"next prev"
+ (let* ((next (cvs-car (cadr tags)))
+ (nprev (if (and cvs-tree-nomerge next
+ (equal vlist (cvs-tag->vlist next)))
+ prev vlist)))
+ (cvs-map (lambda (v p) v) nprev prev)))
+ (after (save-excursion
+ (newline)
+ (cvs-tree-tags-insert (cdr tags) nprev)))
+ (pe t) ;"prev equal"
+ (nas nil)) ;"next afters" to be returned
+ (insert " ")
+ (do* ((vs vlist (cdr vs))
+ (ps prev (cdr ps))
+ (as after (cdr as)))
+ ((and (null as) (null vs) (null ps))
+ (let ((revname (cvs-status-vl-to-str vlist)))
+ (if (cvs-every 'identity (cvs-map 'equal prev vlist))
+ (insert (make-string (+ 4 (length revname)) ? )
+ (or (cvs-tag->name tag) ""))
+ (insert " " revname ": " (or (cvs-tag->name tag) "")))))
+ (let* ((eq (and pe (equal (car ps) (car vs))))
+ (next-eq (equal (cadr ps) (cadr vs))))
+ (let* ((na+char
+ (if (car as)
+ (if eq
+ (if next-eq (cons t cvs-tree-char-vbar)
+ (cons t cvs-tree-char-branch))
+ (cons nil cvs-tree-char-bob))
+ (if eq
+ (if next-eq (cons nil cvs-tree-char-space)
+ (cons t cvs-tree-char-eob))
+ (cons nil (if (and (eq (cvs-tag->type tag) 'branch)
+ (cvs-every 'null as))
+ cvs-tree-char-space
+ cvs-tree-char-hbar))))))
+ (insert (cdr na+char))
+ (push (car na+char) nas))
+ (setq pe eq)))
+ (nreverse nas))))
+
+;;;;
+;;;; Merged trees from different files
+;;;;
+
+(defun cvs-tree-fuzzy-merge-1 (trees tree prev)
+ )
+
+(defun cvs-tree-fuzzy-merge (trees tree)
+ "Do the impossible: merge TREE into TREES."
+ ())
+
+(defun cvs-tree ()
+ "Get tags from the status output and merge tham all into a big tree."
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ (trees (make-vector 31 0)) tree)
+ (while (listp (setq tree (cvs-tags->tree (cvs-status-get-tags))))
+ (cvs-tree-fuzzy-merge trees tree))
+ (erase-buffer)
+ (let ((cvs-tag-print-rev nil))
+ (cvs-tree-print tree 'cvs-tag->string 3)))))
+
+
+(provide 'cvs-status)
+
+;; arch-tag: db8b5094-d02a-473e-a476-544e89ff5ad0
+;;; cvs-status.el ends here
--- /dev/null
+;;; diff-mode.el --- a mode for viewing/editing context diffs
+
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: convenience patch diff
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Provides support for font-lock, outline, navigation
+;; commands, editing and various conversions as well as jumping
+;; to the corresponding source file.
+
+;; Inspired by Pavel Machek's patch-mode.el (<pavel@@atrey.karlin.mff.cuni.cz>)
+;; Some efforts were spent to have it somewhat compatible with XEmacs'
+;; diff-mode as well as with compilation-minor-mode
+
+;; Bugs:
+
+;; - Reverse doesn't work with normal diffs.
+
+;; Todo:
+
+;; - Improve `diff-add-change-log-entries-other-window',
+;; it is very simplistic now.
+;;
+;; - Add a `delete-after-apply' so C-c C-a automatically deletes hunks.
+;; Also allow C-c C-a to delete already-applied hunks.
+;;
+;; - Try `diff <file> <hunk>' to try and fuzzily discover the source location
+;; of a hunk. Show then the changes between <file> and <hunk> and make it
+;; possible to apply them to <file>, <hunk-src>, or <hunk-dst>.
+;; Or maybe just make it into a ".rej to diff3-markers converter".
+;; Maybe just use `wiggle' (by Neil Brown) to do it for us.
+;;
+;; - in diff-apply-hunk, strip context in replace-match to better
+;; preserve markers and spacing.
+;; - Handle `diff -b' output in context->unified.
+
+;;; Code:
+(eval-when-compile (require 'cl))
+
+(defvar add-log-buffer-file-name-function)
+
+
+(defgroup diff-mode ()
+ "Major mode for viewing/editing diffs."
+ :version "21.1"
+ :group 'tools
+ :group 'diff)
+
+(defcustom diff-default-read-only nil
+ "If non-nil, `diff-mode' buffers default to being read-only."
+ :type 'boolean
+ :group 'diff-mode)
+
+(defcustom diff-jump-to-old-file nil
+ "Non-nil means `diff-goto-source' jumps to the old file.
+Else, it jumps to the new file."
+ :type 'boolean
+ :group 'diff-mode)
+
+(defcustom diff-update-on-the-fly t
+ "Non-nil means hunk headers are kept up-to-date on-the-fly.
+When editing a diff file, the line numbers in the hunk headers
+need to be kept consistent with the actual diff. This can
+either be done on the fly (but this sometimes interacts poorly with the
+undo mechanism) or whenever the file is written (can be slow
+when editing big diffs)."
+ :type 'boolean
+ :group 'diff-mode)
+
+(defcustom diff-advance-after-apply-hunk t
+ "Non-nil means `diff-apply-hunk' will move to the next hunk after applying."
+ :type 'boolean
+ :group 'diff-mode)
+
+(defcustom diff-mode-hook nil
+ "Run after setting up the `diff-mode' major mode."
+ :type 'hook
+ :options '(diff-delete-empty-files diff-make-unified)
+ :group 'diff-mode)
+
+(defvar diff-outline-regexp
+ "\\([*+][*+][*+] [^0-9]\\|@@ ...\\|\\*\\*\\* [0-9].\\|--- [0-9]..\\)")
+
+;;;;
+;;;; keymap, menu, ...
+;;;;
+
+(easy-mmode-defmap diff-mode-shared-map
+ '(;; From Pavel Machek's patch-mode.
+ ("n" . diff-hunk-next)
+ ("N" . diff-file-next)
+ ("p" . diff-hunk-prev)
+ ("P" . diff-file-prev)
+ ("\t" . diff-hunk-next)
+ ([backtab] . diff-hunk-prev)
+ ("k" . diff-hunk-kill)
+ ("K" . diff-file-kill)
+ ;; From compilation-minor-mode.
+ ("}" . diff-file-next)
+ ("{" . diff-file-prev)
+ ("\C-m" . diff-goto-source)
+ ([mouse-2] . diff-goto-source)
+ ;; From XEmacs' diff-mode.
+ ;; Standard M-w is useful, so don't change M-W.
+ ;;("W" . widen)
+ ;;("." . diff-goto-source) ;display-buffer
+ ;;("f" . diff-goto-source) ;find-file
+ ("o" . diff-goto-source) ;other-window
+ ;;("w" . diff-goto-source) ;other-frame
+ ;;("N" . diff-narrow)
+ ;;("h" . diff-show-header)
+ ;;("j" . diff-show-difference) ;jump to Nth diff
+ ;;("q" . diff-quit)
+ ;; Not useful if you have to metafy them.
+ ;;(" " . scroll-up)
+ ;;("\177" . scroll-down)
+ ;; Standard M-a is useful, so don't change M-A.
+ ;;("A" . diff-ediff-patch)
+ ;; Standard M-r is useful, so don't change M-r or M-R.
+ ;;("r" . diff-restrict-view)
+ ;;("R" . diff-reverse-direction)
+ ("q" . quit-window))
+ "Basic keymap for `diff-mode', bound to various prefix keys.")
+
+(easy-mmode-defmap diff-mode-map
+ `(("\e" . ,diff-mode-shared-map)
+ ;; From compilation-minor-mode.
+ ("\C-c\C-c" . diff-goto-source)
+ ;; By analogy with the global C-x 4 a binding.
+ ("\C-x4A" . diff-add-change-log-entries-other-window)
+ ;; Misc operations.
+ ("\C-c\C-a" . diff-apply-hunk)
+ ("\C-c\C-e" . diff-ediff-patch)
+ ("\C-c\C-n" . diff-restrict-view)
+ ("\C-c\C-s" . diff-split-hunk)
+ ("\C-c\C-t" . diff-test-hunk)
+ ("\C-c\C-r" . diff-reverse-direction)
+ ("\C-c\C-u" . diff-context->unified)
+ ;; `d' because it duplicates the context :-( --Stef
+ ("\C-c\C-d" . diff-unified->context)
+ ("\C-c\C-w" . diff-ignore-whitespace-hunk)
+ ("\C-c\C-b" . diff-refine-hunk) ;No reason for `b' :-(
+ ("\C-c\C-f" . next-error-follow-minor-mode))
+ "Keymap for `diff-mode'. See also `diff-mode-shared-map'.")
+
+(easy-menu-define diff-mode-menu diff-mode-map
+ "Menu for `diff-mode'."
+ '("Diff"
+ ["Jump to Source" diff-goto-source
+ :help "Jump to the corresponding source line"]
+ ["Apply hunk" diff-apply-hunk
+ :help "Apply the current hunk to the source file and go to the next"]
+ ["Test applying hunk" diff-test-hunk
+ :help "See whether it's possible to apply the current hunk"]
+ ["Apply diff with Ediff" diff-ediff-patch
+ :help "Call `ediff-patch-file' on the current buffer"]
+ ["Create Change Log entries" diff-add-change-log-entries-other-window
+ :help "Create ChangeLog entries for the changes in the diff buffer"]
+ "-----"
+ ["Reverse direction" diff-reverse-direction
+ :help "Reverse the direction of the diffs"]
+ ["Context -> Unified" diff-context->unified
+ :help "Convert context diffs to unified diffs"]
+ ["Unified -> Context" diff-unified->context
+ :help "Convert unified diffs to context diffs"]
+ ;;["Fixup Headers" diff-fixup-modifs (not buffer-read-only)]
+ ["Show trailing whitespace" whitespace-mode
+ :style toggle :selected (bound-and-true-p whitespace-mode)
+ :help "Show trailing whitespace in modified lines"]
+ "-----"
+ ["Split hunk" diff-split-hunk
+ :active (diff-splittable-p)
+ :help "Split the current (unified diff) hunk at point into two hunks"]
+ ["Ignore whitespace changes" diff-ignore-whitespace-hunk
+ :help "Re-diff the current hunk, ignoring whitespace differences"]
+ ["Highlight fine changes" diff-refine-hunk
+ :help "Highlight changes of hunk at point at a finer granularity"]
+ ["Kill current hunk" diff-hunk-kill
+ :help "Kill current hunk"]
+ ["Kill current file's hunks" diff-file-kill
+ :help "Kill all current file's hunks"]
+ "-----"
+ ["Previous Hunk" diff-hunk-prev
+ :help "Go to the previous count'th hunk"]
+ ["Next Hunk" diff-hunk-next
+ :help "Go to the next count'th hunk"]
+ ["Previous File" diff-file-prev
+ :help "Go to the previous count'th file"]
+ ["Next File" diff-file-next
+ :help "Go to the next count'th file"]
+ ))
+
+(defcustom diff-minor-mode-prefix "\C-c="
+ "Prefix key for `diff-minor-mode' commands."
+ :type '(choice (string "\e") (string "C-c=") string)
+ :group 'diff-mode)
+
+(easy-mmode-defmap diff-minor-mode-map
+ `((,diff-minor-mode-prefix . ,diff-mode-shared-map))
+ "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'.")
+
+(define-minor-mode diff-auto-refine-mode
+ "Automatically highlight changes in detail as the user visits hunks.
+When transitioning from disabled to enabled,
+try to refine the current hunk, as well."
+ :group 'diff-mode :init-value t :lighter nil ;; " Auto-Refine"
+ (when diff-auto-refine-mode
+ (condition-case-no-debug nil (diff-refine-hunk) (error nil))))
+
+;;;;
+;;;; font-lock support
+;;;;
+
+(defface diff-header
+ '((((class color) (min-colors 88) (background light))
+ :background "grey80")
+ (((class color) (min-colors 88) (background dark))
+ :background "grey45")
+ (((class color) (background light))
+ :foreground "blue1" :weight bold)
+ (((class color) (background dark))
+ :foreground "green" :weight bold)
+ (t :weight bold))
+ "`diff-mode' face inherited by hunk and index header faces."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-header-face 'diff-header "22.1")
+(defvar diff-header-face 'diff-header)
+
+(defface diff-file-header
+ '((((class color) (min-colors 88) (background light))
+ :background "grey70" :weight bold)
+ (((class color) (min-colors 88) (background dark))
+ :background "grey60" :weight bold)
+ (((class color) (background light))
+ :foreground "green" :weight bold)
+ (((class color) (background dark))
+ :foreground "cyan" :weight bold)
+ (t :weight bold)) ; :height 1.3
+ "`diff-mode' face used to highlight file header lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-file-header-face 'diff-file-header "22.1")
+(defvar diff-file-header-face 'diff-file-header)
+
+(defface diff-index
+ '((t :inherit diff-file-header))
+ "`diff-mode' face used to highlight index header lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-index-face 'diff-index "22.1")
+(defvar diff-index-face 'diff-index)
+
+(defface diff-hunk-header
+ '((t :inherit diff-header))
+ "`diff-mode' face used to highlight hunk header lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-hunk-header-face 'diff-hunk-header "22.1")
+(defvar diff-hunk-header-face 'diff-hunk-header)
+
+(defface diff-removed
+ '((t :inherit diff-changed))
+ "`diff-mode' face used to highlight removed lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-removed-face 'diff-removed "22.1")
+(defvar diff-removed-face 'diff-removed)
+
+(defface diff-added
+ '((t :inherit diff-changed))
+ "`diff-mode' face used to highlight added lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-added-face 'diff-added "22.1")
+(defvar diff-added-face 'diff-added)
+
+(defface diff-changed
+ '((((type tty pc) (class color) (background light))
+ :foreground "magenta" :weight bold :slant italic)
+ (((type tty pc) (class color) (background dark))
+ :foreground "yellow" :weight bold :slant italic))
+ "`diff-mode' face used to highlight changed lines."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-changed-face 'diff-changed "22.1")
+(defvar diff-changed-face 'diff-changed)
+
+(defface diff-indicator-removed
+ '((t :inherit diff-removed))
+ "`diff-mode' face used to highlight indicator of removed lines (-, <)."
+ :group 'diff-mode
+ :version "22.1")
+(defvar diff-indicator-removed-face 'diff-indicator-removed)
+
+(defface diff-indicator-added
+ '((t :inherit diff-added))
+ "`diff-mode' face used to highlight indicator of added lines (+, >)."
+ :group 'diff-mode
+ :version "22.1")
+(defvar diff-indicator-added-face 'diff-indicator-added)
+
+(defface diff-indicator-changed
+ '((t :inherit diff-changed))
+ "`diff-mode' face used to highlight indicator of changed lines."
+ :group 'diff-mode
+ :version "22.1")
+(defvar diff-indicator-changed-face 'diff-indicator-changed)
+
+(defface diff-function
+ '((t :inherit diff-header))
+ "`diff-mode' face used to highlight function names produced by \"diff -p\"."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-function-face 'diff-function "22.1")
+(defvar diff-function-face 'diff-function)
+
+(defface diff-context
+ '((((class color grayscale) (min-colors 88)) :inherit shadow))
+ "`diff-mode' face used to highlight context and other side-information."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-context-face 'diff-context "22.1")
+(defvar diff-context-face 'diff-context)
+
+(defface diff-nonexistent
+ '((t :inherit diff-file-header))
+ "`diff-mode' face used to highlight nonexistent files in recursive diffs."
+ :group 'diff-mode)
+(define-obsolete-face-alias 'diff-nonexistent-face 'diff-nonexistent "22.1")
+(defvar diff-nonexistent-face 'diff-nonexistent)
+
+(defconst diff-yank-handler '(diff-yank-function))
+(defun diff-yank-function (text)
+ ;; FIXME: the yank-handler is now called separately on each piece of text
+ ;; with a yank-handler property, so the next-single-property-change call
+ ;; below will always return nil :-( --stef
+ (let ((mixed (next-single-property-change 0 'yank-handler text))
+ (start (point)))
+ ;; First insert the text.
+ (insert text)
+ ;; If the text does not include any diff markers and if we're not
+ ;; yanking back into a diff-mode buffer, get rid of the prefixes.
+ (unless (or mixed (derived-mode-p 'diff-mode))
+ (undo-boundary) ; Just in case the user wanted the prefixes.
+ (let ((re (save-excursion
+ (if (re-search-backward "^[><!][ \t]" start t)
+ (if (eq (char-after) ?!)
+ "^[!+- ][ \t]" "^[<>][ \t]")
+ "^[ <>!+-]"))))
+ (save-excursion
+ (while (re-search-backward re start t)
+ (replace-match "" t t)))))))
+
+(defconst diff-hunk-header-re-unified
+ "^@@ -\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? \\+\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? @@")
+(defconst diff-context-mid-hunk-header-re
+ "--- \\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? ----$")
+
+(defvar diff-font-lock-keywords
+ `((,(concat "\\(" diff-hunk-header-re-unified "\\)\\(.*\\)$")
+ (1 diff-hunk-header-face) (6 diff-function-face))
+ ("^\\(\\*\\{15\\}\\)\\(.*\\)$" ;context
+ (1 diff-hunk-header-face) (2 diff-function-face))
+ ("^\\*\\*\\* .+ \\*\\*\\*\\*". diff-hunk-header-face) ;context
+ (,diff-context-mid-hunk-header-re . diff-hunk-header-face) ;context
+ ("^[0-9,]+[acd][0-9,]+$" . diff-hunk-header-face) ;normal
+ ("^---$" . diff-hunk-header-face) ;normal
+ ;; For file headers, accept files with spaces, but be careful to rule
+ ;; out false-positives when matching hunk headers.
+ ("^\\(---\\|\\+\\+\\+\\|\\*\\*\\*\\) \\([^\t\n]+?\\)\\(?:\t.*\\| \\(\\*\\*\\*\\*\\|----\\)\\)?\n"
+ (0 diff-header-face)
+ (2 (if (not (match-end 3)) diff-file-header-face) prepend))
+ ("^\\([-<]\\)\\(.*\n\\)"
+ (1 diff-indicator-removed-face) (2 diff-removed-face))
+ ("^\\([+>]\\)\\(.*\n\\)"
+ (1 diff-indicator-added-face) (2 diff-added-face))
+ ("^\\(!\\)\\(.*\n\\)"
+ (1 diff-indicator-changed-face) (2 diff-changed-face))
+ ("^Index: \\(.+\\).*\n"
+ (0 diff-header-face) (1 diff-index-face prepend))
+ ("^Only in .*\n" . diff-nonexistent-face)
+ ("^\\(#\\)\\(.*\\)"
+ (1 font-lock-comment-delimiter-face)
+ (2 font-lock-comment-face))
+ ("^[^-=+*!<>#].*\n" (0 diff-context-face))))
+
+(defconst diff-font-lock-defaults
+ '(diff-font-lock-keywords t nil nil nil (font-lock-multiline . nil)))
+
+(defvar diff-imenu-generic-expression
+ ;; Prefer second name as first is most likely to be a backup or
+ ;; version-control name. The [\t\n] at the end of the unidiff pattern
+ ;; catches Debian source diff files (which lack the trailing date).
+ '((nil "\\+\\+\\+\\ \\([^\t\n]+\\)[\t\n]" 1) ; unidiffs
+ (nil "^--- \\([^\t\n]+\\)\t.*\n\\*" 1))) ; context diffs
+
+;;;;
+;;;; Movement
+;;;;
+
+(defvar diff-valid-unified-empty-line t
+ "If non-nil, empty lines are valid in unified diffs.
+Some versions of diff replace all-blank context lines in unified format with
+empty lines. This makes the format less robust, but is tolerated.
+See http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01990.html")
+
+(defconst diff-hunk-header-re
+ (concat "^\\(?:" diff-hunk-header-re-unified ".*\\|\\*\\{15\\}.*\n\\*\\*\\* .+ \\*\\*\\*\\*\\|[0-9]+\\(,[0-9]+\\)?[acd][0-9]+\\(,[0-9]+\\)?\\)$"))
+(defconst diff-file-header-re (concat "^\\(--- .+\n\\+\\+\\+ \\|\\*\\*\\* .+\n--- \\|[^-+!<>0-9@* \n]\\).+\n" (substring diff-hunk-header-re 1)))
+(defvar diff-narrowed-to nil)
+
+(defun diff-hunk-style (&optional style)
+ (when (looking-at diff-hunk-header-re)
+ (setq style (cdr (assq (char-after) '((?@ . unified) (?* . context)))))
+ (goto-char (match-end 0)))
+ style)
+
+(defun diff-end-of-hunk (&optional style donttrustheader)
+ (let (end)
+ (when (looking-at diff-hunk-header-re)
+ ;; Especially important for unified (because headers are ambiguous).
+ (setq style (diff-hunk-style style))
+ (goto-char (match-end 0))
+ (when (and (not donttrustheader) (match-end 2))
+ (let* ((nold (string-to-number (or (match-string 2) "1")))
+ (nnew (string-to-number (or (match-string 4) "1")))
+ (endold
+ (save-excursion
+ (re-search-forward (if diff-valid-unified-empty-line
+ "^[- \n]" "^[- ]")
+ nil t nold)
+ (line-beginning-position 2)))
+ (endnew
+ ;; The hunk may end with a bunch of "+" lines, so the `end' is
+ ;; then further than computed above.
+ (save-excursion
+ (re-search-forward (if diff-valid-unified-empty-line
+ "^[+ \n]" "^[+ ]")
+ nil t nnew)
+ (line-beginning-position 2))))
+ (setq end (max endold endnew)))))
+ ;; We may have a first evaluation of `end' thanks to the hunk header.
+ (unless end
+ (setq end (and (re-search-forward
+ (case style
+ (unified (concat (if diff-valid-unified-empty-line
+ "^[^-+# \\\n]\\|" "^[^-+# \\]\\|")
+ ;; A `unified' header is ambiguous.
+ diff-file-header-re))
+ (context "^[^-+#! \\]")
+ (normal "^[^<>#\\]")
+ (t "^[^-+#!<> \\]"))
+ nil t)
+ (match-beginning 0)))
+ (when diff-valid-unified-empty-line
+ ;; While empty lines may be valid inside hunks, they are also likely
+ ;; to be unrelated to the hunk.
+ (goto-char (or end (point-max)))
+ (while (eq ?\n (char-before (1- (point))))
+ (forward-char -1)
+ (setq end (point)))))
+ ;; The return value is used by easy-mmode-define-navigation.
+ (goto-char (or end (point-max)))))
+
+(defun diff-beginning-of-hunk (&optional try-harder)
+ "Move back to beginning of hunk.
+If TRY-HARDER is non-nil, try to cater to the case where we're not in a hunk
+but in the file header instead, in which case move forward to the first hunk."
+ (beginning-of-line)
+ (unless (looking-at diff-hunk-header-re)
+ (forward-line 1)
+ (condition-case ()
+ (re-search-backward diff-hunk-header-re)
+ (error
+ (if (not try-harder)
+ (error "Can't find the beginning of the hunk")
+ (diff-beginning-of-file-and-junk)
+ (diff-hunk-next))))))
+
+(defun diff-unified-hunk-p ()
+ (save-excursion
+ (ignore-errors
+ (diff-beginning-of-hunk)
+ (looking-at "^@@"))))
+
+(defun diff-beginning-of-file ()
+ (beginning-of-line)
+ (unless (looking-at diff-file-header-re)
+ (let ((start (point))
+ res)
+ ;; diff-file-header-re may need to match up to 4 lines, so in case
+ ;; we're inside the header, we need to move up to 3 lines forward.
+ (forward-line 3)
+ (if (and (setq res (re-search-backward diff-file-header-re nil t))
+ ;; Maybe the 3 lines forward were too much and we matched
+ ;; a file header after our starting point :-(
+ (or (<= (point) start)
+ (setq res (re-search-backward diff-file-header-re nil t))))
+ res
+ (goto-char start)
+ (error "Can't find the beginning of the file")))))
+
+
+(defun diff-end-of-file ()
+ (re-search-forward "^[-+#!<>0-9@* \\]" nil t)
+ (re-search-forward (concat "^[^-+#!<>0-9@* \\]\\|" diff-file-header-re)
+ nil 'move)
+ (if (match-beginning 1)
+ (goto-char (match-beginning 1))
+ (beginning-of-line)))
+
+;; Define diff-{hunk,file}-{prev,next}
+(easy-mmode-define-navigation
+ diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view
+ (if diff-auto-refine-mode
+ (condition-case-no-debug nil (diff-refine-hunk) (error nil))))
+
+(easy-mmode-define-navigation
+ diff-file diff-file-header-re "file" diff-end-of-hunk)
+
+(defun diff-restrict-view (&optional arg)
+ "Restrict the view to the current hunk.
+If the prefix ARG is given, restrict the view to the current file instead."
+ (interactive "P")
+ (save-excursion
+ (if arg (diff-beginning-of-file) (diff-beginning-of-hunk 'try-harder))
+ (narrow-to-region (point)
+ (progn (if arg (diff-end-of-file) (diff-end-of-hunk))
+ (point)))
+ (set (make-local-variable 'diff-narrowed-to) (if arg 'file 'hunk))))
+
+
+(defun diff-hunk-kill ()
+ "Kill current hunk."
+ (interactive)
+ (diff-beginning-of-hunk)
+ (let* ((start (point))
+ ;; Search the second match, since we're looking at the first.
+ (nexthunk (when (re-search-forward diff-hunk-header-re nil t 2)
+ (match-beginning 0)))
+ (firsthunk (ignore-errors
+ (goto-char start)
+ (diff-beginning-of-file) (diff-hunk-next) (point)))
+ (nextfile (ignore-errors (diff-file-next) (point)))
+ (inhibit-read-only t))
+ (goto-char start)
+ (if (and firsthunk (= firsthunk start)
+ (or (null nexthunk)
+ (and nextfile (> nexthunk nextfile))))
+ ;; It's the only hunk for this file, so kill the file.
+ (diff-file-kill)
+ (diff-end-of-hunk)
+ (kill-region start (point)))))
+
+;; "index ", "old mode", "new mode", "new file mode" and
+;; "deleted file mode" are output by git-diff.
+(defconst diff-file-junk-re
+ "diff \\|index \\|\\(?:deleted file\\|new\\(?: file\\)?\\|old\\) mode")
+
+(defun diff-beginning-of-file-and-junk ()
+ "Go to the beginning of file-related diff-info.
+This is like `diff-beginning-of-file' except it tries to skip back over leading
+data such as \"Index: ...\" and such."
+ (let* ((orig (point))
+ ;; Skip forward over what might be "leading junk" so as to get
+ ;; closer to the actual diff.
+ (_ (progn (beginning-of-line)
+ (while (looking-at diff-file-junk-re)
+ (forward-line 1))))
+ (start (point))
+ (prevfile (condition-case err
+ (save-excursion (diff-beginning-of-file) (point))
+ (error err)))
+ (err (if (consp prevfile) prevfile))
+ (nextfile (ignore-errors
+ (save-excursion
+ (goto-char start) (diff-file-next) (point))))
+ ;; prevhunk is one of the limits.
+ (prevhunk (save-excursion
+ (ignore-errors
+ (if (numberp prevfile) (goto-char prevfile))
+ (diff-hunk-prev) (point))))
+ (previndex (save-excursion
+ (forward-line 1) ;In case we're looking at "Index:".
+ (re-search-backward "^Index: " prevhunk t))))
+ ;; If we're in the junk, we should use nextfile instead of prevfile.
+ (if (and (numberp nextfile)
+ (or (not (numberp prevfile))
+ (and previndex (> previndex prevfile))))
+ (setq prevfile nextfile))
+ (if (and previndex (numberp prevfile) (< previndex prevfile))
+ (setq prevfile previndex))
+ (if (and (numberp prevfile) (<= prevfile start))
+ (progn
+ (goto-char prevfile)
+ ;; Now skip backward over the leading junk we may have before the
+ ;; diff itself.
+ (while (save-excursion
+ (and (zerop (forward-line -1))
+ (looking-at diff-file-junk-re)))
+ (forward-line -1)))
+ ;; File starts *after* the starting point: we really weren't in
+ ;; a file diff but elsewhere.
+ (goto-char orig)
+ (signal (car err) (cdr err)))))
+
+(defun diff-file-kill ()
+ "Kill current file's hunks."
+ (interactive)
+ (let ((orig (point))
+ (start (progn (diff-beginning-of-file-and-junk) (point)))
+ (inhibit-read-only t))
+ (diff-end-of-file)
+ (if (looking-at "^\n") (forward-char 1)) ;`tla' generates such diffs.
+ (if (> orig (point)) (error "Not inside a file diff"))
+ (kill-region start (point))))
+
+(defun diff-kill-junk ()
+ "Kill spurious empty diffs."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^\\(Index: .*\n\\)"
+ "\\([^-+!* <>].*\n\\)*?"
+ "\\(\\(Index:\\) \\|"
+ diff-file-header-re "\\)")
+ nil t)
+ (delete-region (if (match-end 4) (match-beginning 0) (match-end 1))
+ (match-beginning 3))
+ (beginning-of-line)))))
+
+(defun diff-count-matches (re start end)
+ (save-excursion
+ (let ((n 0))
+ (goto-char start)
+ (while (re-search-forward re end t) (incf n))
+ n)))
+
+(defun diff-splittable-p ()
+ (save-excursion
+ (beginning-of-line)
+ (and (looking-at "^[-+ ]")
+ (progn (forward-line -1) (looking-at "^[-+ ]"))
+ (diff-unified-hunk-p))))
+
+(defun diff-split-hunk ()
+ "Split the current (unified diff) hunk at point into two hunks."
+ (interactive)
+ (beginning-of-line)
+ (let ((pos (point))
+ (start (progn (diff-beginning-of-hunk) (point))))
+ (unless (looking-at diff-hunk-header-re-unified)
+ (error "diff-split-hunk only works on unified context diffs"))
+ (forward-line 1)
+ (let* ((start1 (string-to-number (match-string 1)))
+ (start2 (string-to-number (match-string 3)))
+ (newstart1 (+ start1 (diff-count-matches "^[- \t]" (point) pos)))
+ (newstart2 (+ start2 (diff-count-matches "^[+ \t]" (point) pos)))
+ (inhibit-read-only t))
+ (goto-char pos)
+ ;; Hopefully the after-change-function will not screw us over.
+ (insert "@@ -" (number-to-string newstart1) ",1 +"
+ (number-to-string newstart2) ",1 @@\n")
+ ;; Fix the original hunk-header.
+ (diff-fixup-modifs start pos))))
+
+
+;;;;
+;;;; jump to other buffers
+;;;;
+
+(defvar diff-remembered-files-alist nil)
+(defvar diff-remembered-defdir nil)
+
+(defun diff-filename-drop-dir (file)
+ (when (string-match "/" file) (substring file (match-end 0))))
+
+(defun diff-merge-strings (ancestor from to)
+ "Merge the diff between ANCESTOR and FROM into TO.
+Returns the merged string if successful or nil otherwise.
+The strings are assumed not to contain any \"\\n\" (i.e. end of line).
+If ANCESTOR = FROM, returns TO.
+If ANCESTOR = TO, returns FROM.
+The heuristic is simplistic and only really works for cases
+like \(diff-merge-strings \"b/foo\" \"b/bar\" \"/a/c/foo\")."
+ ;; Ideally, we want:
+ ;; AMB ANB CMD -> CND
+ ;; but that's ambiguous if `foo' or `bar' is empty:
+ ;; a/foo a/foo1 b/foo.c -> b/foo1.c but not 1b/foo.c or b/foo.c1
+ (let ((str (concat ancestor "\n" from "\n" to)))
+ (when (and (string-match (concat
+ "\\`\\(.*?\\)\\(.*\\)\\(.*\\)\n"
+ "\\1\\(.*\\)\\3\n"
+ "\\(.*\\(\\2\\).*\\)\\'") str)
+ (equal to (match-string 5 str)))
+ (concat (substring str (match-beginning 5) (match-beginning 6))
+ (match-string 4 str)
+ (substring str (match-end 6) (match-end 5))))))
+
+(defun diff-tell-file-name (old name)
+ "Tell Emacs where the find the source file of the current hunk.
+If the OLD prefix arg is passed, tell the file NAME of the old file."
+ (interactive
+ (let* ((old current-prefix-arg)
+ (fs (diff-hunk-file-names current-prefix-arg)))
+ (unless fs (error "No file name to look for"))
+ (list old (read-file-name (format "File for %s: " (car fs))
+ nil (diff-find-file-name old 'noprompt) t))))
+ (let ((fs (diff-hunk-file-names old)))
+ (unless fs (error "No file name to look for"))
+ (push (cons fs name) diff-remembered-files-alist)))
+
+(defun diff-hunk-file-names (&optional old)
+ "Give the list of file names textually mentioned for the current hunk."
+ (save-excursion
+ (unless (looking-at diff-file-header-re)
+ (or (ignore-errors (diff-beginning-of-file))
+ (re-search-forward diff-file-header-re nil t)))
+ (let ((limit (save-excursion
+ (condition-case ()
+ (progn (diff-hunk-prev) (point))
+ (error (point-min)))))
+ (header-files
+ (if (looking-at "[-*][-*][-*] \\(\\S-+\\)\\(\\s-.*\\)?\n[-+][-+][-+] \\(\\S-+\\)")
+ (list (if old (match-string 1) (match-string 3))
+ (if old (match-string 3) (match-string 1)))
+ (forward-line 1) nil)))
+ (delq nil
+ (append
+ (when (and (not old)
+ (save-excursion
+ (re-search-backward "^Index: \\(.+\\)" limit t)))
+ (list (match-string 1)))
+ header-files
+ (when (re-search-backward
+ "^diff \\(-\\S-+ +\\)*\\(\\S-+\\)\\( +\\(\\S-+\\)\\)?"
+ nil t)
+ (list (if old (match-string 2) (match-string 4))
+ (if old (match-string 4) (match-string 2)))))))))
+
+(defun diff-find-file-name (&optional old noprompt prefix)
+ "Return the file corresponding to the current patch.
+Non-nil OLD means that we want the old file.
+Non-nil NOPROMPT means to prefer returning nil than to prompt the user.
+PREFIX is only used internally: don't use it."
+ (unless (equal diff-remembered-defdir default-directory)
+ ;; Flush diff-remembered-files-alist if the default-directory is changed.
+ (set (make-local-variable 'diff-remembered-defdir) default-directory)
+ (set (make-local-variable 'diff-remembered-files-alist) nil))
+ (save-excursion
+ (unless (looking-at diff-file-header-re)
+ (or (ignore-errors (diff-beginning-of-file))
+ (re-search-forward diff-file-header-re nil t)))
+ (let ((fs (diff-hunk-file-names old)))
+ (if prefix (setq fs (mapcar (lambda (f) (concat prefix f)) fs)))
+ (or
+ ;; use any previously used preference
+ (cdr (assoc fs diff-remembered-files-alist))
+ ;; try to be clever and use previous choices as an inspiration
+ (dolist (rf diff-remembered-files-alist)
+ (let ((newfile (diff-merge-strings (caar rf) (car fs) (cdr rf))))
+ (if (and newfile (file-exists-p newfile)) (return newfile))))
+ ;; look for each file in turn. If none found, try again but
+ ;; ignoring the first level of directory, ...
+ (do* ((files fs (delq nil (mapcar 'diff-filename-drop-dir files)))
+ (file nil nil))
+ ((or (null files)
+ (setq file (do* ((files files (cdr files))
+ (file (car files) (car files)))
+ ;; Use file-regular-p to avoid
+ ;; /dev/null, directories, etc.
+ ((or (null file) (file-regular-p file))
+ file))))
+ file))
+ ;; <foo>.rej patches implicitly apply to <foo>
+ (and (string-match "\\.rej\\'" (or buffer-file-name ""))
+ (let ((file (substring buffer-file-name 0 (match-beginning 0))))
+ (when (file-exists-p file) file)))
+ ;; If we haven't found the file, maybe it's because we haven't paid
+ ;; attention to the PCL-CVS hint.
+ (and (not prefix)
+ (boundp 'cvs-pcl-cvs-dirchange-re)
+ (save-excursion
+ (re-search-backward cvs-pcl-cvs-dirchange-re nil t))
+ (diff-find-file-name old noprompt (match-string 1)))
+ ;; if all else fails, ask the user
+ (unless noprompt
+ (let ((file (read-file-name (format "Use file %s: "
+ (or (first fs) ""))
+ nil (first fs) t (first fs))))
+ (set (make-local-variable 'diff-remembered-files-alist)
+ (cons (cons fs file) diff-remembered-files-alist))
+ file))))))
+
+
+(defun diff-ediff-patch ()
+ "Call `ediff-patch-file' on the current buffer."
+ (interactive)
+ (condition-case err
+ (ediff-patch-file nil (current-buffer))
+ (wrong-number-of-arguments (ediff-patch-file))))
+
+;;;;
+;;;; Conversion functions
+;;;;
+
+;;(defvar diff-inhibit-after-change nil
+;; "Non-nil means inhibit `diff-mode's after-change functions.")
+
+(defun diff-unified->context (start end)
+ "Convert unified diffs to context diffs.
+START and END are either taken from the region (if a prefix arg is given) or
+else cover the whole buffer."
+ (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active))
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
+ (unless (markerp end) (setq end (copy-marker end t)))
+ (let (;;(diff-inhibit-after-change t)
+ (inhibit-read-only t))
+ (save-excursion
+ (goto-char start)
+ (while (and (re-search-forward
+ (concat "^\\(\\(---\\) .+\n\\(\\+\\+\\+\\) .+\\|"
+ diff-hunk-header-re-unified ".*\\)$")
+ nil t)
+ (< (point) end))
+ (combine-after-change-calls
+ (if (match-beginning 2)
+ ;; we matched a file header
+ (progn
+ ;; use reverse order to make sure the indices are kept valid
+ (replace-match "---" t t nil 3)
+ (replace-match "***" t t nil 2))
+ ;; we matched a hunk header
+ (let ((line1 (match-string 4))
+ (lines1 (or (match-string 5) "1"))
+ (line2 (match-string 6))
+ (lines2 (or (match-string 7) "1"))
+ ;; Variables to use the special undo function.
+ (old-undo buffer-undo-list)
+ (old-end (marker-position end))
+ (start (match-beginning 0))
+ (reversible t))
+ (replace-match
+ (concat "***************\n*** " line1 ","
+ (number-to-string (+ (string-to-number line1)
+ (string-to-number lines1)
+ -1))
+ " ****"))
+ (save-restriction
+ (narrow-to-region (line-beginning-position 2)
+ ;; Call diff-end-of-hunk from just before
+ ;; the hunk header so it can use the hunk
+ ;; header info.
+ (progn (diff-end-of-hunk 'unified) (point)))
+ (let ((hunk (buffer-string)))
+ (goto-char (point-min))
+ (if (not (save-excursion (re-search-forward "^-" nil t)))
+ (delete-region (point) (point-max))
+ (goto-char (point-max))
+ (let ((modif nil) last-pt)
+ (while (progn (setq last-pt (point))
+ (= (forward-line -1) 0))
+ (case (char-after)
+ (?\s (insert " ") (setq modif nil) (backward-char 1))
+ (?+ (delete-region (point) last-pt) (setq modif t))
+ (?- (if (not modif)
+ (progn (forward-char 1)
+ (insert " "))
+ (delete-char 1)
+ (insert "! "))
+ (backward-char 2))
+ (?\\ (when (save-excursion (forward-line -1)
+ (= (char-after) ?+))
+ (delete-region (point) last-pt) (setq modif t)))
+ ;; diff-valid-unified-empty-line.
+ (?\n (insert " ") (setq modif nil) (backward-char 2))
+ (t (setq modif nil))))))
+ (goto-char (point-max))
+ (save-excursion
+ (insert "--- " line2 ","
+ (number-to-string (+ (string-to-number line2)
+ (string-to-number lines2)
+ -1))
+ " ----\n" hunk))
+ ;;(goto-char (point-min))
+ (forward-line 1)
+ (if (not (save-excursion (re-search-forward "^+" nil t)))
+ (delete-region (point) (point-max))
+ (let ((modif nil) (delete nil))
+ (if (save-excursion (re-search-forward "^\\+.*\n-" nil t))
+ ;; Normally, lines in a substitution come with
+ ;; first the removals and then the additions, and
+ ;; the context->unified function follows this
+ ;; convention, of course. Yet, other alternatives
+ ;; are valid as well, but they preclude the use of
+ ;; context->unified as an undo command.
+ (setq reversible nil))
+ (while (not (eobp))
+ (case (char-after)
+ (?\s (insert " ") (setq modif nil) (backward-char 1))
+ (?- (setq delete t) (setq modif t))
+ (?+ (if (not modif)
+ (progn (forward-char 1)
+ (insert " "))
+ (delete-char 1)
+ (insert "! "))
+ (backward-char 2))
+ (?\\ (when (save-excursion (forward-line 1)
+ (not (eobp)))
+ (setq delete t) (setq modif t)))
+ ;; diff-valid-unified-empty-line.
+ (?\n (insert " ") (setq modif nil) (backward-char 2)
+ (setq reversible nil))
+ (t (setq modif nil)))
+ (let ((last-pt (point)))
+ (forward-line 1)
+ (when delete
+ (delete-region last-pt (point))
+ (setq delete nil)))))))
+ (unless (or (not reversible) (eq buffer-undo-list t))
+ ;; Drop the many undo entries and replace them with
+ ;; a single entry that uses diff-context->unified to do
+ ;; the work.
+ (setq buffer-undo-list
+ (cons (list 'apply (- old-end end) start (point-max)
+ 'diff-context->unified start (point-max))
+ old-undo)))))))))))
+
+(defun diff-context->unified (start end &optional to-context)
+ "Convert context diffs to unified diffs.
+START and END are either taken from the region
+\(when it is highlighted) or else cover the whole buffer.
+With a prefix argument, convert unified format to context format."
+ (interactive (if (and transient-mark-mode mark-active)
+ (list (region-beginning) (region-end) current-prefix-arg)
+ (list (point-min) (point-max) current-prefix-arg)))
+ (if to-context
+ (diff-unified->context start end)
+ (unless (markerp end) (setq end (copy-marker end t)))
+ (let ( ;;(diff-inhibit-after-change t)
+ (inhibit-read-only t))
+ (save-excursion
+ (goto-char start)
+ (while (and (re-search-forward "^\\(\\(\\*\\*\\*\\) .+\n\\(---\\) .+\\|\\*\\{15\\}.*\n\\*\\*\\* \\([0-9]+\\),\\(-?[0-9]+\\) \\*\\*\\*\\*\\)$" nil t)
+ (< (point) end))
+ (combine-after-change-calls
+ (if (match-beginning 2)
+ ;; we matched a file header
+ (progn
+ ;; use reverse order to make sure the indices are kept valid
+ (replace-match "+++" t t nil 3)
+ (replace-match "---" t t nil 2))
+ ;; we matched a hunk header
+ (let ((line1s (match-string 4))
+ (line1e (match-string 5))
+ (pt1 (match-beginning 0))
+ ;; Variables to use the special undo function.
+ (old-undo buffer-undo-list)
+ (old-end (marker-position end))
+ (reversible t))
+ (replace-match "")
+ (unless (re-search-forward
+ diff-context-mid-hunk-header-re nil t)
+ (error "Can't find matching `--- n1,n2 ----' line"))
+ (let ((line2s (match-string 1))
+ (line2e (match-string 2))
+ (pt2 (progn
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point)))
+ (point-marker))))
+ (goto-char pt1)
+ (forward-line 1)
+ (while (< (point) pt2)
+ (case (char-after)
+ (?! (delete-char 2) (insert "-") (forward-line 1))
+ (?- (forward-char 1) (delete-char 1) (forward-line 1))
+ (?\s ;merge with the other half of the chunk
+ (let* ((endline2
+ (save-excursion
+ (goto-char pt2) (forward-line 1) (point))))
+ (case (char-after pt2)
+ ((?! ?+)
+ (insert "+"
+ (prog1 (buffer-substring (+ pt2 2) endline2)
+ (delete-region pt2 endline2))))
+ (?\s
+ (unless (= (- endline2 pt2)
+ (- (line-beginning-position 2) (point)))
+ ;; If the two lines we're merging don't have the
+ ;; same length (can happen with "diff -b"), then
+ ;; diff-unified->context will not properly undo
+ ;; this operation.
+ (setq reversible nil))
+ (delete-region pt2 endline2)
+ (delete-char 1)
+ (forward-line 1))
+ (?\\ (forward-line 1))
+ (t (setq reversible nil)
+ (delete-char 1) (forward-line 1)))))
+ (t (setq reversible nil) (forward-line 1))))
+ (while (looking-at "[+! ] ")
+ (if (/= (char-after) ?!) (forward-char 1)
+ (delete-char 1) (insert "+"))
+ (delete-char 1) (forward-line 1))
+ (save-excursion
+ (goto-char pt1)
+ (insert "@@ -" line1s ","
+ (number-to-string (- (string-to-number line1e)
+ (string-to-number line1s)
+ -1))
+ " +" line2s ","
+ (number-to-string (- (string-to-number line2e)
+ (string-to-number line2s)
+ -1)) " @@"))
+ (set-marker pt2 nil)
+ ;; The whole procedure succeeded, let's replace the myriad
+ ;; of undo elements with just a single special one.
+ (unless (or (not reversible) (eq buffer-undo-list t))
+ (setq buffer-undo-list
+ (cons (list 'apply (- old-end end) pt1 (point)
+ 'diff-unified->context pt1 (point))
+ old-undo)))
+ )))))))))
+
+(defun diff-reverse-direction (start end)
+ "Reverse the direction of the diffs.
+START and END are either taken from the region (if a prefix arg is given) or
+else cover the whole buffer."
+ (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active))
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
+ (unless (markerp end) (setq end (copy-marker end t)))
+ (let (;;(diff-inhibit-after-change t)
+ (inhibit-read-only t))
+ (save-excursion
+ (goto-char start)
+ (while (and (re-search-forward "^\\(\\([-*][-*][-*] \\)\\(.+\\)\n\\([-+][-+][-+] \\)\\(.+\\)\\|\\*\\{15\\}.*\n\\*\\*\\* \\(.+\\) \\*\\*\\*\\*\\|@@ -\\([0-9,]+\\) \\+\\([0-9,]+\\) @@.*\\)$" nil t)
+ (< (point) end))
+ (combine-after-change-calls
+ (cond
+ ;; a file header
+ ((match-beginning 2) (replace-match "\\2\\5\n\\4\\3" nil))
+ ;; a context-diff hunk header
+ ((match-beginning 6)
+ (let ((pt-lines1 (match-beginning 6))
+ (lines1 (match-string 6)))
+ (replace-match "" nil nil nil 6)
+ (forward-line 1)
+ (let ((half1s (point)))
+ (while (looking-at "[-! \\][ \t]\\|#")
+ (when (= (char-after) ?-) (delete-char 1) (insert "+"))
+ (forward-line 1))
+ (let ((half1 (delete-and-extract-region half1s (point))))
+ (unless (looking-at diff-context-mid-hunk-header-re)
+ (insert half1)
+ (error "Can't find matching `--- n1,n2 ----' line"))
+ (let* ((str1end (or (match-end 2) (match-end 1)))
+ (str1 (buffer-substring (match-beginning 1) str1end)))
+ (goto-char str1end)
+ (insert lines1)
+ (delete-region (match-beginning 1) str1end)
+ (forward-line 1)
+ (let ((half2s (point)))
+ (while (looking-at "[!+ \\][ \t]\\|#")
+ (when (= (char-after) ?+) (delete-char 1) (insert "-"))
+ (forward-line 1))
+ (let ((half2 (delete-and-extract-region half2s (point))))
+ (insert (or half1 ""))
+ (goto-char half1s)
+ (insert (or half2 ""))))
+ (goto-char pt-lines1)
+ (insert str1))))))
+ ;; a unified-diff hunk header
+ ((match-beginning 7)
+ (replace-match "@@ -\\8 +\\7 @@" nil)
+ (forward-line 1)
+ (let ((c (char-after)) first last)
+ (while (case (setq c (char-after))
+ (?- (setq first (or first (point)))
+ (delete-char 1) (insert "+") t)
+ (?+ (setq last (or last (point)))
+ (delete-char 1) (insert "-") t)
+ ((?\\ ?#) t)
+ (t (when (and first last (< first last))
+ (insert (delete-and-extract-region first last)))
+ (setq first nil last nil)
+ (memq c (if diff-valid-unified-empty-line
+ '(?\s ?\n) '(?\s)))))
+ (forward-line 1))))))))))
+
+(defun diff-fixup-modifs (start end)
+ "Fixup the hunk headers (in case the buffer was modified).
+START and END are either taken from the region (if a prefix arg is given) or
+else cover the whole buffer."
+ (interactive (if (or current-prefix-arg (and transient-mark-mode mark-active))
+ (list (region-beginning) (region-end))
+ (list (point-min) (point-max))))
+ (let ((inhibit-read-only t))
+ (save-excursion
+ (goto-char end) (diff-end-of-hunk nil 'donttrustheader)
+ (let ((plus 0) (minus 0) (space 0) (bang 0))
+ (while (and (= (forward-line -1) 0) (<= start (point)))
+ (if (not (looking-at
+ (concat diff-hunk-header-re-unified
+ "\\|[-*][-*][-*] [0-9,]+ [-*][-*][-*][-*]$"
+ "\\|--- .+\n\\+\\+\\+ ")))
+ (case (char-after)
+ (?\s (incf space))
+ (?+ (incf plus))
+ (?- (incf minus))
+ (?! (incf bang))
+ ((?\\ ?#) nil)
+ (t (setq space 0 plus 0 minus 0 bang 0)))
+ (cond
+ ((looking-at diff-hunk-header-re-unified)
+ (let* ((old1 (match-string 2))
+ (old2 (match-string 4))
+ (new1 (number-to-string (+ space minus)))
+ (new2 (number-to-string (+ space plus))))
+ (if old2
+ (unless (string= new2 old2) (replace-match new2 t t nil 4))
+ (goto-char (match-end 4)) (insert "," new2))
+ (if old1
+ (unless (string= new1 old1) (replace-match new1 t t nil 2))
+ (goto-char (match-end 2)) (insert "," new1))))
+ ((looking-at diff-context-mid-hunk-header-re)
+ (when (> (+ space bang plus) 0)
+ (let* ((old1 (match-string 1))
+ (old2 (match-string 2))
+ (new (number-to-string
+ (+ space bang plus -1 (string-to-number old1)))))
+ (unless (string= new old2) (replace-match new t t nil 2)))))
+ ((looking-at "\\*\\*\\* \\([0-9]+\\),\\(-?[0-9]*\\) \\*\\*\\*\\*$")
+ (when (> (+ space bang minus) 0)
+ (let* ((old (match-string 1))
+ (new (format
+ (concat "%0" (number-to-string (length old)) "d")
+ (+ space bang minus -1 (string-to-number old)))))
+ (unless (string= new old) (replace-match new t t nil 2))))))
+ (setq space 0 plus 0 minus 0 bang 0)))))))
+
+;;;;
+;;;; Hooks
+;;;;
+
+(defun diff-write-contents-hooks ()
+ "Fixup hunk headers if necessary."
+ (if (buffer-modified-p) (diff-fixup-modifs (point-min) (point-max)))
+ nil)
+
+;; It turns out that making changes in the buffer from within an
+;; *-change-function is asking for trouble, whereas making them
+;; from a post-command-hook doesn't pose much problems
+(defvar diff-unhandled-changes nil)
+(defun diff-after-change-function (beg end len)
+ "Remember to fixup the hunk header.
+See `after-change-functions' for the meaning of BEG, END and LEN."
+ ;; Ignoring changes when inhibit-read-only is set is strictly speaking
+ ;; incorrect, but it turns out that inhibit-read-only is normally not set
+ ;; inside editing commands, while it tends to be set when the buffer gets
+ ;; updated by an async process or by a conversion function, both of which
+ ;; would rather not be uselessly slowed down by this hook.
+ (when (and (not undo-in-progress) (not inhibit-read-only))
+ (if diff-unhandled-changes
+ (setq diff-unhandled-changes
+ (cons (min beg (car diff-unhandled-changes))
+ (max end (cdr diff-unhandled-changes))))
+ (setq diff-unhandled-changes (cons beg end)))))
+
+(defun diff-post-command-hook ()
+ "Fixup hunk headers if necessary."
+ (when (consp diff-unhandled-changes)
+ (ignore-errors
+ (save-excursion
+ (goto-char (car diff-unhandled-changes))
+ ;; Maybe we've cut the end of the hunk before point.
+ (if (and (bolp) (not (bobp))) (backward-char 1))
+ ;; We used to fixup modifs on all the changes, but it turns out that
+ ;; it's safer not to do it on big changes, e.g. when yanking a big
+ ;; diff, or when the user edits the header, since we might then
+ ;; screw up perfectly correct values. --Stef
+ (diff-beginning-of-hunk)
+ (let* ((style (if (looking-at "\\*\\*\\*") 'context))
+ (start (line-beginning-position (if (eq style 'context) 3 2)))
+ (mid (if (eq style 'context)
+ (save-excursion
+ (re-search-forward diff-context-mid-hunk-header-re
+ nil t)))))
+ (when (and ;; Don't try to fixup changes in the hunk header.
+ (> (car diff-unhandled-changes) start)
+ ;; Don't try to fixup changes in the mid-hunk header either.
+ (or (not mid)
+ (< (cdr diff-unhandled-changes) (match-beginning 0))
+ (> (car diff-unhandled-changes) (match-end 0)))
+ (save-excursion
+ (diff-end-of-hunk nil 'donttrustheader)
+ ;; Don't try to fixup changes past the end of the hunk.
+ (>= (point) (cdr diff-unhandled-changes))))
+ (diff-fixup-modifs (point) (cdr diff-unhandled-changes)))))
+ (setq diff-unhandled-changes nil))))
+
+(defun diff-next-error (arg reset)
+ ;; Select a window that displays the current buffer so that point
+ ;; movements are reflected in that window. Otherwise, the user might
+ ;; never see the hunk corresponding to the source she's jumping to.
+ (pop-to-buffer (current-buffer))
+ (if reset (goto-char (point-min)))
+ (diff-hunk-next arg)
+ (diff-goto-source))
+
+(defvar whitespace-style)
+(defvar whitespace-trailing-regexp)
+
+;;;###autoload
+(define-derived-mode diff-mode fundamental-mode "Diff"
+ "Major mode for viewing/editing context diffs.
+Supports unified and context diffs as well as (to a lesser extent)
+normal diffs.
+
+When the buffer is read-only, the ESC prefix is not necessary.
+If you edit the buffer manually, diff-mode will try to update the hunk
+headers for you on-the-fly.
+
+You can also switch between context diff and unified diff with \\[diff-context->unified],
+or vice versa with \\[diff-unified->context] and you can also reverse the direction of
+a diff with \\[diff-reverse-direction].
+
+ \\{diff-mode-map}"
+
+ (set (make-local-variable 'font-lock-defaults) diff-font-lock-defaults)
+ (set (make-local-variable 'outline-regexp) diff-outline-regexp)
+ (set (make-local-variable 'imenu-generic-expression)
+ diff-imenu-generic-expression)
+ ;; These are not perfect. They would be better done separately for
+ ;; context diffs and unidiffs.
+ ;; (set (make-local-variable 'paragraph-start)
+ ;; (concat "@@ " ; unidiff hunk
+ ;; "\\|\\*\\*\\* " ; context diff hunk or file start
+ ;; "\\|--- [^\t]+\t")) ; context or unidiff file
+ ;; ; start (first or second line)
+ ;; (set (make-local-variable 'paragraph-separate) paragraph-start)
+ ;; (set (make-local-variable 'page-delimiter) "--- [^\t]+\t")
+ ;; compile support
+ (set (make-local-variable 'next-error-function) 'diff-next-error)
+
+ (set (make-local-variable 'beginning-of-defun-function)
+ 'diff-beginning-of-file-and-junk)
+ (set (make-local-variable 'end-of-defun-function)
+ 'diff-end-of-file)
+
+ ;; Set up `whitespace-mode' so that turning it on will show trailing
+ ;; whitespace problems on the modified lines of the diff.
+ (set (make-local-variable 'whitespace-style) '(trailing))
+ (set (make-local-variable 'whitespace-trailing-regexp)
+ "^[-\+!<>].*?\\([\t ]+\\)$")
+
+ (setq buffer-read-only diff-default-read-only)
+ ;; setup change hooks
+ (if (not diff-update-on-the-fly)
+ (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t)
+ (make-local-variable 'diff-unhandled-changes)
+ (add-hook 'after-change-functions 'diff-after-change-function nil t)
+ (add-hook 'post-command-hook 'diff-post-command-hook nil t))
+ ;; Neat trick from Dave Love to add more bindings in read-only mode:
+ (lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
+ (add-to-list 'minor-mode-overriding-map-alist ro-bind)
+ ;; Turn off this little trick in case the buffer is put in view-mode.
+ (add-hook 'view-mode-hook
+ (lambda ()
+ (setq minor-mode-overriding-map-alist
+ (delq ro-bind minor-mode-overriding-map-alist)))
+ nil t))
+ ;; add-log support
+ (set (make-local-variable 'add-log-current-defun-function)
+ 'diff-current-defun)
+ (set (make-local-variable 'add-log-buffer-file-name-function)
+ (lambda () (diff-find-file-name nil 'noprompt)))
+ (unless (buffer-file-name)
+ (hack-dir-local-variables-non-file-buffer)))
+
+;;;###autoload
+(define-minor-mode diff-minor-mode
+ "Minor mode for viewing/editing context diffs.
+\\{diff-minor-mode-map}"
+ :group 'diff-mode :lighter " Diff"
+ ;; FIXME: setup font-lock
+ ;; setup change hooks
+ (if (not diff-update-on-the-fly)
+ (add-hook 'write-contents-functions 'diff-write-contents-hooks nil t)
+ (make-local-variable 'diff-unhandled-changes)
+ (add-hook 'after-change-functions 'diff-after-change-function nil t)
+ (add-hook 'post-command-hook 'diff-post-command-hook nil t)))
+
+;;; Handy hook functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun diff-delete-if-empty ()
+ ;; An empty diff file means there's no more diffs to integrate, so we
+ ;; can just remove the file altogether. Very handy for .rej files if we
+ ;; remove hunks as we apply them.
+ (when (and buffer-file-name
+ (eq 0 (nth 7 (file-attributes buffer-file-name))))
+ (delete-file buffer-file-name)))
+
+(defun diff-delete-empty-files ()
+ "Arrange for empty diff files to be removed."
+ (add-hook 'after-save-hook 'diff-delete-if-empty nil t))
+
+(defun diff-make-unified ()
+ "Turn context diffs into unified diffs if applicable."
+ (if (save-excursion
+ (goto-char (point-min))
+ (and (looking-at diff-hunk-header-re) (eq (char-after) ?*)))
+ (let ((mod (buffer-modified-p)))
+ (unwind-protect
+ (diff-context->unified (point-min) (point-max))
+ (restore-buffer-modified-p mod)))))
+
+;;;
+;;; Misc operations that have proved useful at some point.
+;;;
+
+(defun diff-next-complex-hunk ()
+ "Jump to the next \"complex\" hunk.
+\"Complex\" is approximated by \"the hunk changes the number of lines\".
+Only works for unified diffs."
+ (interactive)
+ (while
+ (and (re-search-forward diff-hunk-header-re-unified nil t)
+ (equal (match-string 2) (match-string 4)))))
+
+(defun diff-sanity-check-context-hunk-half (lines)
+ (let ((count lines))
+ (while
+ (cond
+ ((and (memq (char-after) '(?\s ?! ?+ ?-))
+ (memq (char-after (1+ (point))) '(?\s ?\t)))
+ (decf count) t)
+ ((or (zerop count) (= count lines)) nil)
+ ((memq (char-after) '(?! ?+ ?-))
+ (if (not (and (eq (char-after (1+ (point))) ?\n)
+ (y-or-n-p "Try to auto-fix whitespace loss damage? ")))
+ (error "End of hunk ambiguously marked")
+ (forward-char 1) (insert " ") (forward-line -1) t))
+ ((< lines 0)
+ (error "End of hunk ambiguously marked"))
+ ((not (y-or-n-p "Try to auto-fix whitespace loss and word-wrap damage? "))
+ (error "Abort!"))
+ ((eolp) (insert " ") (forward-line -1) t)
+ (t (insert " ") (delete-region (- (point) 2) (- (point) 1)) t))
+ (forward-line))))
+
+(defun diff-sanity-check-hunk ()
+ (let (;; Every modification is protected by a y-or-n-p, so it's probably
+ ;; OK to override a read-only setting.
+ (inhibit-read-only t))
+ (save-excursion
+ (cond
+ ((not (looking-at diff-hunk-header-re))
+ (error "Not recognizable hunk header"))
+
+ ;; A context diff.
+ ((eq (char-after) ?*)
+ (if (not (looking-at "\\*\\{15\\}\\(?: .*\\)?\n\\*\\*\\* \\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? \\*\\*\\*\\*"))
+ (error "Unrecognized context diff first hunk header format")
+ (forward-line 2)
+ (diff-sanity-check-context-hunk-half
+ (if (match-end 2)
+ (1+ (- (string-to-number (match-string 2))
+ (string-to-number (match-string 1))))
+ 1))
+ (if (not (looking-at diff-context-mid-hunk-header-re))
+ (error "Unrecognized context diff second hunk header format")
+ (forward-line)
+ (diff-sanity-check-context-hunk-half
+ (if (match-end 2)
+ (1+ (- (string-to-number (match-string 2))
+ (string-to-number (match-string 1))))
+ 1)))))
+
+ ;; A unified diff.
+ ((eq (char-after) ?@)
+ (if (not (looking-at diff-hunk-header-re-unified))
+ (error "Unrecognized unified diff hunk header format")
+ (let ((before (string-to-number (or (match-string 2) "1")))
+ (after (string-to-number (or (match-string 4) "1"))))
+ (forward-line)
+ (while
+ (case (char-after)
+ (?\s (decf before) (decf after) t)
+ (?-
+ (if (and (looking-at diff-file-header-re)
+ (zerop before) (zerop after))
+ ;; No need to query: this is a case where two patches
+ ;; are concatenated and only counting the lines will
+ ;; give the right result. Let's just add an empty
+ ;; line so that our code which doesn't count lines
+ ;; will not get confused.
+ (progn (save-excursion (insert "\n")) nil)
+ (decf before) t))
+ (?+ (decf after) t)
+ (t
+ (cond
+ ((and diff-valid-unified-empty-line
+ ;; Not just (eolp) so we don't infloop at eob.
+ (eq (char-after) ?\n)
+ (> before 0) (> after 0))
+ (decf before) (decf after) t)
+ ((and (zerop before) (zerop after)) nil)
+ ((or (< before 0) (< after 0))
+ (error (if (or (zerop before) (zerop after))
+ "End of hunk ambiguously marked"
+ "Hunk seriously messed up")))
+ ((not (y-or-n-p (concat "Try to auto-fix " (if (eolp) "whitespace loss" "word-wrap damage") "? ")))
+ (error "Abort!"))
+ ((eolp) (insert " ") (forward-line -1) t)
+ (t (insert " ")
+ (delete-region (- (point) 2) (- (point) 1)) t))))
+ (forward-line)))))
+
+ ;; A plain diff.
+ (t
+ ;; TODO.
+ )))))
+
+(defun diff-hunk-text (hunk destp char-offset)
+ "Return the literal source text from HUNK as (TEXT . OFFSET).
+If DESTP is nil, TEXT is the source, otherwise the destination text.
+CHAR-OFFSET is a char-offset in HUNK, and OFFSET is the corresponding
+char-offset in TEXT."
+ (with-temp-buffer
+ (insert hunk)
+ (goto-char (point-min))
+ (let ((src-pos nil)
+ (dst-pos nil)
+ (divider-pos nil)
+ (num-pfx-chars 2))
+ ;; Set the following variables:
+ ;; SRC-POS buffer pos of the source part of the hunk or nil if none
+ ;; DST-POS buffer pos of the destination part of the hunk or nil
+ ;; DIVIDER-POS buffer pos of any divider line separating the src & dst
+ ;; NUM-PFX-CHARS number of line-prefix characters used by this format"
+ (cond ((looking-at "^@@")
+ ;; unified diff
+ (setq num-pfx-chars 1)
+ (forward-line 1)
+ (setq src-pos (point) dst-pos (point)))
+ ((looking-at "^\\*\\*")
+ ;; context diff
+ (forward-line 2)
+ (setq src-pos (point))
+ (re-search-forward diff-context-mid-hunk-header-re nil t)
+ (forward-line 0)
+ (setq divider-pos (point))
+ (forward-line 1)
+ (setq dst-pos (point)))
+ ((looking-at "^[0-9]+a[0-9,]+$")
+ ;; normal diff, insert
+ (forward-line 1)
+ (setq dst-pos (point)))
+ ((looking-at "^[0-9,]+d[0-9]+$")
+ ;; normal diff, delete
+ (forward-line 1)
+ (setq src-pos (point)))
+ ((looking-at "^[0-9,]+c[0-9,]+$")
+ ;; normal diff, change
+ (forward-line 1)
+ (setq src-pos (point))
+ (re-search-forward "^---$" nil t)
+ (forward-line 0)
+ (setq divider-pos (point))
+ (forward-line 1)
+ (setq dst-pos (point)))
+ (t
+ (error "Unknown diff hunk type")))
+
+ (if (if destp (null dst-pos) (null src-pos))
+ ;; Implied empty text
+ (if char-offset '("" . 0) "")
+
+ ;; For context diffs, either side can be empty, (if there's only
+ ;; added or only removed text). We should then use the other side.
+ (cond ((equal src-pos divider-pos) (setq src-pos dst-pos))
+ ((equal dst-pos (point-max)) (setq dst-pos src-pos)))
+
+ (when char-offset (goto-char (+ (point-min) char-offset)))
+
+ ;; Get rid of anything except the desired text.
+ (save-excursion
+ ;; Delete unused text region
+ (let ((keep (if destp dst-pos src-pos)))
+ (when (and divider-pos (> divider-pos keep))
+ (delete-region divider-pos (point-max)))
+ (delete-region (point-min) keep))
+ ;; Remove line-prefix characters, and unneeded lines (unified diffs).
+ (let ((kill-char (if destp ?- ?+)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (eq (char-after) kill-char)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (delete-char num-pfx-chars)
+ (forward-line 1)))))
+
+ (let ((text (buffer-substring-no-properties (point-min) (point-max))))
+ (if char-offset (cons text (- (point) (point-min))) text))))))
+
+
+(defun diff-find-text (text)
+ "Return the buffer position (BEG . END) of the nearest occurrence of TEXT.
+If TEXT isn't found, nil is returned."
+ (let* ((orig (point))
+ (forw (and (search-forward text nil t)
+ (cons (match-beginning 0) (match-end 0))))
+ (back (and (goto-char (+ orig (length text)))
+ (search-backward text nil t)
+ (cons (match-beginning 0) (match-end 0)))))
+ ;; Choose the closest match.
+ (if (and forw back)
+ (if (> (- (car forw) orig) (- orig (car back))) back forw)
+ (or back forw))))
+
+(defun diff-find-approx-text (text)
+ "Return the buffer position (BEG . END) of the nearest occurrence of TEXT.
+Whitespace differences are ignored."
+ (let* ((orig (point))
+ (re (concat "^[ \t\n\f]*"
+ (mapconcat 'regexp-quote (split-string text) "[ \t\n\f]+")
+ "[ \t\n\f]*\n"))
+ (forw (and (re-search-forward re nil t)
+ (cons (match-beginning 0) (match-end 0))))
+ (back (and (goto-char (+ orig (length text)))
+ (re-search-backward re nil t)
+ (cons (match-beginning 0) (match-end 0)))))
+ ;; Choose the closest match.
+ (if (and forw back)
+ (if (> (- (car forw) orig) (- orig (car back))) back forw)
+ (or back forw))))
+
+(defsubst diff-xor (a b) (if a (if (not b) a) b))
+
+(defun diff-find-source-location (&optional other-file reverse noprompt)
+ "Find out (BUF LINE-OFFSET POS SRC DST SWITCHED).
+BUF is the buffer corresponding to the source file.
+LINE-OFFSET is the offset between the expected and actual positions
+ of the text of the hunk or nil if the text was not found.
+POS is a pair (BEG . END) indicating the position of the text in the buffer.
+SRC and DST are the two variants of text as returned by `diff-hunk-text'.
+ SRC is the variant that was found in the buffer.
+SWITCHED is non-nil if the patch is already applied.
+NOPROMPT, if non-nil, means not to prompt the user."
+ (save-excursion
+ (let* ((other (diff-xor other-file diff-jump-to-old-file))
+ (char-offset (- (point) (progn (diff-beginning-of-hunk 'try-harder)
+ (point))))
+ ;; Check that the hunk is well-formed. Otherwise diff-mode and
+ ;; the user may disagree on what constitutes the hunk
+ ;; (e.g. because an empty line truncates the hunk mid-course),
+ ;; leading to potentially nasty surprises for the user.
+ ;;
+ ;; Suppress check when NOPROMPT is non-nil (Bug#3033).
+ (_ (unless noprompt (diff-sanity-check-hunk)))
+ (hunk (buffer-substring
+ (point) (save-excursion (diff-end-of-hunk) (point))))
+ (old (diff-hunk-text hunk reverse char-offset))
+ (new (diff-hunk-text hunk (not reverse) char-offset))
+ ;; Find the location specification.
+ (line (if (not (looking-at "\\(?:\\*\\{15\\}.*\n\\)?[-@* ]*\\([0-9,]+\\)\\([ acd+]+\\([0-9,]+\\)\\)?"))
+ (error "Can't find the hunk header")
+ (if other (match-string 1)
+ (if (match-end 3) (match-string 3)
+ (unless (re-search-forward
+ diff-context-mid-hunk-header-re nil t)
+ (error "Can't find the hunk separator"))
+ (match-string 1)))))
+ (file (or (diff-find-file-name other noprompt)
+ (error "Can't find the file")))
+ (buf (find-file-noselect file)))
+ ;; Update the user preference if he so wished.
+ (when (> (prefix-numeric-value other-file) 8)
+ (setq diff-jump-to-old-file other))
+ (with-current-buffer buf
+ (goto-char (point-min)) (forward-line (1- (string-to-number line)))
+ (let* ((orig-pos (point))
+ (switched nil)
+ ;; FIXME: Check for case where both OLD and NEW are found.
+ (pos (or (diff-find-text (car old))
+ (progn (setq switched t) (diff-find-text (car new)))
+ (progn (setq switched nil)
+ (condition-case nil
+ (diff-find-approx-text (car old))
+ (invalid-regexp nil))) ;Regex too big.
+ (progn (setq switched t)
+ (condition-case nil
+ (diff-find-approx-text (car new))
+ (invalid-regexp nil))) ;Regex too big.
+ (progn (setq switched nil) nil))))
+ (nconc
+ (list buf)
+ (if pos
+ (list (count-lines orig-pos (car pos)) pos)
+ (list nil (cons orig-pos (+ orig-pos (length (car old))))))
+ (if switched (list new old t) (list old new))))))))
+
+
+(defun diff-hunk-status-msg (line-offset reversed dry-run)
+ (let ((msg (if dry-run
+ (if reversed "already applied" "not yet applied")
+ (if reversed "undone" "applied"))))
+ (message (cond ((null line-offset) "Hunk text not found")
+ ((= line-offset 0) "Hunk %s")
+ ((= line-offset 1) "Hunk %s at offset %d line")
+ (t "Hunk %s at offset %d lines"))
+ msg line-offset)))
+
+(defvar diff-apply-hunk-to-backup-file nil)
+
+(defun diff-apply-hunk (&optional reverse)
+ "Apply the current hunk to the source file and go to the next.
+By default, the new source file is patched, but if the variable
+`diff-jump-to-old-file' is non-nil, then the old source file is
+patched instead (some commands, such as `diff-goto-source' can change
+the value of this variable when given an appropriate prefix argument).
+
+With a prefix argument, REVERSE the hunk."
+ (interactive "P")
+ (destructuring-bind (buf line-offset pos old new &optional switched)
+ ;; Sometimes we'd like to have the following behavior: if REVERSE go
+ ;; to the new file, otherwise go to the old. But that means that by
+ ;; default we use the old file, which is the opposite of the default
+ ;; for diff-goto-source, and is thus confusing. Also when you don't
+ ;; know about it it's pretty surprising.
+ ;; TODO: make it possible to ask explicitly for this behavior.
+ ;;
+ ;; This is duplicated in diff-test-hunk.
+ (diff-find-source-location nil reverse)
+ (cond
+ ((null line-offset)
+ (error "Can't find the text to patch"))
+ ((with-current-buffer buf
+ (and buffer-file-name
+ (backup-file-name-p buffer-file-name)
+ (not diff-apply-hunk-to-backup-file)
+ (not (set (make-local-variable 'diff-apply-hunk-to-backup-file)
+ (yes-or-no-p (format "Really apply this hunk to %s? "
+ (file-name-nondirectory
+ buffer-file-name)))))))
+ (error "%s"
+ (substitute-command-keys
+ (format "Use %s\\[diff-apply-hunk] to apply it to the other file"
+ (if (not reverse) "\\[universal-argument] ")))))
+ ((and switched
+ ;; A reversed patch was detected, perhaps apply it in reverse.
+ (not (save-window-excursion
+ (pop-to-buffer buf)
+ (goto-char (+ (car pos) (cdr old)))
+ (y-or-n-p
+ (if reverse
+ "Hunk hasn't been applied yet; apply it now? "
+ "Hunk has already been applied; undo it? ")))))
+ (message "(Nothing done)"))
+ (t
+ ;; Apply the hunk
+ (with-current-buffer buf
+ (goto-char (car pos))
+ (delete-region (car pos) (cdr pos))
+ (insert (car new)))
+ ;; Display BUF in a window
+ (set-window-point (display-buffer buf) (+ (car pos) (cdr new)))
+ (diff-hunk-status-msg line-offset (diff-xor switched reverse) nil)
+ (when diff-advance-after-apply-hunk
+ (diff-hunk-next))))))
+
+
+(defun diff-test-hunk (&optional reverse)
+ "See whether it's possible to apply the current hunk.
+With a prefix argument, try to REVERSE the hunk."
+ (interactive "P")
+ (destructuring-bind (buf line-offset pos src dst &optional switched)
+ (diff-find-source-location nil reverse)
+ (set-window-point (display-buffer buf) (+ (car pos) (cdr src)))
+ (diff-hunk-status-msg line-offset (diff-xor reverse switched) t)))
+
+
+(defalias 'diff-mouse-goto-source 'diff-goto-source)
+
+(defun diff-goto-source (&optional other-file event)
+ "Jump to the corresponding source line.
+`diff-jump-to-old-file' (or its opposite if the OTHER-FILE prefix arg
+is given) determines whether to jump to the old or the new file.
+If the prefix arg is bigger than 8 (for example with \\[universal-argument] \\[universal-argument])
+then `diff-jump-to-old-file' is also set, for the next invocations."
+ (interactive (list current-prefix-arg last-input-event))
+ ;; When pointing at a removal line, we probably want to jump to
+ ;; the old location, and else to the new (i.e. as if reverting).
+ ;; This is a convenient detail when using smerge-diff.
+ (if event (posn-set-point (event-end event)))
+ (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]")))))
+ (destructuring-bind (buf line-offset pos src dst &optional switched)
+ (diff-find-source-location other-file rev)
+ (pop-to-buffer buf)
+ (goto-char (+ (car pos) (cdr src)))
+ (diff-hunk-status-msg line-offset (diff-xor rev switched) t))))
+
+
+(defun diff-current-defun ()
+ "Find the name of function at point.
+For use in `add-log-current-defun-function'."
+ ;; Kill change-log-default-name so it gets recomputed each time, since
+ ;; each hunk may belong to another file which may belong to another
+ ;; directory and hence have a different ChangeLog file.
+ (kill-local-variable 'change-log-default-name)
+ (save-excursion
+ (when (looking-at diff-hunk-header-re)
+ (forward-line 1)
+ (re-search-forward "^[^ ]" nil t))
+ (destructuring-bind (&optional buf line-offset pos src dst switched)
+ ;; Use `noprompt' since this is used in which-func-mode and such.
+ (ignore-errors ;Signals errors in place of prompting.
+ (diff-find-source-location nil nil 'noprompt))
+ (when buf
+ (beginning-of-line)
+ (or (when (memq (char-after) '(?< ?-))
+ ;; Cursor is pointing at removed text. This could be a removed
+ ;; function, in which case, going to the source buffer will
+ ;; not help since the function is now removed. Instead,
+ ;; try to figure out the function name just from the
+ ;; code-fragment.
+ (let ((old (if switched dst src)))
+ (with-temp-buffer
+ (insert (car old))
+ (funcall (buffer-local-value 'major-mode buf))
+ (goto-char (+ (point-min) (cdr old)))
+ (add-log-current-defun))))
+ (with-current-buffer buf
+ (goto-char (+ (car pos) (cdr src)))
+ (add-log-current-defun)))))))
+
+(defun diff-ignore-whitespace-hunk ()
+ "Re-diff the current hunk, ignoring whitespace differences."
+ (interactive)
+ (let* ((char-offset (- (point) (progn (diff-beginning-of-hunk 'try-harder)
+ (point))))
+ (opts (case (char-after) (?@ "-bu") (?* "-bc") (t "-b")))
+ (line-nb (and (or (looking-at "[^0-9]+\\([0-9]+\\)")
+ (error "Can't find line number"))
+ (string-to-number (match-string 1))))
+ (inhibit-read-only t)
+ (hunk (delete-and-extract-region
+ (point) (save-excursion (diff-end-of-hunk) (point))))
+ (lead (make-string (1- line-nb) ?\n)) ;Line nums start at 1.
+ (file1 (make-temp-file "diff1"))
+ (file2 (make-temp-file "diff2"))
+ (coding-system-for-read buffer-file-coding-system)
+ old new)
+ (unwind-protect
+ (save-excursion
+ (setq old (diff-hunk-text hunk nil char-offset))
+ (setq new (diff-hunk-text hunk t char-offset))
+ (write-region (concat lead (car old)) nil file1 nil 'nomessage)
+ (write-region (concat lead (car new)) nil file2 nil 'nomessage)
+ (with-temp-buffer
+ (let ((status
+ (call-process diff-command nil t nil
+ opts file1 file2)))
+ (case status
+ (0 nil) ;Nothing to reformat.
+ (1 (goto-char (point-min))
+ ;; Remove the file-header.
+ (when (re-search-forward diff-hunk-header-re nil t)
+ (delete-region (point-min) (match-beginning 0))))
+ (t (goto-char (point-max))
+ (unless (bolp) (insert "\n"))
+ (insert hunk)))
+ (setq hunk (buffer-string))
+ (unless (memq status '(0 1))
+ (error "Diff returned: %s" status)))))
+ ;; Whatever happens, put back some equivalent text: either the new
+ ;; one or the original one in case some error happened.
+ (insert hunk)
+ (delete-file file1)
+ (delete-file file2))))
+
+;;; Fine change highlighting.
+
+(defface diff-refine-change
+ '((((class color) (min-colors 88) (background light))
+ :background "grey85")
+ (((class color) (min-colors 88) (background dark))
+ :background "grey60")
+ (((class color) (background light))
+ :background "yellow")
+ (((class color) (background dark))
+ :background "green")
+ (t :weight bold))
+ "Face used for char-based changes shown by `diff-refine-hunk'."
+ :group 'diff-mode)
+
+(defun diff-refine-preproc ()
+ (while (re-search-forward "^[+>]" nil t)
+ ;; Remove spurious changes due to the fact that one side of the hunk is
+ ;; marked with leading + or > and the other with leading - or <.
+ ;; We used to replace all the prefix chars with " " but this only worked
+ ;; when we did char-based refinement (or when using
+ ;; smerge-refine-weight-hack) since otherwise, the `forward' motion done
+ ;; in chopup do not necessarily do the same as the ones in highlight
+ ;; since the "_" is not treated the same as " ".
+ (replace-match (cdr (assq (char-before) '((?+ . "-") (?> . "<"))))))
+ )
+
+(defun diff-refine-hunk ()
+ "Highlight changes of hunk at point at a finer granularity."
+ (interactive)
+ (eval-and-compile (require 'smerge-mode))
+ (save-excursion
+ (diff-beginning-of-hunk 'try-harder)
+ (let* ((style (diff-hunk-style)) ;Skips the hunk header as well.
+ (beg (point))
+ (props '((diff-mode . fine) (face diff-refine-change)))
+ (end (progn (diff-end-of-hunk) (point))))
+
+ (remove-overlays beg end 'diff-mode 'fine)
+
+ (goto-char beg)
+ (case style
+ (unified
+ (while (re-search-forward "^\\(?:-.*\n\\)+\\(\\)\\(?:\\+.*\n\\)+"
+ end t)
+ (smerge-refine-subst (match-beginning 0) (match-end 1)
+ (match-end 1) (match-end 0)
+ props 'diff-refine-preproc)))
+ (context
+ (let* ((middle (save-excursion (re-search-forward "^---")))
+ (other middle))
+ (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
+ (smerge-refine-subst (match-beginning 0) (match-end 0)
+ (save-excursion
+ (goto-char other)
+ (re-search-forward "^\\(?:!.*\n\\)+" end)
+ (setq other (match-end 0))
+ (match-beginning 0))
+ other
+ props 'diff-refine-preproc))))
+ (t ;; Normal diffs.
+ (let ((beg1 (1+ (point))))
+ (when (re-search-forward "^---.*\n" end t)
+ ;; It's a combined add&remove, so there's something to do.
+ (smerge-refine-subst beg1 (match-beginning 0)
+ (match-end 0) end
+ props 'diff-refine-preproc))))))))
+
+
+(defun diff-add-change-log-entries-other-window ()
+ "Iterate through the current diff and create ChangeLog entries.
+I.e. like `add-change-log-entry-other-window' but applied to all hunks."
+ (interactive)
+ ;; XXX: Currently add-change-log-entry-other-window is only called
+ ;; once per hunk. Some hunks have multiple changes, it would be
+ ;; good to call it for each change.
+ (save-excursion
+ (goto-char (point-min))
+ (let ((orig-buffer (current-buffer)))
+ (condition-case nil
+ ;; Call add-change-log-entry-other-window for each hunk in
+ ;; the diff buffer.
+ (while (progn
+ (diff-hunk-next)
+ ;; Move to where the changes are,
+ ;; `add-change-log-entry-other-window' works better in
+ ;; that case.
+ (re-search-forward
+ (concat "\n[!+-<>]"
+ ;; If the hunk is a context hunk with an empty first
+ ;; half, recognize the "--- NNN,MMM ----" line
+ "\\(-- [0-9]+\\(,[0-9]+\\)? ----\n"
+ ;; and skip to the next non-context line.
+ "\\( .*\n\\)*[+]\\)?")
+ nil t))
+ (save-excursion
+ ;; FIXME: this pops up windows of all the buffers.
+ (add-change-log-entry nil nil t nil t)))
+ ;; When there's no more hunks, diff-hunk-next signals an error.
+ (error nil)))))
+
+;; provide the package
+(provide 'diff-mode)
+
+;;; Old Change Log from when diff-mode wasn't part of Emacs:
+;; Revision 1.11 1999/10/09 23:38:29 monnier
+;; (diff-mode-load-hook): dropped.
+;; (auto-mode-alist): also catch *.diffs.
+;; (diff-find-file-name, diff-mode): add smarts to find the right file
+;; for *.rej files (that lack any file name indication).
+;;
+;; Revision 1.10 1999/09/30 15:32:11 monnier
+;; added support for "\ No newline at end of file".
+;;
+;; Revision 1.9 1999/09/15 00:01:13 monnier
+;; - added basic `compile' support.
+;; - have diff-kill-hunk call diff-kill-file if it's the only hunk.
+;; - diff-kill-file now tries to kill the leading garbage as well.
+;;
+;; Revision 1.8 1999/09/13 21:10:09 monnier
+;; - don't use CL in the autoloaded code
+;; - accept diffs using -T
+;;
+;; Revision 1.7 1999/09/05 20:53:03 monnier
+;; interface to ediff-patch
+;;
+;; Revision 1.6 1999/09/01 20:55:13 monnier
+;; (ediff=patch-file): add bindings to call ediff-patch.
+;; (diff-find-file-name): taken out of diff-goto-source.
+;; (diff-unified->context, diff-context->unified, diff-reverse-direction,
+;; diff-fixup-modifs): only use the region if a prefix arg is given.
+;;
+;; Revision 1.5 1999/08/31 19:18:52 monnier
+;; (diff-beginning-of-file, diff-prev-file): fixed wrong parenthesis.
+;;
+;; Revision 1.4 1999/08/31 13:01:44 monnier
+;; use `combine-after-change-calls' to minimize the slowdown of font-lock.
+;;
+
+;; arch-tag: 2571d7ff-bc28-4cf9-8585-42e21890be66
+;;; diff-mode.el ends here
--- /dev/null
+;;; diff.el --- run `diff' in compilation-mode
+
+;; Copyright (C) 1992, 1994, 1996, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Frank Bresz
+;; (according to authors.el)
+;; Maintainer: FSF
+;; Keywords: unix, tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package helps you explore differences between files, using the
+;; UNIX command diff(1). The commands are `diff' and `diff-backup'.
+;; You can specify options with `diff-switches'.
+
+;;; Code:
+
+(defgroup diff nil
+ "Comparing files with `diff'."
+ :group 'tools)
+
+;;;###autoload
+(defcustom diff-switches (purecopy "-c")
+ "A string or list of strings specifying switches to be passed to diff."
+ :type '(choice string (repeat string))
+ :group 'diff)
+
+;;;###autoload
+(defcustom diff-command (purecopy "diff")
+ "The command to use to run diff."
+ :type 'string
+ :group 'diff)
+
+(defvar diff-old-temp-file nil
+ "This is the name of a temp file to be deleted after diff finishes.")
+(defvar diff-new-temp-file nil
+ "This is the name of a temp file to be deleted after diff finishes.")
+
+;; prompt if prefix arg present
+(defun diff-switches ()
+ (if current-prefix-arg
+ (read-string "Diff switches: "
+ (if (stringp diff-switches)
+ diff-switches
+ (mapconcat 'identity diff-switches " ")))))
+
+(defun diff-sentinel (code)
+ "Code run when the diff process exits.
+CODE is the exit code of the process. It should be 0 only if no diffs
+were found."
+ (if diff-old-temp-file (delete-file diff-old-temp-file))
+ (if diff-new-temp-file (delete-file diff-new-temp-file))
+ (save-excursion
+ (goto-char (point-max))
+ (let ((inhibit-read-only t))
+ (insert (format "\nDiff finished%s. %s\n"
+ (cond ((equal 0 code) " (no differences)")
+ ((equal 2 code) " (diff error)")
+ (t ""))
+ (current-time-string))))))
+
+(defvar diff-old-file nil)
+(defvar diff-new-file nil)
+(defvar diff-extra-args nil)
+
+;;;###autoload
+(defun diff (old new &optional switches no-async)
+ "Find and display the differences between OLD and NEW files.
+When called interactively, read OLD and NEW using the minibuffer;
+the default for NEW is the current buffer's file name, and the
+default for OLD is a backup file for NEW, if one exists.
+If NO-ASYNC is non-nil, call diff synchronously.
+
+When called interactively with a prefix argument, prompt
+interactively for diff switches. Otherwise, the switches
+specified in `diff-switches' are passed to the diff command."
+ (interactive
+ (let (oldf newf)
+ (setq newf (buffer-file-name)
+ newf (if (and newf (file-exists-p newf))
+ (read-file-name
+ (concat "Diff new file (default "
+ (file-name-nondirectory newf) "): ")
+ nil newf t)
+ (read-file-name "Diff new file: " nil nil t)))
+ (setq oldf (file-newest-backup newf)
+ oldf (if (and oldf (file-exists-p oldf))
+ (read-file-name
+ (concat "Diff original file (default "
+ (file-name-nondirectory oldf) "): ")
+ (file-name-directory oldf) oldf t)
+ (read-file-name "Diff original file: "
+ (file-name-directory newf) nil t)))
+ (list oldf newf (diff-switches))))
+ (setq new (expand-file-name new)
+ old (expand-file-name old))
+ (or switches (setq switches diff-switches)) ; If not specified, use default.
+ (let* ((old-alt (file-local-copy old))
+ (new-alt (file-local-copy new))
+ (command
+ (mapconcat 'identity
+ `(,diff-command
+ ;; Use explicitly specified switches
+ ,@(if (listp switches) switches (list switches))
+ ,@(if (or old-alt new-alt)
+ (list "-L" old "-L" new))
+ ,(shell-quote-argument (or old-alt old))
+ ,(shell-quote-argument (or new-alt new)))
+ " "))
+ (buf (get-buffer-create "*Diff*"))
+ (thisdir default-directory)
+ proc)
+ (save-excursion
+ (display-buffer buf)
+ (set-buffer buf)
+ (setq buffer-read-only nil)
+ (buffer-disable-undo (current-buffer))
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (buffer-enable-undo (current-buffer))
+ (diff-mode)
+ ;; Use below 2 vars for backward-compatibility.
+ (set (make-local-variable 'diff-old-file) old)
+ (set (make-local-variable 'diff-new-file) new)
+ (set (make-local-variable 'diff-extra-args) (list switches no-async))
+ (set (make-local-variable 'revert-buffer-function)
+ (lambda (ignore-auto noconfirm)
+ (apply 'diff diff-old-file diff-new-file diff-extra-args)))
+ (set (make-local-variable 'diff-old-temp-file) old-alt)
+ (set (make-local-variable 'diff-new-temp-file) new-alt)
+ (setq default-directory thisdir)
+ (let ((inhibit-read-only t))
+ (insert command "\n"))
+ (if (and (not no-async) (fboundp 'start-process))
+ (progn
+ (setq proc (start-process "Diff" buf shell-file-name
+ shell-command-switch command))
+ (set-process-filter proc 'diff-process-filter)
+ (set-process-sentinel
+ proc (lambda (proc msg)
+ (with-current-buffer (process-buffer proc)
+ (diff-sentinel (process-exit-status proc))))))
+ ;; Async processes aren't available.
+ (let ((inhibit-read-only t))
+ (diff-sentinel
+ (call-process shell-file-name nil buf nil
+ shell-command-switch command)))))
+ buf))
+
+(defun diff-process-filter (proc string)
+ (with-current-buffer (process-buffer proc)
+ (let ((moving (= (point) (process-mark proc))))
+ (save-excursion
+ ;; Insert the text, advancing the process marker.
+ (goto-char (process-mark proc))
+ (let ((inhibit-read-only t))
+ (insert string))
+ (set-marker (process-mark proc) (point)))
+ (if moving (goto-char (process-mark proc))))))
+
+;;;###autoload
+(defun diff-backup (file &optional switches)
+ "Diff this file with its backup file or vice versa.
+Uses the latest backup, if there are several numerical backups.
+If this file is a backup, diff it with its original.
+The backup file is the first file given to `diff'.
+With prefix arg, prompt for diff switches."
+ (interactive (list (read-file-name "Diff (file with backup): ")
+ (diff-switches)))
+ (let (bak ori)
+ (if (backup-file-name-p file)
+ (setq bak file
+ ori (file-name-sans-versions file))
+ (setq bak (or (diff-latest-backup-file file)
+ (error "No backup found for %s" file))
+ ori file))
+ (diff bak ori switches)))
+
+(defun diff-latest-backup-file (fn) ; actually belongs into files.el
+ "Return the latest existing backup of FILE, or nil."
+ (let ((handler (find-file-name-handler fn 'diff-latest-backup-file)))
+ (if handler
+ (funcall handler 'diff-latest-backup-file fn)
+ (file-newest-backup fn))))
+
+(provide 'diff)
+
+;; arch-tag: 7de2c29b-7ea5-4b85-9b9d-72dd860de2bd
+;;; diff.el ends here
--- /dev/null
+;;; ediff-diff.el --- diff-related utilities
+
+;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+(provide 'ediff-diff)
+
+(eval-when-compile
+ (require 'ediff-util))
+
+(require 'ediff-init)
+
+(defgroup ediff-diff nil
+ "Diff related utilities."
+ :prefix "ediff-"
+ :group 'ediff)
+
+(defcustom ediff-diff-program "diff"
+ "Program to use for generating the differential of the two files."
+ :type 'string
+ :group 'ediff-diff)
+(defcustom ediff-diff3-program "diff3"
+ "Program to be used for three-way comparison.
+Must produce output compatible with Unix's diff3 program."
+ :type 'string
+ :group 'ediff-diff)
+
+
+;; The following functions must precede all defcustom-defined variables.
+
+(fset 'ediff-set-actual-diff-options '(lambda () nil))
+
+(defcustom ediff-shell
+ (cond ((eq system-type 'emx) "cmd") ; OS/2
+ ((memq system-type '(ms-dos windows-nt windows-95))
+ shell-file-name) ; no standard name on MS-DOS
+ (t "sh")) ; UNIX
+ "The shell used to run diff and patch.
+If user's .profile or .cshrc files are set up correctly, any shell
+will do. However, some people set $prompt or other things
+incorrectly, which leads to undesirable output messages. These may
+cause Ediff to fail. In such a case, set `ediff-shell' to a shell that
+you are not using or, better, fix your shell's startup file."
+ :type 'string
+ :group 'ediff-diff)
+
+(defcustom ediff-cmp-program "cmp"
+ "Utility to use to determine if two files are identical.
+It must return code 0, if its arguments are identical files."
+ :type 'string
+ :group 'ediff-diff)
+
+(defcustom ediff-cmp-options nil
+ "Options to pass to `ediff-cmp-program'.
+If GNU diff is used as `ediff-cmp-program', then the most useful options
+are `-I REGEXP', to ignore changes whose lines match the REGEXP."
+ :type '(repeat string)
+ :group 'ediff-diff)
+
+(defun ediff-set-diff-options (symbol value)
+ (set symbol value)
+ (ediff-set-actual-diff-options))
+
+(defcustom ediff-diff-options
+ (if (memq system-type '(ms-dos windows-nt windows-95)) "--binary" "")
+ "Options to pass to `ediff-diff-program'.
+If Unix diff is used as `ediff-diff-program',
+then a useful option is `-w', to ignore space.
+Options `-c', `-u', and `-i' are not allowed. Case sensitivity can be
+toggled interactively using \\[ediff-toggle-ignore-case].
+
+Do not remove the default options. If you need to change this variable, add new
+options after the default ones.
+
+This variable is not for customizing the look of the differences produced by
+the command \\[ediff-show-diff-output]. Use the variable
+`ediff-custom-diff-options' for that."
+ :set 'ediff-set-diff-options
+ :type 'string
+ :group 'ediff-diff)
+
+(ediff-defvar-local ediff-ignore-case nil
+ "*If t, skip over difference regions that differ only in letter case.
+This variable can be set either in .emacs or toggled interactively.
+Use `setq-default' if setting it in .emacs")
+
+(defcustom ediff-ignore-case-option "-i"
+ "Option that causes the diff program to ignore case of letters."
+ :type 'string
+ :group 'ediff-diff)
+
+(defcustom ediff-ignore-case-option3 ""
+ "Option that causes the diff3 program to ignore case of letters.
+GNU diff3 doesn't have such an option."
+ :type 'string
+ :group 'ediff-diff)
+
+;; the actual options used in comparison
+(ediff-defvar-local ediff-actual-diff-options ediff-diff-options "")
+
+(defcustom ediff-custom-diff-program ediff-diff-program
+ "Program to use for generating custom diff output for saving it in a file.
+This output is not used by Ediff internally."
+ :type 'string
+ :group 'ediff-diff)
+(defcustom ediff-custom-diff-options "-c"
+ "Options to pass to `ediff-custom-diff-program'."
+ :type 'string
+ :group 'ediff-diff)
+
+;;; Support for diff3
+
+(defvar ediff-match-diff3-line "^====\\(.?\\)\C-m?$"
+ "Pattern to match lines produced by diff3 that describe differences.")
+(defcustom ediff-diff3-options ""
+ "Options to pass to `ediff-diff3-program'."
+ :set 'ediff-set-diff-options
+ :type 'string
+ :group 'ediff-diff)
+
+;; the actual options used in comparison
+(ediff-defvar-local ediff-actual-diff3-options ediff-diff3-options "")
+
+(defcustom ediff-diff3-ok-lines-regexp
+ "^\\([1-3]:\\|====\\| \\|.*Warning *:\\|.*No newline\\|.*missing newline\\|^\C-m$\\)"
+ "Regexp that matches normal output lines from `ediff-diff3-program'.
+Lines that do not match are assumed to be error messages."
+ :type 'regexp
+ :group 'ediff-diff)
+
+;; keeps the status of the current diff in 3-way jobs.
+;; the status can be =diff(A), =diff(B), or =diff(A+B)
+(ediff-defvar-local ediff-diff-status "" "")
+
+
+;;; Fine differences
+
+(ediff-defvar-local ediff-auto-refine (if (ediff-has-face-support-p) 'on 'nix)
+ "If `on', Ediff auto-highlights fine diffs for the current diff region.
+If `off', auto-highlighting is not used. If `nix', no fine diffs are shown
+at all, unless the user force-refines the region by hitting `*'.
+
+This variable can be set either in .emacs or toggled interactively.
+Use `setq-default' if setting it in .emacs")
+
+(ediff-defvar-local ediff-ignore-similar-regions nil
+ "*If t, skip over difference regions that differ only in the white space and line breaks.
+This variable can be set either in .emacs or toggled interactively.
+Use `setq-default' if setting it in .emacs")
+
+(ediff-defvar-local ediff-auto-refine-limit 14000
+ "*Auto-refine only the regions of this size \(in bytes\) or less.")
+
+;;; General
+
+(defvar ediff-diff-ok-lines-regexp
+ (concat
+ "^\\("
+ "[0-9,]+[acd][0-9,]+\C-m?$"
+ "\\|[<>] "
+ "\\|---"
+ "\\|.*Warning *:"
+ "\\|.*No +newline"
+ "\\|.*missing +newline"
+ "\\|^\C-m?$"
+ "\\)")
+ "Regexp that matches normal output lines from `ediff-diff-program'.
+This is mostly lifted from Emerge, except that Ediff also considers
+warnings and `Missing newline'-type messages to be normal output.
+Lines that do not match are assumed to be error messages.")
+
+(defvar ediff-match-diff-line
+ (let ((x "\\([0-9]+\\)\\(\\|,\\([0-9]+\\)\\)"))
+ (concat "^" x "\\([acd]\\)" x "\C-m?$"))
+ "Pattern to match lines produced by diff that describe differences.")
+
+(ediff-defvar-local ediff-setup-diff-regions-function nil
+ "value is a function symbol depending on the kind of job is to be done.
+For 2-way jobs and for ediff-merge, it should be `ediff-setup-diff-regions'.
+For jobs requiring diff3, it should be `ediff-setup-diff-regions3'.
+
+The function should take three mandatory arguments, file-A, file-B, and
+file-C. It may ignore file C for diff2 jobs. It should also take
+one optional arguments, diff-number to refine.")
+
+
+;;; Functions
+
+;; Generate the difference vector and overlays for the two files
+;; With optional arg REG-TO-REFINE, refine this region.
+;; File-C argument is not used here. It is there just because
+;; ediff-setup-diff-regions is called via a funcall to
+;; ediff-setup-diff-regions-function, which can also have the value
+;; ediff-setup-diff-regions3, which takes 4 arguments.
+(defun ediff-setup-diff-regions (file-A file-B file-C)
+ ;; looking for '-c', '-i', '-u', or 'c', 'i', 'u' among clustered non-long options
+ (if (string-match "^-[ciu]\\| -[ciu]\\|\\(^\\| \\)-[^- ]+[ciu]"
+ ediff-diff-options)
+ (error "Options `-c', `-u', and `-i' are not allowed in `ediff-diff-options'"))
+
+ ;; create, if it doesn't exist
+ (or (ediff-buffer-live-p ediff-diff-buffer)
+ (setq ediff-diff-buffer
+ (get-buffer-create (ediff-unique-buffer-name "*ediff-diff" "*"))))
+ (ediff-make-diff2-buffer ediff-diff-buffer file-A file-B)
+ (ediff-prepare-error-list ediff-diff-ok-lines-regexp ediff-diff-buffer)
+ (ediff-convert-diffs-to-overlays
+ (ediff-extract-diffs
+ ediff-diff-buffer ediff-word-mode ediff-narrow-bounds)))
+
+;; Run the diff program on FILE1 and FILE2 and put the output in DIFF-BUFFER
+;; Return the size of DIFF-BUFFER
+;; The return code isn't used in the program at present.
+(defun ediff-make-diff2-buffer (diff-buffer file1 file2)
+ (let ((file1-size (ediff-file-size file1))
+ (file2-size (ediff-file-size file2)))
+ (cond ((not (numberp file1-size))
+ (message "Can't find file: %s"
+ (ediff-abbreviate-file-name file1))
+ (sit-for 2)
+ ;; 1 is an error exit code
+ 1)
+ ((not (numberp file2-size))
+ (message "Can't find file: %s"
+ (ediff-abbreviate-file-name file2))
+ (sit-for 2)
+ ;; 1 is an error exit code
+ 1)
+ (t (message "Computing differences between %s and %s ..."
+ (file-name-nondirectory file1)
+ (file-name-nondirectory file2))
+ ;; this erases the diff buffer automatically
+ (ediff-exec-process ediff-diff-program
+ diff-buffer
+ 'synchronize
+ ediff-actual-diff-options file1 file2)
+ (message "")
+ (ediff-with-current-buffer diff-buffer
+ (buffer-size))))))
+
+
+
+;; If file-A/B/C is nil, do 2-way comparison with the non-nil buffers
+;; This function works for diff3 and diff2 jobs
+(defun ediff-setup-fine-diff-regions (file-A file-B file-C reg-num)
+ (or (ediff-buffer-live-p ediff-fine-diff-buffer)
+ (setq ediff-fine-diff-buffer
+ (get-buffer-create
+ (ediff-unique-buffer-name "*ediff-fine-diff" "*"))))
+
+ (let (diff3-job diff-program diff-options ok-regexp diff-list)
+ (setq diff3-job ediff-3way-job
+ diff-program (if diff3-job ediff-diff3-program ediff-diff-program)
+ diff-options (if diff3-job
+ ediff-actual-diff3-options
+ ediff-actual-diff-options)
+ ok-regexp (if diff3-job
+ ediff-diff3-ok-lines-regexp
+ ediff-diff-ok-lines-regexp))
+
+ (ediff-message-if-verbose "Refining difference region %d ..." (1+ reg-num))
+ (ediff-exec-process diff-program ediff-fine-diff-buffer 'synchronize
+ diff-options
+ ;; The shuffle below is because we can compare 3-way
+ ;; or in several 2-way fashions, like fA fC, fA fB,
+ ;; or fB fC.
+ (if file-A file-A file-B)
+ (if file-B file-B file-A)
+ (if diff3-job
+ (if file-C file-C file-B))
+ ) ; exec process
+
+ (ediff-prepare-error-list ok-regexp ediff-fine-diff-buffer)
+ (ediff-message-if-verbose
+ "")
+ ;; "Refining difference region %d ... done" (1+ reg-num))
+
+ (setq diff-list
+ (if diff3-job
+ (ediff-extract-diffs3
+ ediff-fine-diff-buffer '3way-comparison 'word-mode)
+ (ediff-extract-diffs ediff-fine-diff-buffer 'word-mode)))
+ ;; fixup diff-list
+ (if diff3-job
+ (cond ((not file-A)
+ (mapc (lambda (elt)
+ (aset elt 0 nil)
+ (aset elt 1 nil))
+ (cdr diff-list)))
+ ((not file-B)
+ (mapc (lambda (elt)
+ (aset elt 2 nil)
+ (aset elt 3 nil))
+ (cdr diff-list)))
+ ((not file-C)
+ (mapc (lambda (elt)
+ (aset elt 4 nil)
+ (aset elt 5 nil))
+ (cdr diff-list)))
+ ))
+
+ (ediff-convert-fine-diffs-to-overlays diff-list reg-num)
+ ))
+
+
+(defun ediff-prepare-error-list (ok-regexp diff-buff)
+ (or (ediff-buffer-live-p ediff-error-buffer)
+ (setq ediff-error-buffer
+ (get-buffer-create (ediff-unique-buffer-name
+ "*ediff-errors" "*"))))
+ (ediff-with-current-buffer ediff-error-buffer
+ (setq buffer-undo-list t)
+ (erase-buffer)
+ (insert (ediff-with-current-buffer diff-buff (buffer-string)))
+ (goto-char (point-min))
+ (delete-matching-lines ok-regexp))
+ ;; If diff reports errors, show them then quit.
+ (if (/= 0 (ediff-with-current-buffer ediff-error-buffer (buffer-size)))
+ (let ((ctl-buf ediff-control-buffer)
+ (error-buf ediff-error-buffer))
+ (ediff-skip-unsuitable-frames)
+ (switch-to-buffer error-buf)
+ (ediff-kill-buffer-carefully ctl-buf)
+ (error "Errors in diff output. Diff output is in %S" diff-buff))))
+
+;; BOUNDS specifies visibility bounds to use.
+;; WORD-MODE tells whether we are in the word-mode or not.
+;; If WORD-MODE, also construct vector of diffs using word numbers.
+;; Else, use point values.
+;; This function handles diff-2 jobs including the case of
+;; merging buffers and files without ancestor.
+(defun ediff-extract-diffs (diff-buffer word-mode &optional bounds)
+ (let ((A-buffer ediff-buffer-A)
+ (B-buffer ediff-buffer-B)
+ (C-buffer ediff-buffer-C)
+ (a-prev 1) ; this is needed to set the first diff line correctly
+ (a-prev-pt nil)
+ (b-prev 1)
+ (b-prev-pt nil)
+ (c-prev 1)
+ (c-prev-pt nil)
+ diff-list shift-A shift-B
+ )
+
+ ;; diff list contains word numbers, unless changed later
+ (setq diff-list (cons (if word-mode 'words 'points)
+ diff-list))
+ ;; we don't use visibility bounds for buffer C when merging
+ (if bounds
+ (setq shift-A
+ (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type 'A bounds))
+ shift-B
+ (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type 'B bounds))))
+
+ ;; reset point in buffers A/B/C
+ (ediff-with-current-buffer A-buffer
+ (goto-char (if shift-A shift-A (point-min))))
+ (ediff-with-current-buffer B-buffer
+ (goto-char (if shift-B shift-B (point-min))))
+ (if (ediff-buffer-live-p C-buffer)
+ (ediff-with-current-buffer C-buffer
+ (goto-char (point-min))))
+
+ (ediff-with-current-buffer diff-buffer
+ (goto-char (point-min))
+ (while (re-search-forward ediff-match-diff-line nil t)
+ (let* ((a-begin (string-to-number (buffer-substring (match-beginning 1)
+ (match-end 1))))
+ (a-end (let ((b (match-beginning 3))
+ (e (match-end 3)))
+ (if b
+ (string-to-number (buffer-substring b e))
+ a-begin)))
+ (diff-type (buffer-substring (match-beginning 4) (match-end 4)))
+ (b-begin (string-to-number (buffer-substring (match-beginning 5)
+ (match-end 5))))
+ (b-end (let ((b (match-beginning 7))
+ (e (match-end 7)))
+ (if b
+ (string-to-number (buffer-substring b e))
+ b-begin)))
+ a-begin-pt a-end-pt b-begin-pt b-end-pt
+ c-begin c-end c-begin-pt c-end-pt)
+ ;; fix the beginning and end numbers, because diff is somewhat
+ ;; strange about how it numbers lines
+ (if (string-equal diff-type "a")
+ (setq b-end (1+ b-end)
+ a-begin (1+ a-begin)
+ a-end a-begin)
+ (if (string-equal diff-type "d")
+ (setq a-end (1+ a-end)
+ b-begin (1+ b-begin)
+ b-end b-begin)
+ ;; (string-equal diff-type "c")
+ (setq a-end (1+ a-end)
+ b-end (1+ b-end))))
+
+ (if (eq ediff-default-variant 'default-B)
+ (setq c-begin b-begin
+ c-end b-end)
+ (setq c-begin a-begin
+ c-end a-end))
+
+ ;; compute main diff vector
+ (if word-mode
+ ;; make diff-list contain word numbers
+ (setq diff-list
+ (nconc diff-list
+ (list
+ (if (ediff-buffer-live-p C-buffer)
+ (vector (- a-begin a-prev) (- a-end a-begin)
+ (- b-begin b-prev) (- b-end b-begin)
+ (- c-begin c-prev) (- c-end c-begin)
+ nil nil ; dummy ancestor
+ nil ; state of diff
+ nil ; state of merge
+ nil ; state of ancestor
+ )
+ (vector (- a-begin a-prev) (- a-end a-begin)
+ (- b-begin b-prev) (- b-end b-begin)
+ nil nil ; dummy buf C
+ nil nil ; dummy ancestor
+ nil ; state of diff
+ nil ; state of merge
+ nil ; state of ancestor
+ ))
+ ))
+ a-prev a-end
+ b-prev b-end
+ c-prev c-end)
+ ;; else convert lines to points
+ (ediff-with-current-buffer A-buffer
+ (let ((longlines-mode-val
+ (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
+ ;; we must disable and then restore longlines-mode
+ (if (eq longlines-mode-val 1)
+ (longlines-mode 0))
+ (goto-char (or a-prev-pt shift-A (point-min)))
+ (forward-line (- a-begin a-prev))
+ (setq a-begin-pt (point))
+ (forward-line (- a-end a-begin))
+ (setq a-end-pt (point)
+ a-prev a-end
+ a-prev-pt a-end-pt)
+ (if (eq longlines-mode-val 1)
+ (longlines-mode longlines-mode-val))
+ ))
+ (ediff-with-current-buffer B-buffer
+ (let ((longlines-mode-val
+ (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
+ (if (eq longlines-mode-val 1)
+ (longlines-mode 0))
+ (goto-char (or b-prev-pt shift-B (point-min)))
+ (forward-line (- b-begin b-prev))
+ (setq b-begin-pt (point))
+ (forward-line (- b-end b-begin))
+ (setq b-end-pt (point)
+ b-prev b-end
+ b-prev-pt b-end-pt)
+ (if (eq longlines-mode-val 1)
+ (longlines-mode longlines-mode-val))
+ ))
+ (if (ediff-buffer-live-p C-buffer)
+ (ediff-with-current-buffer C-buffer
+ (let ((longlines-mode-val
+ (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
+ (if (eq longlines-mode-val 1)
+ (longlines-mode 0))
+ (goto-char (or c-prev-pt (point-min)))
+ (forward-line (- c-begin c-prev))
+ (setq c-begin-pt (point))
+ (forward-line (- c-end c-begin))
+ (setq c-end-pt (point)
+ c-prev c-end
+ c-prev-pt c-end-pt)
+ (if (eq longlines-mode-val 1)
+ (longlines-mode longlines-mode-val))
+ )))
+ (setq diff-list
+ (nconc
+ diff-list
+ (list
+ (if (ediff-buffer-live-p C-buffer)
+ (vector
+ a-begin-pt a-end-pt b-begin-pt b-end-pt
+ c-begin-pt c-end-pt
+ nil nil ; dummy ancestor
+ ;; state of diff
+ ;; shows which buff is different from the other two
+ (if (eq ediff-default-variant 'default-B) 'A 'B)
+ ediff-default-variant ; state of merge
+ nil ; state of ancestor
+ )
+ (vector a-begin-pt a-end-pt
+ b-begin-pt b-end-pt
+ nil nil ; dummy buf C
+ nil nil ; dummy ancestor
+ nil nil ; dummy state of diff & merge
+ nil ; dummy state of ancestor
+ )))
+ )))
+
+ ))) ; end ediff-with-current-buffer
+ diff-list
+ ))
+
+
+(defun ediff-convert-diffs-to-overlays (diff-list)
+ (ediff-set-diff-overlays-in-one-buffer 'A diff-list)
+ (ediff-set-diff-overlays-in-one-buffer 'B diff-list)
+ (if ediff-3way-job
+ (ediff-set-diff-overlays-in-one-buffer 'C diff-list))
+ (if ediff-merge-with-ancestor-job
+ (ediff-set-diff-overlays-in-one-buffer 'Ancestor diff-list))
+ ;; set up vector showing the status of merge regions
+ (if ediff-merge-job
+ (setq ediff-state-of-merge
+ (vconcat
+ (mapcar (lambda (elt)
+ (let ((state-of-merge (aref elt 9))
+ (state-of-ancestor (aref elt 10)))
+ (vector
+ ;; state of merge: prefers/default-A/B or combined
+ (if state-of-merge (format "%S" state-of-merge))
+ ;; whether the ancestor region is empty
+ state-of-ancestor)))
+ ;; the first elt designates type of list
+ (cdr diff-list))
+ )))
+ (message "Processing difference regions ... done"))
+
+
+(defun ediff-set-diff-overlays-in-one-buffer (buf-type diff-list)
+ (let* ((current-diff -1)
+ (buff (ediff-get-buffer buf-type))
+ (ctl-buf ediff-control-buffer)
+ ;; ediff-extract-diffs puts the type of diff-list as the first elt
+ ;; of this list. The type is either 'points or 'words
+ (diff-list-type (car diff-list))
+ (shift (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ buf-type ediff-narrow-bounds)))
+ (limit (ediff-overlay-end
+ (ediff-get-value-according-to-buffer-type
+ buf-type ediff-narrow-bounds)))
+ diff-overlay-list list-element total-diffs
+ begin end pt-saved overlay state-of-diff)
+
+ (setq diff-list (cdr diff-list)) ; discard diff list type
+ (setq total-diffs (length diff-list))
+
+ ;; shift, if necessary
+ (ediff-with-current-buffer buff (setq pt-saved shift))
+
+ (while diff-list
+ (setq current-diff (1+ current-diff)
+ list-element (car diff-list)
+ begin (aref list-element (cond ((eq buf-type 'A) 0)
+ ((eq buf-type 'B) 2)
+ ((eq buf-type 'C) 4)
+ (t 6))) ; Ancestor
+ end (aref list-element (cond ((eq buf-type 'A) 1)
+ ((eq buf-type 'B) 3)
+ ((eq buf-type 'C) 5)
+ (t 7))) ; Ancestor
+ state-of-diff (aref list-element 8)
+ )
+
+ (cond ((and (not (eq buf-type state-of-diff))
+ (not (eq buf-type 'Ancestor))
+ (memq state-of-diff '(A B C)))
+ (setq state-of-diff
+ (car (delq buf-type (delq state-of-diff (list 'A 'B 'C)))))
+ (setq state-of-diff (format "=diff(%S)" state-of-diff))
+ )
+ (t (setq state-of-diff nil)))
+
+ ;; Put overlays at appropriate places in buffer
+ ;; convert word numbers to points, if necessary
+ (if (eq diff-list-type 'words)
+ (progn
+ (ediff-with-current-buffer buff (goto-char pt-saved))
+ (ediff-with-current-buffer ctl-buf
+ (setq begin (ediff-goto-word (1+ begin) buff)
+ end (ediff-goto-word end buff 'end)))
+ (if (> end limit) (setq end limit))
+ (if (> begin end) (setq begin end))
+ (setq pt-saved (ediff-with-current-buffer buff (point)))))
+ (setq overlay (ediff-make-bullet-proof-overlay begin end buff))
+
+ (ediff-overlay-put overlay 'priority ediff-shadow-overlay-priority)
+ (ediff-overlay-put overlay 'ediff-diff-num current-diff)
+ (if (and (ediff-has-face-support-p)
+ ediff-use-faces ediff-highlight-all-diffs)
+ (ediff-set-overlay-face
+ overlay (ediff-background-face buf-type current-diff)))
+
+ (if (= 0 (mod current-diff 10))
+ (message "Buffer %S: Processing difference region %d of %d"
+ buf-type current-diff total-diffs))
+ ;; Record all overlays for this difference.
+ ;; The 2-d elt, nil, is a place holder for the fine diff vector.
+ ;; The 3-d elt, nil, is a place holder for no-fine-diffs flag.
+ ;; The 4-th elt says which diff region is different from the other two
+ ;; (3-way jobs only).
+ (setq diff-overlay-list
+ (nconc
+ diff-overlay-list
+ (list (vector overlay nil nil state-of-diff)))
+ diff-list
+ (cdr diff-list))
+ ) ; while
+
+ (set (ediff-get-symbol-from-alist buf-type ediff-difference-vector-alist)
+ (vconcat diff-overlay-list))
+ ))
+
+;; `n' is the diff region to work on. Default is ediff-current-difference.
+;; if `flag' is 'noforce then make fine-diffs only if this region's fine
+;; diffs have not been computed before.
+;; if `flag' is 'skip then don't compute fine diffs for this region.
+(defun ediff-make-fine-diffs (&optional n flag)
+ (or n (setq n ediff-current-difference))
+
+ (if (< ediff-number-of-differences 1)
+ (error ediff-NO-DIFFERENCES))
+
+ (if ediff-word-mode
+ (setq flag 'skip
+ ediff-auto-refine 'nix))
+
+ (or (< n 0)
+ (>= n ediff-number-of-differences)
+ ;; n is within the range
+ (let ((tmp-buffer (get-buffer-create ediff-tmp-buffer))
+ (file-A ediff-temp-file-A)
+ (file-B ediff-temp-file-B)
+ (file-C ediff-temp-file-C)
+ (empty-A (ediff-empty-diff-region-p n 'A))
+ (empty-B (ediff-empty-diff-region-p n 'B))
+ (empty-C (ediff-empty-diff-region-p n 'C))
+ (whitespace-A (ediff-whitespace-diff-region-p n 'A))
+ (whitespace-B (ediff-whitespace-diff-region-p n 'B))
+ (whitespace-C (ediff-whitespace-diff-region-p n 'C))
+ cumulative-fine-diff-length)
+
+ (cond ;; If one of the regions is empty (or 2 in 3way comparison)
+ ;; then don't refine.
+ ;; If the region happens to be entirely whitespace or empty then
+ ;; mark as such.
+ ((> (length (delq nil (list empty-A empty-B empty-C))) 1)
+ (if (and (ediff-looks-like-combined-merge n)
+ ediff-merge-job)
+ (ediff-set-fine-overlays-in-one-buffer 'C nil n))
+ (if ediff-3way-comparison-job
+ (ediff-message-if-verbose
+ "Region %d is empty in all buffers but %S"
+ (1+ n)
+ (cond ((not empty-A) 'A)
+ ((not empty-B) 'B)
+ ((not empty-C) 'C)))
+ (ediff-message-if-verbose
+ "Region %d in buffer %S is empty"
+ (1+ n)
+ (cond (empty-A 'A)
+ (empty-B 'B)
+ (empty-C 'C)))
+ )
+ ;; if all regions happen to be whitespace
+ (if (and whitespace-A whitespace-B whitespace-C)
+ ;; mark as space only
+ (ediff-mark-diff-as-space-only n t)
+ ;; if some regions are white and others don't, then mark as
+ ;; non-white-space-only
+ (ediff-mark-diff-as-space-only n nil)))
+
+ ;; don't compute fine diffs if diff vector exists
+ ((and (eq flag 'noforce) (ediff-get-fine-diff-vector n 'A))
+ (if (ediff-no-fine-diffs-p n)
+ (message
+ "Only white-space differences in region %d %s"
+ (1+ n)
+ (cond ((eq (ediff-no-fine-diffs-p n) 'A)
+ "in buffers B & C")
+ ((eq (ediff-no-fine-diffs-p n) 'B)
+ "in buffers A & C")
+ ((eq (ediff-no-fine-diffs-p n) 'C)
+ "in buffers A & B")
+ (t "")))))
+ ;; don't compute fine diffs for this region
+ ((eq flag 'skip)
+ (or (ediff-get-fine-diff-vector n 'A)
+ (memq ediff-auto-refine '(off nix))
+ (ediff-message-if-verbose
+ "Region %d exceeds the auto-refinement limit. Type `%s' to refine"
+ (1+ n)
+ (substitute-command-keys
+ "\\[ediff-make-or-kill-fine-diffs]")
+ )))
+ (t
+ ;; recompute fine diffs
+ (ediff-wordify
+ (ediff-get-diff-posn 'A 'beg n)
+ (ediff-get-diff-posn 'A 'end n)
+ ediff-buffer-A
+ tmp-buffer
+ ediff-control-buffer)
+ (setq file-A
+ (ediff-make-temp-file tmp-buffer "fineDiffA" file-A))
+
+ (ediff-wordify
+ (ediff-get-diff-posn 'B 'beg n)
+ (ediff-get-diff-posn 'B 'end n)
+ ediff-buffer-B
+ tmp-buffer
+ ediff-control-buffer)
+ (setq file-B
+ (ediff-make-temp-file tmp-buffer "fineDiffB" file-B))
+
+ (if ediff-3way-job
+ (progn
+ (ediff-wordify
+ (ediff-get-diff-posn 'C 'beg n)
+ (ediff-get-diff-posn 'C 'end n)
+ ediff-buffer-C
+ tmp-buffer
+ ediff-control-buffer)
+ (setq file-C
+ (ediff-make-temp-file
+ tmp-buffer "fineDiffC" file-C))))
+
+ ;; save temp file names.
+ (setq ediff-temp-file-A file-A
+ ediff-temp-file-B file-B
+ ediff-temp-file-C file-C)
+
+ ;; set the new vector of fine diffs, if none exists
+ (cond ((and ediff-3way-job whitespace-A)
+ (ediff-setup-fine-diff-regions nil file-B file-C n))
+ ((and ediff-3way-job whitespace-B)
+ (ediff-setup-fine-diff-regions file-A nil file-C n))
+ ((and ediff-3way-job
+ ;; In merge-jobs, whitespace-C is t, since
+ ;; ediff-empty-diff-region-p returns t in this case
+ whitespace-C)
+ (ediff-setup-fine-diff-regions file-A file-B nil n))
+ (t
+ (ediff-setup-fine-diff-regions file-A file-B file-C n)))
+
+ (setq cumulative-fine-diff-length
+ (+ (length (ediff-get-fine-diff-vector n 'A))
+ (length (ediff-get-fine-diff-vector n 'B))
+ ;; in merge jobs, the merge buffer is never refined
+ (if (and file-C (not ediff-merge-job))
+ (length (ediff-get-fine-diff-vector n 'C))
+ 0)))
+
+ (cond ((or
+ ;; all regions are white space
+ (and whitespace-A whitespace-B whitespace-C)
+ ;; none is white space and no fine diffs detected
+ (and (not whitespace-A)
+ (not whitespace-B)
+ (not (and ediff-3way-job whitespace-C))
+ (eq cumulative-fine-diff-length 0)))
+ (ediff-mark-diff-as-space-only n t)
+ (ediff-message-if-verbose
+ "Only white-space differences in region %d" (1+ n)))
+ ((eq cumulative-fine-diff-length 0)
+ (ediff-message-if-verbose
+ "Only white-space differences in region %d %s"
+ (1+ n)
+ (cond (whitespace-A (ediff-mark-diff-as-space-only n 'A)
+ "in buffers B & C")
+ (whitespace-B (ediff-mark-diff-as-space-only n 'B)
+ "in buffers A & C")
+ (whitespace-C (ediff-mark-diff-as-space-only n 'C)
+ "in buffers A & B"))))
+ (t
+ (ediff-mark-diff-as-space-only n nil)))
+ )
+ ) ; end cond
+ (ediff-set-fine-diff-properties n)
+ )))
+
+;; Interface to ediff-make-fine-diffs. Checks for auto-refine limit, etc.
+(defun ediff-install-fine-diff-if-necessary (n)
+ (cond ((and (eq ediff-auto-refine 'on)
+ ediff-use-faces
+ (not (eq ediff-highlighting-style 'off))
+ (not (eq ediff-highlighting-style 'ascii)))
+ (if (and
+ (> ediff-auto-refine-limit
+ (- (ediff-get-diff-posn 'A 'end n)
+ (ediff-get-diff-posn 'A 'beg n)))
+ (> ediff-auto-refine-limit
+ (- (ediff-get-diff-posn 'B 'end n)
+ (ediff-get-diff-posn 'B 'beg n))))
+ (ediff-make-fine-diffs n 'noforce)
+ (ediff-make-fine-diffs n 'skip)))
+
+ ;; highlight if fine diffs already exist
+ ((eq ediff-auto-refine 'off)
+ (ediff-make-fine-diffs n 'skip))))
+
+
+;; if fine diff vector is not set for diff N, then do nothing
+(defun ediff-set-fine-diff-properties (n &optional default)
+ (or (not (ediff-has-face-support-p))
+ (< n 0)
+ (>= n ediff-number-of-differences)
+ ;; when faces are supported, set faces and priorities of fine overlays
+ (progn
+ (ediff-set-fine-diff-properties-in-one-buffer 'A n default)
+ (ediff-set-fine-diff-properties-in-one-buffer 'B n default)
+ (if ediff-3way-job
+ (ediff-set-fine-diff-properties-in-one-buffer 'C n default)))))
+
+(defun ediff-set-fine-diff-properties-in-one-buffer (buf-type
+ n &optional default)
+ (let ((fine-diff-vector (ediff-get-fine-diff-vector n buf-type))
+ (face (if default
+ 'default
+ (ediff-get-symbol-from-alist
+ buf-type ediff-fine-diff-face-alist)
+ ))
+ (priority (if default
+ 0
+ (1+ (or (ediff-overlay-get
+ (symbol-value
+ (ediff-get-symbol-from-alist
+ buf-type
+ ediff-current-diff-overlay-alist))
+ 'priority)
+ 0)))))
+ (mapcar (lambda (overl)
+ (ediff-set-overlay-face overl face)
+ (ediff-overlay-put overl 'priority priority))
+ fine-diff-vector)))
+
+;; Set overlays over the regions that denote delimiters
+(defun ediff-set-fine-overlays-for-combined-merge (diff-list reg-num)
+ (let (overlay overlay-list)
+ (while diff-list
+ (condition-case nil
+ (setq overlay
+ (ediff-make-bullet-proof-overlay
+ (nth 0 diff-list) (nth 1 diff-list) ediff-buffer-C))
+ (error ""))
+ (setq overlay-list (cons overlay overlay-list))
+ (if (> (length diff-list) 1)
+ (setq diff-list (cdr (cdr diff-list)))
+ (error "ediff-set-fine-overlays-for-combined-merge: corrupt list of
+delimiter regions"))
+ )
+ (setq overlay-list (reverse overlay-list))
+ (ediff-set-fine-diff-vector
+ reg-num 'C (apply 'vector overlay-list))
+ ))
+
+
+;; Convert diff list to overlays for a given DIFF-REGION
+;; in buffer of type BUF-TYPE
+(defun ediff-set-fine-overlays-in-one-buffer (buf-type diff-list region-num)
+ (let* ((current-diff -1)
+ (reg-start (ediff-get-diff-posn buf-type 'beg region-num))
+ (buff (ediff-get-buffer buf-type))
+ (ctl-buf ediff-control-buffer)
+ combined-merge-diff-list
+ diff-overlay-list list-element
+ begin end overlay)
+
+ (ediff-clear-fine-differences-in-one-buffer region-num buf-type)
+ (setq diff-list (cdr diff-list)) ; discard list type (words or points)
+ (ediff-with-current-buffer buff (goto-char reg-start))
+
+ ;; if it is a combined merge then set overlays in buff C specially
+ (if (and ediff-merge-job (eq buf-type 'C)
+ (setq combined-merge-diff-list
+ (ediff-looks-like-combined-merge region-num)))
+ (ediff-set-fine-overlays-for-combined-merge
+ combined-merge-diff-list region-num)
+ ;; regular fine diff
+ (while diff-list
+ (setq current-diff (1+ current-diff)
+ list-element (car diff-list)
+ begin (aref list-element (cond ((eq buf-type 'A) 0)
+ ((eq buf-type 'B) 2)
+ (t 4))) ; buf C
+ end (aref list-element (cond ((eq buf-type 'A) 1)
+ ((eq buf-type 'B) 3)
+ (t 5)))) ; buf C
+ (if (not (or begin end))
+ () ; skip this diff
+ ;; Put overlays at appropriate places in buffers
+ ;; convert lines to points, if necessary
+ (ediff-with-current-buffer ctl-buf
+ (setq begin (ediff-goto-word (1+ begin) buff)
+ end (ediff-goto-word end buff 'end)))
+ (setq overlay (ediff-make-bullet-proof-overlay begin end buff))
+ ;; record all overlays for this difference region
+ (setq diff-overlay-list (nconc diff-overlay-list (list overlay))))
+
+ (setq diff-list (cdr diff-list))
+ ) ; while
+ ;; convert the list of difference information into a vector
+ ;; for fast access
+ (ediff-set-fine-diff-vector
+ region-num buf-type (vconcat diff-overlay-list))
+ )))
+
+
+(defun ediff-convert-fine-diffs-to-overlays (diff-list region-num)
+ (ediff-set-fine-overlays-in-one-buffer 'A diff-list region-num)
+ (ediff-set-fine-overlays-in-one-buffer 'B diff-list region-num)
+ (if ediff-3way-job
+ (ediff-set-fine-overlays-in-one-buffer 'C diff-list region-num)
+ ))
+
+
+;; Stolen from emerge.el
+(defun ediff-get-diff3-group (file)
+ ;; This save-excursion allows ediff-get-diff3-group to be called for the
+ ;; various groups of lines (1, 2, 3) in any order, and for the lines to
+ ;; appear in any order. The reason this is necessary is that Gnu diff3
+ ;; can produce the groups in the order 1, 2, 3 or 1, 3, 2.
+ (save-excursion
+ (re-search-forward
+ (concat "^" file ":\\([0-9]+\\)\\(,\\([0-9]+\\)\\)?\\([ac]\\)\C-m?$"))
+ (beginning-of-line 2)
+ ;; treatment depends on whether it is an "a" group or a "c" group
+ (if (string-equal (buffer-substring (match-beginning 4) (match-end 4)) "c")
+ ;; it is a "c" group
+ (if (match-beginning 2)
+ ;; it has two numbers
+ (list (string-to-number
+ (buffer-substring (match-beginning 1) (match-end 1)))
+ (1+ (string-to-number
+ (buffer-substring (match-beginning 3) (match-end 3)))))
+ ;; it has one number
+ (let ((x (string-to-number
+ (buffer-substring (match-beginning 1) (match-end 1)))))
+ (list x (1+ x))))
+ ;; it is an "a" group
+ (let ((x (1+ (string-to-number
+ (buffer-substring (match-beginning 1) (match-end 1))))))
+ (list x x)))))
+
+
+;; If WORD-MODE, construct vector of diffs using word numbers.
+;; Else, use point values.
+;; WORD-MODE also tells if we are in the word-mode or not.
+;; If THREE-WAY-COMP, then it is a 3-way comparison. Else, it is merging
+;; with ancestor, in which case buffer-C contents is identical to buffer-A/B,
+;; contents (unless buffer-A is narrowed) depending on ediff-default-variant's
+;; value.
+;; BOUNDS specifies visibility bounds to use.
+(defun ediff-extract-diffs3 (diff-buffer word-mode three-way-comp
+ &optional bounds)
+ (let ((A-buffer ediff-buffer-A)
+ (B-buffer ediff-buffer-B)
+ (C-buffer ediff-buffer-C)
+ (anc-buffer ediff-ancestor-buffer)
+ (a-prev 1) ; needed to set the first diff line correctly
+ (a-prev-pt nil)
+ (b-prev 1)
+ (b-prev-pt nil)
+ (c-prev 1)
+ (c-prev-pt nil)
+ (anc-prev 1)
+ diff-list shift-A shift-B shift-C
+ )
+
+ ;; diff list contains word numbers or points, depending on word-mode
+ (setq diff-list (cons (if word-mode 'words 'points)
+ diff-list))
+ (if bounds
+ (setq shift-A
+ (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type 'A bounds))
+ shift-B
+ (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type 'B bounds))
+ shift-C
+ (if three-way-comp
+ (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type 'C bounds)))))
+
+ ;; reset point in buffers A, B, C
+ (ediff-with-current-buffer A-buffer
+ (goto-char (if shift-A shift-A (point-min))))
+ (ediff-with-current-buffer B-buffer
+ (goto-char (if shift-B shift-B (point-min))))
+ (if three-way-comp
+ (ediff-with-current-buffer C-buffer
+ (goto-char (if shift-C shift-C (point-min)))))
+ (if (ediff-buffer-live-p anc-buffer)
+ (ediff-with-current-buffer anc-buffer
+ (goto-char (point-min))))
+
+ (ediff-with-current-buffer diff-buffer
+ (goto-char (point-min))
+ (while (re-search-forward ediff-match-diff3-line nil t)
+ ;; leave point after matched line
+ (beginning-of-line 2)
+ (let ((agreement (buffer-substring (match-beginning 1) (match-end 1))))
+ ;; if the files A and B are the same and not 3way-comparison,
+ ;; ignore the difference
+ (if (or three-way-comp (not (string-equal agreement "3")))
+ (let* ((a-begin (car (ediff-get-diff3-group "1")))
+ (a-end (nth 1 (ediff-get-diff3-group "1")))
+ (b-begin (car (ediff-get-diff3-group "2")))
+ (b-end (nth 1 (ediff-get-diff3-group "2")))
+ (c-or-anc-begin (car (ediff-get-diff3-group "3")))
+ (c-or-anc-end (nth 1 (ediff-get-diff3-group "3")))
+ (state-of-merge
+ (cond ((string-equal agreement "1") 'prefer-A)
+ ((string-equal agreement "2") 'prefer-B)
+ (t ediff-default-variant)))
+ (state-of-diff-merge
+ (if (memq state-of-merge '(default-A prefer-A)) 'B 'A))
+ (state-of-diff-comparison
+ (cond ((string-equal agreement "1") 'A)
+ ((string-equal agreement "2") 'B)
+ ((string-equal agreement "3") 'C)))
+ state-of-ancestor
+ c-begin c-end
+ a-begin-pt a-end-pt
+ b-begin-pt b-end-pt
+ c-begin-pt c-end-pt
+ anc-begin-pt anc-end-pt)
+
+ (setq state-of-ancestor
+ (= c-or-anc-begin c-or-anc-end))
+
+ (cond (three-way-comp
+ (setq c-begin c-or-anc-begin
+ c-end c-or-anc-end))
+ ((eq ediff-default-variant 'default-B)
+ (setq c-begin b-begin
+ c-end b-end))
+ (t
+ (setq c-begin a-begin
+ c-end a-end)))
+
+ ;; compute main diff vector
+ (if word-mode
+ ;; make diff-list contain word numbers
+ (setq diff-list
+ (nconc diff-list
+ (list (vector
+ (- a-begin a-prev) (- a-end a-begin)
+ (- b-begin b-prev) (- b-end b-begin)
+ (- c-begin c-prev) (- c-end c-begin)
+ nil nil ; dummy ancestor
+ nil ; state of diff
+ nil ; state of merge
+ nil ; state of ancestor
+ )))
+ a-prev a-end
+ b-prev b-end
+ c-prev c-end)
+ ;; else convert lines to points
+ (ediff-with-current-buffer A-buffer
+ (let ((longlines-mode-val
+ (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
+ ;; we must disable and then restore longlines-mode
+ (if (eq longlines-mode-val 1)
+ (longlines-mode 0))
+ (goto-char (or a-prev-pt shift-A (point-min)))
+ (forward-line (- a-begin a-prev))
+ (setq a-begin-pt (point))
+ (forward-line (- a-end a-begin))
+ (setq a-end-pt (point)
+ a-prev a-end
+ a-prev-pt a-end-pt)
+ (if (eq longlines-mode-val 1)
+ (longlines-mode longlines-mode-val))
+ ))
+ (ediff-with-current-buffer B-buffer
+ (let ((longlines-mode-val
+ (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
+ (if (eq longlines-mode-val 1)
+ (longlines-mode 0))
+ (goto-char (or b-prev-pt shift-B (point-min)))
+ (forward-line (- b-begin b-prev))
+ (setq b-begin-pt (point))
+ (forward-line (- b-end b-begin))
+ (setq b-end-pt (point)
+ b-prev b-end
+ b-prev-pt b-end-pt)
+ (if (eq longlines-mode-val 1)
+ (longlines-mode longlines-mode-val))
+ ))
+ (ediff-with-current-buffer C-buffer
+ (let ((longlines-mode-val
+ (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
+ (if (eq longlines-mode-val 1)
+ (longlines-mode 0))
+ (goto-char (or c-prev-pt shift-C (point-min)))
+ (forward-line (- c-begin c-prev))
+ (setq c-begin-pt (point))
+ (forward-line (- c-end c-begin))
+ (setq c-end-pt (point)
+ c-prev c-end
+ c-prev-pt c-end-pt)
+ (if (eq longlines-mode-val 1)
+ (longlines-mode longlines-mode-val))
+ ))
+ (if (ediff-buffer-live-p anc-buffer)
+ (ediff-with-current-buffer anc-buffer
+ (let ((longlines-mode-val
+ (if (and (boundp 'longlines-mode) longlines-mode) 1 0)))
+ (if (eq longlines-mode-val 1)
+ (longlines-mode 0))
+ (forward-line (- c-or-anc-begin anc-prev))
+ (setq anc-begin-pt (point))
+ (forward-line (- c-or-anc-end c-or-anc-begin))
+ (setq anc-end-pt (point)
+ anc-prev c-or-anc-end)
+ (if (eq longlines-mode-val 1)
+ (longlines-mode longlines-mode-val))
+ )))
+ (setq diff-list
+ (nconc
+ diff-list
+ ;; if comparing with ancestor, then there also is a
+ ;; state-of-difference marker
+ (if three-way-comp
+ (list (vector
+ a-begin-pt a-end-pt
+ b-begin-pt b-end-pt
+ c-begin-pt c-end-pt
+ nil nil ; ancestor begin/end
+ state-of-diff-comparison
+ nil ; state of merge
+ nil ; state of ancestor
+ ))
+ (list (vector a-begin-pt a-end-pt
+ b-begin-pt b-end-pt
+ c-begin-pt c-end-pt
+ anc-begin-pt anc-end-pt
+ state-of-diff-merge
+ state-of-merge
+ state-of-ancestor
+ )))
+ )))
+ ))
+
+ ))) ; end ediff-with-current-buffer
+ diff-list
+ ))
+
+;; Generate the difference vector and overlays for three files
+;; File-C is either the third file to compare (in case of 3-way comparison)
+;; or it is the ancestor file.
+(defun ediff-setup-diff-regions3 (file-A file-B file-C)
+ ;; looking for '-i' or a 'i' among clustered non-long options
+ (if (string-match "^-i\\| -i\\|\\(^\\| \\)-[^- ]+i" ediff-diff-options)
+ (error "Option `-i' is not allowed in `ediff-diff3-options'"))
+
+ (or (ediff-buffer-live-p ediff-diff-buffer)
+ (setq ediff-diff-buffer
+ (get-buffer-create (ediff-unique-buffer-name "*ediff-diff" "*"))))
+
+ (message "Computing differences ...")
+ (ediff-exec-process ediff-diff3-program ediff-diff-buffer 'synchronize
+ ediff-actual-diff3-options file-A file-B file-C)
+
+ (ediff-prepare-error-list ediff-diff3-ok-lines-regexp ediff-diff-buffer)
+ ;;(message "Computing differences ... done")
+ (ediff-convert-diffs-to-overlays
+ (ediff-extract-diffs3
+ ediff-diff-buffer
+ ediff-word-mode ediff-3way-comparison-job ediff-narrow-bounds)
+ ))
+
+
+;; Execute PROGRAM asynchronously, unless OS/2, Windows-*, or DOS, or unless
+;; SYNCH is non-nil. BUFFER must be a buffer object, and must be alive. The
+;; OPTIONS arg is a list of options to pass to PROGRAM. It may be a blank
+;; string. All elements in FILES must be strings. We also delete nil from
+;; args.
+(defun ediff-exec-process (program buffer synch options &rest files)
+ (let ((data (match-data))
+ ;; If this is a buffer job, we are diffing temporary files
+ ;; produced by Emacs with ediff-coding-system-for-write, so
+ ;; use the same encoding to read the results.
+ (coding-system-for-read
+ (if (string-match "buffer" (symbol-name ediff-job-name))
+ ediff-coding-system-for-write
+ ediff-coding-system-for-read))
+ args)
+ (setq args (append (split-string options) files))
+ (setq args (delete "" (delq nil args))) ; delete nil and "" from arguments
+ ;; the --binary option, if present, should be used only for buffer jobs
+ ;; or for refining the differences
+ (or (string-match "buffer" (symbol-name ediff-job-name))
+ (eq buffer ediff-fine-diff-buffer)
+ (setq args (delete "--binary" args)))
+ (unwind-protect
+ (let ((directory default-directory)
+ proc)
+ (with-current-buffer buffer
+ (erase-buffer)
+ (setq default-directory directory)
+ (if (or (memq system-type '(emx ms-dos windows-nt windows-95))
+ synch)
+ ;; In OS/2 (emx) do it synchronously, since OS/2 doesn't let us
+ ;; delete files used by other processes. Thus, in ediff-buffers
+ ;; and similar functions, we can't delete temp files because
+ ;; they might be used by the asynch process that computes
+ ;; custom diffs. So, we have to wait till custom diff
+ ;; subprocess is done.
+ ;; Similarly for Windows-*
+ ;; In DOS, must synchronize because DOS doesn't have
+ ;; asynchronous processes.
+ (apply 'call-process program nil buffer nil args)
+ ;; On other systems, do it asynchronously.
+ (setq proc (get-buffer-process buffer))
+ (if proc (kill-process proc))
+ (setq proc
+ (apply 'start-process "Custom Diff" buffer program args))
+ (setq mode-line-process '(":%s"))
+ (set-process-sentinel proc 'ediff-process-sentinel)
+ (set-process-filter proc 'ediff-process-filter)
+ )))
+ (store-match-data data))))
+
+;; This is shell-command-filter from simple.el in Emacs.
+;; Copied here because XEmacs doesn't have it.
+(defun ediff-process-filter (proc string)
+ ;; Do save-excursion by hand so that we can leave point numerically unchanged
+ ;; despite an insertion immediately after it.
+ (let* ((obuf (current-buffer))
+ (buffer (process-buffer proc))
+ opoint
+ (window (get-buffer-window buffer))
+ (pos (window-start window)))
+ (unwind-protect
+ (progn
+ (set-buffer buffer)
+ (or (= (point) (point-max))
+ (setq opoint (point)))
+ (goto-char (point-max))
+ (insert-before-markers string))
+ ;; insert-before-markers moved this marker: set it back.
+ (set-window-start window pos)
+ ;; Finish our save-excursion.
+ (if opoint
+ (goto-char opoint))
+ (set-buffer obuf))))
+
+;; like shell-command-sentinel but doesn't print an exit status message
+;; we do this because diff always exits with status 1, if diffs are found
+;; so shell-command-sentinel displays a confusing message to the user
+(defun ediff-process-sentinel (process signal)
+ (if (and (memq (process-status process) '(exit signal))
+ (buffer-name (process-buffer process)))
+ (progn
+ (with-current-buffer (process-buffer process)
+ (setq mode-line-process nil))
+ (delete-process process))))
+
+
+;;; Word functions used to refine the current diff
+
+(defvar ediff-forward-word-function 'ediff-forward-word
+ "*Function to call to move to the next word.
+Used for splitting difference regions into individual words.")
+(make-variable-buffer-local 'ediff-forward-word-function)
+
+;; \240 is unicode symbol for nonbreakable whitespace
+(defvar ediff-whitespace " \n\t\f\r\240"
+ "*Characters constituting white space.
+These characters are ignored when differing regions are split into words.")
+(make-variable-buffer-local 'ediff-whitespace)
+
+(defvar ediff-word-1
+ (if (featurep 'xemacs) "a-zA-Z---_" "-[:word:]_")
+ "*Characters that constitute words of type 1.
+More precisely, [ediff-word-1] is a regexp that matches type 1 words.
+See `ediff-forward-word' for more details.")
+(make-variable-buffer-local 'ediff-word-1)
+
+(defvar ediff-word-2 "0-9.,"
+ "*Characters that constitute words of type 2.
+More precisely, [ediff-word-2] is a regexp that matches type 2 words.
+See `ediff-forward-word' for more details.")
+(make-variable-buffer-local 'ediff-word-2)
+
+(defvar ediff-word-3 "`'?!:;\"{}[]()"
+ "*Characters that constitute words of type 3.
+More precisely, [ediff-word-3] is a regexp that matches type 3 words.
+See `ediff-forward-word' for more details.")
+(make-variable-buffer-local 'ediff-word-3)
+
+(defvar ediff-word-4
+ (concat "^" ediff-word-1 ediff-word-2 ediff-word-3 ediff-whitespace)
+ "*Characters that constitute words of type 4.
+More precisely, [ediff-word-4] is a regexp that matches type 4 words.
+See `ediff-forward-word' for more details.")
+(make-variable-buffer-local 'ediff-word-4)
+
+;; Split region along word boundaries. Each word will be on its own line.
+;; Output to buffer out-buffer.
+(defun ediff-forward-word ()
+ "Move point one word forward.
+There are four types of words, each of which consists entirely of
+characters in `ediff-word-1', `ediff-word-2', `ediff-word-3', or
+`ediff-word-4'. Words are recognized by passing these one after another as
+arguments to `skip-chars-forward'."
+ (or (> (+ (skip-chars-forward ediff-word-1)
+ (skip-syntax-forward "w"))
+ 0)
+ (> (skip-chars-forward ediff-word-2) 0)
+ (> (skip-chars-forward ediff-word-3) 0)
+ (> (skip-chars-forward ediff-word-4) 0)
+ ))
+
+
+(defun ediff-wordify (beg end in-buffer out-buffer &optional control-buf)
+ (let ((forward-word-function
+ ;; eval in control buf to let user create local versions for
+ ;; different invocations
+ (if control-buf
+ (ediff-with-current-buffer control-buf
+ ediff-forward-word-function)
+ ediff-forward-word-function))
+ inbuf-syntax-tbl sv-point diff-string)
+ (with-current-buffer in-buffer
+ (setq inbuf-syntax-tbl
+ (if control-buf
+ (ediff-with-current-buffer control-buf
+ ediff-syntax-table)
+ (syntax-table)))
+ (setq diff-string (buffer-substring-no-properties beg end))
+
+ (set-buffer out-buffer)
+ ;; Make sure that temp buff syntax table is the same as the original buf
+ ;; syntax tbl, because we use ediff-forward-word in both and
+ ;; ediff-forward-word depends on the syntax classes of characters.
+ (set-syntax-table inbuf-syntax-tbl)
+ (erase-buffer)
+ (insert diff-string)
+ (goto-char (point-min))
+ (skip-chars-forward ediff-whitespace)
+ (delete-region (point-min) (point))
+
+ (while (not (eobp))
+ (funcall forward-word-function)
+ (setq sv-point (point))
+ (skip-chars-forward ediff-whitespace)
+ (delete-region sv-point (point))
+ (insert "\n")))))
+
+;; copy string specified as BEG END from IN-BUF to OUT-BUF
+(defun ediff-copy-to-buffer (beg end in-buffer out-buffer)
+ (with-current-buffer out-buffer
+ (erase-buffer)
+ (insert-buffer-substring in-buffer beg end)
+ (goto-char (point-min))))
+
+
+;; goto word #n starting at current position in buffer `buf'
+;; For ediff, a word is determined by ediff-forward-word-function
+;; If `flag' is non-nil, goto the end of the n-th word.
+(defun ediff-goto-word (n buf &optional flag)
+ ;; remember val ediff-forward-word-function has in ctl buf
+ (let ((fwd-word-fun ediff-forward-word-function)
+ (syntax-tbl ediff-syntax-table))
+ (ediff-with-current-buffer buf
+ (skip-chars-forward ediff-whitespace)
+ (ediff-with-syntax-table syntax-tbl
+ (while (> n 1)
+ (funcall fwd-word-fun)
+ (skip-chars-forward ediff-whitespace)
+ (setq n (1- n)))
+ (if (and flag (> n 0))
+ (funcall fwd-word-fun)))
+ (point))))
+
+(defun ediff-same-file-contents (f1 f2)
+ "Return t if files F1 and F2 have identical contents."
+ (if (and (not (file-directory-p f1))
+ (not (file-directory-p f2)))
+ (let ((res
+ (apply 'call-process ediff-cmp-program nil nil nil
+ (append ediff-cmp-options (list (expand-file-name f1)
+ (expand-file-name f2))))
+ ))
+ (and (numberp res) (eq res 0)))
+ ))
+
+
+(defun ediff-same-contents (d1 d2 &optional filter-re)
+ "Return t if D1 and D2 have the same content.
+D1 and D2 can either be both directories or both regular files.
+Symlinks and the likes are not handled.
+If FILTER-RE is non-nil, recursive checking in directories
+affects only files whose names match the expression."
+ ;; Normalize empty filter RE to nil.
+ (unless (> (length filter-re) 0) (setq filter-re nil))
+ ;; Indicate progress
+ (message "Comparing '%s' and '%s' modulo '%s'" d1 d2 filter-re)
+ (cond
+ ;; D1 & D2 directories => recurse
+ ((and (file-directory-p d1)
+ (file-directory-p d2))
+ (if (null ediff-recurse-to-subdirectories)
+ (if (y-or-n-p "Compare subdirectories recursively? ")
+ (setq ediff-recurse-to-subdirectories 'yes)
+ (setq ediff-recurse-to-subdirectories 'no)))
+ (if (eq ediff-recurse-to-subdirectories 'yes)
+ (let* ((all-entries-1 (directory-files d1 t filter-re))
+ (all-entries-2 (directory-files d2 t filter-re))
+ (entries-1 (ediff-delete-all-matches "^\\.\\.?$" all-entries-1))
+ (entries-2 (ediff-delete-all-matches "^\\.\\.?$" all-entries-2))
+ )
+
+ (ediff-same-file-contents-lists entries-1 entries-2 filter-re)
+ ))
+ ) ; end of the directories case
+ ;; D1 & D2 are both files => compare directly
+ ((and (file-regular-p d1)
+ (file-regular-p d2))
+ (ediff-same-file-contents d1 d2))
+ ;; Otherwise => false: unequal contents
+ )
+ )
+
+;; If lists have the same length and names of files are pairwise equal
+;; (removing the directories) then compare contents pairwise.
+;; True if all contents are the same; false otherwise
+(defun ediff-same-file-contents-lists (entries-1 entries-2 filter-re)
+ ;; First, check only the names (works quickly and ensures a
+ ;; precondition for subsequent code)
+ (if (and (= (length entries-1) (length entries-2))
+ (equal (mapcar 'file-name-nondirectory entries-1)
+ (mapcar 'file-name-nondirectory entries-2)))
+ ;; With name equality established, compare the entries
+ ;; through recursion.
+ (let ((continue t))
+ (while (and entries-1 continue)
+ (if (ediff-same-contents
+ (car entries-1) (car entries-2) filter-re)
+ (setq entries-1 (cdr entries-1)
+ entries-2 (cdr entries-2))
+ (setq continue nil))
+ )
+ ;; if reached the end then lists are equal
+ (null entries-1))
+ )
+ )
+
+
+;; ARG1 is a regexp, ARG2 is a list of full-filenames
+;; Delete all entries that match the regexp
+(defun ediff-delete-all-matches (regex file-list-list)
+ (let (result elt)
+ (while file-list-list
+ (setq elt (car file-list-list))
+ (or (string-match regex (file-name-nondirectory elt))
+ (setq result (cons elt result)))
+ (setq file-list-list (cdr file-list-list)))
+ (reverse result)))
+
+
+(defun ediff-set-actual-diff-options ()
+ (if ediff-ignore-case
+ (setq ediff-actual-diff-options
+ (concat ediff-diff-options " " ediff-ignore-case-option)
+ ediff-actual-diff3-options
+ (concat ediff-diff3-options " " ediff-ignore-case-option3))
+ (setq ediff-actual-diff-options ediff-diff-options
+ ediff-actual-diff3-options ediff-diff3-options)
+ )
+ (setq-default ediff-actual-diff-options ediff-actual-diff-options
+ ediff-actual-diff3-options ediff-actual-diff3-options)
+ )
+
+
+;; Ignore case handling - some ideas from drew.adams@@oracle.com
+(defun ediff-toggle-ignore-case ()
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (setq ediff-ignore-case (not ediff-ignore-case))
+ (ediff-set-actual-diff-options)
+ (if ediff-ignore-case
+ (message "Ignoring regions that differ only in case")
+ (message "Ignoring case differences turned OFF"))
+ (cond (ediff-merge-job
+ (message "Ignoring letter case is too dangerous in merge jobs"))
+ ((and ediff-diff3-job (string= ediff-ignore-case-option3 ""))
+ (message "Ignoring letter case is not supported by this diff3 program"))
+ ((and (not ediff-3way-job) (string= ediff-ignore-case-option ""))
+ (message "Ignoring letter case is not supported by this diff program"))
+ (t
+ (sit-for 1)
+ (ediff-update-diffs)))
+ )
+
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: a86d448e-58d7-4572-a1d9-fdedfa22f648
+;;; ediff-diff.el ends here
--- /dev/null
+;;; ediff-help.el --- Code related to the contents of Ediff help buffers
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+;; Compiler pacifier start
+(defvar ediff-multiframe)
+;; end pacifier
+
+(require 'ediff-init)
+
+;; Help messages
+
+(defconst ediff-long-help-message-head
+ " Move around | Toggle features | Manipulate
+=====================|===========================|============================="
+ "The head of the full help message.")
+(defconst ediff-long-help-message-tail
+ "=====================|===========================|=============================
+ R -show registry | = -compare regions | M -show session group
+ D -diff output | E -browse Ediff manual| G -send bug report
+ i -status info | ? -help off | z/q -suspend/quit
+-------------------------------------------------------------------------------
+For help on a specific command: Click Button 2 over it; or
+ Put the cursor over it and type RET."
+ "The tail of the full-help message.")
+
+(defconst ediff-long-help-message-compare3
+ "
+p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y
+n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
+ j -jump to diff | @ -auto-refinement | * -refine current region
+ gx -goto X's point| ## -ignore whitespace | ! -update diff regions
+ C-l -recenter | #c -ignore case |
+ v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
+ </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
+ ~ -rotate buffers| m -wide display |
+"
+ "Help message usually used for 3-way comparison.
+Normally, not a user option. See `ediff-help-message' for details.")
+
+(defconst ediff-long-help-message-compare2
+ "
+p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A
+n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
+ j -jump to diff | @ -auto-refinement | * -refine current region
+ gx -goto X's point| ## -ignore whitespace | ! -update diff regions
+ C-l -recenter | #c -ignore case |
+ v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
+ </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
+ ~ -swap variants | m -wide display |
+"
+ "Help message usually used for 2-way comparison.
+Normally, not a user option. See `ediff-help-message' for details.")
+
+(defconst ediff-long-help-message-narrow2
+ "
+p,DEL -previous diff | | -vert/horiz split |a/b -copy A/B's region to B/A
+n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
+ j -jump to diff | @ -auto-refinement | * -refine current region
+ gx -goto X's point| ## -ignore whitespace | ! -update diff regions
+ C-l -recenter | #c -ignore case | % -narrow/widen buffs
+ v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
+ </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
+ ~ -swap variants | m -wide display |
+"
+ "Help message when comparing windows or regions line-by-line.
+Normally, not a user option. See `ediff-help-message' for details.")
+
+(defconst ediff-long-help-message-word-mode
+ "
+p,DEL -previous diff | | -vert/horiz split | xy -copy buf X's region to Y
+n,SPC -next diff | h -hilighting | rx -restore buf X's old diff
+ j -jump to diff | |
+ gx -goto X's point| % -narrow/widen buffs | ! -recompute diffs
+ C-l -recenter | #c -ignore case |
+ v/V -scroll up/dn | #f/#h -focus/hide regions | wx -save buf X
+ </> -scroll lt/rt | X -read-only in buf X | wd -save diff output
+ ~ -swap variants | m -wide display |
+"
+ "Help message when comparing windows or regions word-by-word.
+Normally, not a user option. See `ediff-help-message' for details.")
+
+(defconst ediff-long-help-message-merge
+ "
+p,DEL -previous diff | | -vert/horiz split | x -copy buf X's region to C
+n,SPC -next diff | h -hilighting | r -restore buf C's old diff
+ j -jump to diff | @ -auto-refinement | * -refine current region
+ gx -goto X's point| ## -ignore whitespace | ! -update diff regions
+ C-l -recenter | #f/#h -focus/hide regions | + -combine diff regions
+ v/V -scroll up/dn | X -read-only in buf X | wx -save buf X
+ </> -scroll lt/rt | m -wide display | wd -save diff output
+ ~ -swap variants | s -shrink window C | / -show ancestor buff
+ | $$ -show clashes only | & -merge w/new default
+ | $* -skip changed regions |
+"
+ "Help message for merge sessions.
+Normally, not a user option. See `ediff-help-message' for details.")
+
+;; The actual long help message.
+(ediff-defvar-local ediff-long-help-message ""
+ "Normally, not a user option. See `ediff-help-message' for details.")
+
+(defconst ediff-brief-message-string
+ " Type ? for help"
+ "Contents of the brief help message.")
+;; The actual brief help message
+(ediff-defvar-local ediff-brief-help-message ""
+ "Normally, not a user option. See `ediff-help-message' for details.")
+
+(ediff-defvar-local ediff-brief-help-message-function nil
+ "The brief help message that the user can customize.
+If the user sets this to a parameter-less function, Ediff will use it to
+produce the brief help message. This function must return a string.")
+(ediff-defvar-local ediff-long-help-message-function nil
+ "The long help message that the user can customize.
+See `ediff-brief-help-message-function' for more.")
+
+(defcustom ediff-use-long-help-message nil
+ "If t, Ediff displays a long help message. Short help message otherwise."
+ :type 'boolean
+ :group 'ediff-window)
+
+;; The actual help message.
+(ediff-defvar-local ediff-help-message ""
+ "The actual help message.
+Normally, the user shouldn't touch this. However, if you want Ediff to
+start up with different help messages for different jobs, you can change
+the value of this variable and the variables `ediff-help-message-*' in
+`ediff-startup-hook'.")
+
+
+;; the keymap that defines clicks over the quick help regions
+(defvar ediff-help-region-map (make-sparse-keymap))
+
+(define-key
+ ediff-help-region-map
+ (if (featurep 'emacs) [mouse-2] [button2])
+ 'ediff-help-for-quick-help)
+
+;; runs in the control buffer
+(defun ediff-set-help-overlays ()
+ (goto-char (point-min))
+ (let (overl beg end cmd)
+ (while (re-search-forward " *\\([^ \t\n|]+\\||\\) +-[^|\n]+" nil 'noerror)
+ (setq beg (match-beginning 0)
+ end (match-end 0)
+ cmd (buffer-substring (match-beginning 1) (match-end 1)))
+ (setq overl (ediff-make-overlay beg end))
+ (if (featurep 'emacs)
+ (ediff-overlay-put overl 'mouse-face 'highlight)
+ (ediff-overlay-put overl 'highlight t))
+ (ediff-overlay-put overl 'ediff-help-info cmd))))
+
+
+(defun ediff-help-for-quick-help ()
+ "Explain Ediff commands in more detail."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (let ((pos (ediff-event-point last-command-event))
+ overl cmd)
+
+ (if (featurep 'xemacs)
+ (setq overl (extent-at pos (current-buffer) 'ediff-help-info)
+ cmd (ediff-overlay-get overl 'ediff-help-info))
+ (setq cmd (car (mapcar (lambda (elt)
+ (overlay-get elt 'ediff-help-info))
+ (overlays-at pos)))))
+
+ (if (not (stringp cmd))
+ (error "Hmm... I don't see an Ediff command around here..."))
+
+ (ediff-documentation "Quick Help Commands")
+
+ (let (case-fold-search)
+ (cond ((string= cmd "?") (re-search-forward "^`\\?'"))
+ ((string= cmd "G") (re-search-forward "^`G'"))
+ ((string= cmd "E") (re-search-forward "^`E'"))
+ ((string= cmd "wd") (re-search-forward "^`wd'"))
+ ((string= cmd "wx") (re-search-forward "^`wa'"))
+ ((string= cmd "a/b") (re-search-forward "^`a'"))
+ ((string= cmd "x") (re-search-forward "^`a'"))
+ ((string= cmd "xy") (re-search-forward "^`ab'"))
+ ((string= cmd "p,DEL") (re-search-forward "^`p'"))
+ ((string= cmd "n,SPC") (re-search-forward "^`n'"))
+ ((string= cmd "j") (re-search-forward "^`j'"))
+ ((string= cmd "gx") (re-search-forward "^`ga'"))
+ ((string= cmd "!") (re-search-forward "^`!'"))
+ ((string= cmd "*") (re-search-forward "^`\\*'"))
+ ((string= cmd "m") (re-search-forward "^`m'"))
+ ((string= cmd "|") (re-search-forward "^`|'"))
+ ((string= cmd "@") (re-search-forward "^`@'"))
+ ((string= cmd "h") (re-search-forward "^`h'"))
+ ((string= cmd "r") (re-search-forward "^`r'"))
+ ((string= cmd "rx") (re-search-forward "^`ra'"))
+ ((string= cmd "##") (re-search-forward "^`##'"))
+ ((string= cmd "#c") (re-search-forward "^`#c'"))
+ ((string= cmd "#f/#h") (re-search-forward "^`#f'"))
+ ((string= cmd "X") (re-search-forward "^`A'"))
+ ((string= cmd "v/V") (re-search-forward "^`v'"))
+ ((string= cmd "</>") (re-search-forward "^`<'"))
+ ((string= cmd "~") (re-search-forward "^`~'"))
+ ((string= cmd "i") (re-search-forward "^`i'"))
+ ((string= cmd "D") (re-search-forward "^`D'"))
+ ((string= cmd "R") (re-search-forward "^`R'"))
+ ((string= cmd "M") (re-search-forward "^`M'"))
+ ((string= cmd "z/q") (re-search-forward "^`z'"))
+ ((string= cmd "%") (re-search-forward "^`%'"))
+ ((string= cmd "C-l") (re-search-forward "^`C-l'"))
+ ((string= cmd "$$") (re-search-forward "^`\\$\\$'"))
+ ((string= cmd "$*") (re-search-forward "^`\\$\\*'"))
+ ((string= cmd "/") (re-search-forward "^`/'"))
+ ((string= cmd "&") (re-search-forward "^`&'"))
+ ((string= cmd "s") (re-search-forward "^`s'"))
+ ((string= cmd "+") (re-search-forward "^`\\+'"))
+ ((string= cmd "=") (re-search-forward "^`='"))
+ (t (error "Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer")))
+ ) ; let case-fold-search
+ ))
+
+
+;; assuming we are in control window, calculate length of the first line in
+;; help message
+(defun ediff-help-message-line-length ()
+ (save-excursion
+ (goto-char (point-min))
+ (if ediff-use-long-help-message
+ (forward-line 1))
+ (end-of-line)
+ (current-column)))
+
+
+(defun ediff-indent-help-message ()
+ (let* ((shift (/ (max 0 (- (window-width (selected-window))
+ (ediff-help-message-line-length)))
+ 2))
+ (str (make-string shift ?\ )))
+ (save-excursion
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (insert str)
+ (beginning-of-line)
+ (forward-line 1)))))
+
+
+;; compose the help message as a string
+(defun ediff-set-help-message ()
+ (setq ediff-long-help-message
+ (cond ((and ediff-long-help-message-function
+ (or (symbolp ediff-long-help-message-function)
+ (consp ediff-long-help-message-function)))
+ (funcall ediff-long-help-message-function))
+ (ediff-word-mode
+ (concat ediff-long-help-message-head
+ ediff-long-help-message-word-mode
+ ediff-long-help-message-tail))
+ (ediff-narrow-job
+ (concat ediff-long-help-message-head
+ ediff-long-help-message-narrow2
+ ediff-long-help-message-tail))
+ (ediff-merge-job
+ (concat ediff-long-help-message-head
+ ediff-long-help-message-merge
+ ediff-long-help-message-tail))
+ (ediff-diff3-job
+ (concat ediff-long-help-message-head
+ ediff-long-help-message-compare3
+ ediff-long-help-message-tail))
+ (t
+ (concat ediff-long-help-message-head
+ ediff-long-help-message-compare2
+ ediff-long-help-message-tail))))
+ (setq ediff-brief-help-message
+ (cond ((and ediff-brief-help-message-function
+ (or (symbolp ediff-brief-help-message-function)
+ (consp ediff-brief-help-message-function)))
+ (funcall ediff-brief-help-message-function))
+ ((stringp ediff-brief-help-message-function)
+ ediff-brief-help-message-function)
+ ((ediff-multiframe-setup-p) ediff-brief-message-string)
+ (t ; long brief msg, not multiframe --- put in the middle
+ ediff-brief-message-string)
+ ))
+ (setq ediff-help-message (if ediff-use-long-help-message
+ ediff-long-help-message
+ ediff-brief-help-message))
+ (run-hooks 'ediff-display-help-hook))
+
+;;;###autoload
+(defun ediff-customize ()
+ (interactive)
+ (customize-group "ediff"))
+
+
+(provide 'ediff-help)
+
+
+;; arch-tag: 05659813-7fcf-4274-964f-d2f577431a9d
+;;; ediff-help.el ends here
--- /dev/null
+;;; ediff-hook.el --- setup for Ediff's menus and autoloads
+
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+;;; These must be placed in menu-bar.el in Emacs
+;;
+;; (define-key menu-bar-tools-menu [ediff-misc]
+;; '("Ediff Miscellanea" . menu-bar-ediff-misc-menu))
+;; (define-key menu-bar-tools-menu [epatch]
+;; '("Apply Patch" . menu-bar-epatch-menu))
+;; (define-key menu-bar-tools-menu [ediff-merge]
+;; '("Merge" . menu-bar-ediff-merge-menu))
+;; (define-key menu-bar-tools-menu [ediff]
+;; '("Compare" . menu-bar-ediff-menu))
+
+;; Compiler pacifier
+(defvar ediff-menu)
+(defvar ediff-merge-menu)
+(defvar epatch-menu)
+(defvar ediff-misc-menu)
+;; end pacifier
+
+;; allow menus to be set up without ediff-wind.el being loaded
+(defvar ediff-window-setup-function)
+
+;; This autoload is useless in Emacs because ediff-hook.el is dumped with
+;; emacs, but it is needed in XEmacs
+;;;###autoload
+(if (featurep 'xemacs)
+ (progn
+ (defun ediff-xemacs-init-menus ()
+ (when (featurep 'menubar)
+ (add-submenu
+ '("Tools") ediff-menu "OO-Browser...")
+ (add-submenu
+ '("Tools") ediff-merge-menu "OO-Browser...")
+ (add-submenu
+ '("Tools") epatch-menu "OO-Browser...")
+ (add-submenu
+ '("Tools") ediff-misc-menu "OO-Browser...")
+ (add-menu-button
+ '("Tools") "-------" "OO-Browser...")
+ ))
+ (defvar ediff-menu
+ '("Compare"
+ ["Two Files..." ediff-files t]
+ ["Two Buffers..." ediff-buffers t]
+ ["Three Files..." ediff-files3 t]
+ ["Three Buffers..." ediff-buffers3 t]
+ "---"
+ ["Two Directories..." ediff-directories t]
+ ["Three Directories..." ediff-directories3 t]
+ "---"
+ ["File with Revision..." ediff-revision t]
+ ["Directory Revisions..." ediff-directory-revisions t]
+ "---"
+ ["Windows Word-by-word..." ediff-windows-wordwise t]
+ ["Windows Line-by-line..." ediff-windows-linewise t]
+ "---"
+ ["Regions Word-by-word..." ediff-regions-wordwise t]
+ ["Regions Line-by-line..." ediff-regions-linewise t]
+ ))
+ (defvar ediff-merge-menu
+ '("Merge"
+ ["Files..." ediff-merge-files t]
+ ["Files with Ancestor..." ediff-merge-files-with-ancestor t]
+ ["Buffers..." ediff-merge-buffers t]
+ ["Buffers with Ancestor..."
+ ediff-merge-buffers-with-ancestor t]
+ "---"
+ ["Directories..." ediff-merge-directories t]
+ ["Directories with Ancestor..."
+ ediff-merge-directories-with-ancestor t]
+ "---"
+ ["Revisions..." ediff-merge-revisions t]
+ ["Revisions with Ancestor..."
+ ediff-merge-revisions-with-ancestor t]
+ ["Directory Revisions..." ediff-merge-directory-revisions t]
+ ["Directory Revisions with Ancestor..."
+ ediff-merge-directory-revisions-with-ancestor t]
+ ))
+ (defvar epatch-menu
+ '("Apply Patch"
+ ["To a file..." ediff-patch-file t]
+ ["To a buffer..." ediff-patch-buffer t]
+ ))
+ (defvar ediff-misc-menu
+ '("Ediff Miscellanea"
+ ["Ediff Manual" ediff-documentation t]
+ ["Customize Ediff" ediff-customize t]
+ ["List Ediff Sessions" ediff-show-registry t]
+ ["Use separate frame for Ediff control buffer"
+ ediff-toggle-multiframe
+ :style toggle
+ :selected (if (and (featurep 'ediff-util)
+ (boundp 'ediff-window-setup-function))
+ (eq ediff-window-setup-function
+ 'ediff-setup-windows-multiframe))]
+ ["Use a toolbar with Ediff control buffer"
+ ediff-toggle-use-toolbar
+ :style toggle
+ :selected (if (featurep 'ediff-tbar)
+ (ediff-use-toolbar-p))]))
+
+ ;; put these menus before Object-Oriented-Browser in Tools menu
+ (if (and (featurep 'menubar) (not (featurep 'infodock))
+ (not (featurep 'ediff-hook)))
+ (ediff-xemacs-init-menus)))
+ ;; Emacs
+ ;; initialize menu bar keymaps
+ (defvar menu-bar-ediff-misc-menu
+ (make-sparse-keymap "Ediff Miscellanea"))
+ (fset 'menu-bar-ediff-misc-menu
+ (symbol-value 'menu-bar-ediff-misc-menu))
+ (defvar menu-bar-epatch-menu (make-sparse-keymap "Apply Patch"))
+ (fset 'menu-bar-epatch-menu (symbol-value 'menu-bar-epatch-menu))
+ (defvar menu-bar-ediff-merge-menu (make-sparse-keymap "Merge"))
+ (fset 'menu-bar-ediff-merge-menu
+ (symbol-value 'menu-bar-ediff-merge-menu))
+ (defvar menu-bar-ediff-menu (make-sparse-keymap "Compare"))
+ (fset 'menu-bar-ediff-menu (symbol-value 'menu-bar-ediff-menu))
+
+ ;; define ediff compare menu
+ (define-key menu-bar-ediff-menu [ediff-misc]
+ `(menu-item ,(purecopy "Ediff Miscellanea") menu-bar-ediff-misc-menu))
+ (define-key menu-bar-ediff-menu [separator-ediff-misc] menu-bar-separator)
+ (define-key menu-bar-ediff-menu [window]
+ `(menu-item ,(purecopy "This Window and Next Window") compare-windows
+ :help ,(purecopy "Compare the current window and the next window")))
+ (define-key menu-bar-ediff-menu [ediff-windows-linewise]
+ `(menu-item ,(purecopy "Windows Line-by-line...") ediff-windows-linewise
+ :help ,(purecopy "Compare windows line-wise")))
+ (define-key menu-bar-ediff-menu [ediff-windows-wordwise]
+ `(menu-item ,(purecopy "Windows Word-by-word...") ediff-windows-wordwise
+ :help ,(purecopy "Compare windows word-wise")))
+ (define-key menu-bar-ediff-menu [separator-ediff-windows] menu-bar-separator)
+ (define-key menu-bar-ediff-menu [ediff-regions-linewise]
+ `(menu-item ,(purecopy "Regions Line-by-line...") ediff-regions-linewise
+ :help ,(purecopy "Compare regions line-wise")))
+ (define-key menu-bar-ediff-menu [ediff-regions-wordwise]
+ `(menu-item ,(purecopy "Regions Word-by-word...") ediff-regions-wordwise
+ :help ,(purecopy "Compare regions word-wise")))
+ (define-key menu-bar-ediff-menu [separator-ediff-regions] menu-bar-separator)
+ (define-key menu-bar-ediff-menu [ediff-dir-revision]
+ `(menu-item ,(purecopy "Directory Revisions...") ediff-directory-revisions
+ :help ,(purecopy "Compare directory files with their older versions")))
+ (define-key menu-bar-ediff-menu [ediff-revision]
+ `(menu-item ,(purecopy "File with Revision...") ediff-revision
+ :help ,(purecopy "Compare file with its older versions")))
+ (define-key menu-bar-ediff-menu [separator-ediff-directories] menu-bar-separator)
+ (define-key menu-bar-ediff-menu [ediff-directories3]
+ `(menu-item ,(purecopy "Three Directories...") ediff-directories3
+ :help ,(purecopy "Compare files common to three directories simultaneously")))
+ (define-key menu-bar-ediff-menu [ediff-directories]
+ `(menu-item ,(purecopy "Two Directories...") ediff-directories
+ :help ,(purecopy "Compare files common to two directories simultaneously")))
+ (define-key menu-bar-ediff-menu [separator-ediff-files] menu-bar-separator)
+ (define-key menu-bar-ediff-menu [ediff-buffers3]
+ `(menu-item ,(purecopy "Three Buffers...") ediff-buffers3
+ :help ,(purecopy "Compare three buffers simultaneously")))
+ (define-key menu-bar-ediff-menu [ediff-files3]
+ `(menu-item ,(purecopy "Three Files...") ediff-files3
+ :help ,(purecopy "Compare three files simultaneously")))
+ (define-key menu-bar-ediff-menu [ediff-buffers]
+ `(menu-item ,(purecopy "Two Buffers...") ediff-buffers
+ :help ,(purecopy "Compare two buffers simultaneously")))
+ (define-key menu-bar-ediff-menu [ediff-files]
+ `(menu-item ,(purecopy "Two Files...") ediff-files
+ :help ,(purecopy "Compare two files simultaneously")))
+
+ ;; define ediff merge menu
+ (define-key
+ menu-bar-ediff-merge-menu [ediff-merge-dir-revisions-with-ancestor]
+ `(menu-item ,(purecopy "Directory Revisions with Ancestor...")
+ ediff-merge-directory-revisions-with-ancestor
+ :help ,(purecopy "Merge versions of the files in the same directory by comparing the files with common ancestors")))
+ (define-key
+ menu-bar-ediff-merge-menu [ediff-merge-dir-revisions]
+ `(menu-item ,(purecopy "Directory Revisions...") ediff-merge-directory-revisions
+ :help ,(purecopy "Merge versions of the files in the same directory (without using ancestor information)")))
+ (define-key
+ menu-bar-ediff-merge-menu [ediff-merge-revisions-with-ancestor]
+ `(menu-item ,(purecopy "Revisions with Ancestor...")
+ ediff-merge-revisions-with-ancestor
+ :help ,(purecopy "Merge versions of the same file by comparing them with a common ancestor")))
+ (define-key menu-bar-ediff-merge-menu [ediff-merge-revisions]
+ `(menu-item ,(purecopy "Revisions...") ediff-merge-revisions
+ :help ,(purecopy "Merge versions of the same file (without using ancestor information)")))
+ (define-key menu-bar-ediff-merge-menu [separator-ediff-merge] menu-bar-separator)
+ (define-key
+ menu-bar-ediff-merge-menu [ediff-merge-directories-with-ancestor]
+ `(menu-item ,(purecopy "Directories with Ancestor...")
+ ediff-merge-directories-with-ancestor
+ :help ,(purecopy "Merge files common to a pair of directories by comparing the files with common ancestors")))
+ (define-key menu-bar-ediff-merge-menu [ediff-merge-directories]
+ `(menu-item ,(purecopy "Directories...") ediff-merge-directories
+ :help ,(purecopy "Merge files common to a pair of directories")))
+ (define-key
+ menu-bar-ediff-merge-menu [separator-ediff-merge-dirs] menu-bar-separator)
+ (define-key
+ menu-bar-ediff-merge-menu [ediff-merge-buffers-with-ancestor]
+ `(menu-item ,(purecopy "Buffers with Ancestor...") ediff-merge-buffers-with-ancestor
+ :help ,(purecopy "Merge buffers by comparing their contents with a common ancestor")))
+ (define-key menu-bar-ediff-merge-menu [ediff-merge-buffers]
+ `(menu-item ,(purecopy "Buffers...") ediff-merge-buffers
+ :help ,(purecopy "Merge buffers (without using ancestor information)")))
+ (define-key menu-bar-ediff-merge-menu [ediff-merge-files-with-ancestor]
+ `(menu-item ,(purecopy "Files with Ancestor...") ediff-merge-files-with-ancestor
+ :help ,(purecopy "Merge files by comparing them with a common ancestor")))
+ (define-key menu-bar-ediff-merge-menu [ediff-merge-files]
+ `(menu-item ,(purecopy "Files...") ediff-merge-files
+ :help ,(purecopy "Merge files (without using ancestor information)")))
+
+ ;; define epatch menu
+ (define-key menu-bar-epatch-menu [ediff-patch-buffer]
+ `(menu-item ,(purecopy "To a Buffer...") ediff-patch-buffer
+ :help ,(purecopy "Apply a patch to the contents of a buffer")))
+ (define-key menu-bar-epatch-menu [ediff-patch-file]
+ `(menu-item ,(purecopy "To a File...") ediff-patch-file
+ :help ,(purecopy "Apply a patch to a file")))
+
+ ;; define ediff miscellanea
+ (define-key menu-bar-ediff-misc-menu [emultiframe]
+ `(menu-item ,(purecopy "Use separate control buffer frame")
+ ediff-toggle-multiframe
+ :help ,(purecopy "Switch between the single-frame presentation mode and the multi-frame mode")))
+ (define-key menu-bar-ediff-misc-menu [eregistry]
+ `(menu-item ,(purecopy "List Ediff Sessions") ediff-show-registry
+ :help ,(purecopy "List all active Ediff sessions; it is a convenient way to find and resume such a session")))
+ (define-key menu-bar-ediff-misc-menu [ediff-cust]
+ `(menu-item ,(purecopy "Customize Ediff") ediff-customize
+ :help ,(purecopy "Change some of the parameters that govern the behavior of Ediff")))
+ (define-key menu-bar-ediff-misc-menu [ediff-doc]
+ `(menu-item ,(purecopy "Ediff Manual") ediff-documentation
+ :help ,(purecopy "Bring up the Ediff manual"))))
+
+(provide 'ediff-hook)
+
+
+;; arch-tag: 512f8656-8a4b-4789-af5d-5c6144498df3
+;;; ediff-hook.el ends here
--- /dev/null
+;;; ediff-init.el --- Macros, variables, and defsubsts used by Ediff
+
+;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+;; Start compiler pacifier
+(defvar ediff-metajob-name)
+(defvar ediff-meta-buffer)
+(defvar ediff-grab-mouse)
+(defvar ediff-mouse-pixel-position)
+(defvar ediff-mouse-pixel-threshold)
+(defvar ediff-whitespace)
+(defvar ediff-multiframe)
+(defvar ediff-use-toolbar-p)
+(defvar mswindowsx-bitmap-file-path)
+;; end pacifier
+
+(defvar ediff-force-faces nil
+ "If t, Ediff will think that it is running on a display that supports faces.
+This is provided as a temporary relief for users of face-capable displays
+that Ediff doesn't know about.")
+
+;; Are we running as a window application or on a TTY?
+(defsubst ediff-device-type ()
+ (if (featurep 'xemacs)
+ (device-type (selected-device))
+ window-system))
+
+;; in XEmacs: device-type is tty on tty and stream in batch.
+(defun ediff-window-display-p ()
+ (and (ediff-device-type) (not (memq (ediff-device-type) '(tty pc stream)))))
+
+;; test if supports faces
+(defun ediff-has-face-support-p ()
+ (cond ((ediff-window-display-p))
+ (ediff-force-faces)
+ ((ediff-color-display-p))
+ ((featurep 'emacs) (memq (ediff-device-type) '(pc)))
+ ((featurep 'xemacs) (memq (ediff-device-type) '(tty pc)))
+ ))
+
+;; toolbar support for emacs hasn't been implemented in ediff
+(defun ediff-has-toolbar-support-p ()
+ (if (featurep 'xemacs)
+ (if (featurep 'toolbar) (console-on-window-system-p))))
+
+
+(defun ediff-has-gutter-support-p ()
+ (if (featurep 'xemacs)
+ (if (featurep 'gutter) (console-on-window-system-p))))
+
+(defun ediff-use-toolbar-p ()
+ (and (ediff-has-toolbar-support-p) ;Can it do it ?
+ (boundp 'ediff-use-toolbar-p)
+ ediff-use-toolbar-p)) ;Does the user want it ?
+
+;; Defines VAR as an advertised local variable.
+;; Performs a defvar, then executes `make-variable-buffer-local' on
+;; the variable. Also sets the `permanent-local' property,
+;; so that `kill-all-local-variables' (called by major-mode setting
+;; commands) won't destroy Ediff control variables.
+;;
+;; Plagiarised from `emerge-defvar-local' for XEmacs.
+(defmacro ediff-defvar-local (var value doc)
+ "Defines VAR as a local variable."
+ (declare (indent defun))
+ `(progn
+ (defvar ,var ,value ,doc)
+ (make-variable-buffer-local ',var)
+ (put ',var 'permanent-local t)))
+
+
+
+;; Variables that control each Ediff session---local to the control buffer.
+
+;; Mode variables
+;; The buffer in which the A variant is stored.
+(ediff-defvar-local ediff-buffer-A nil "")
+;; The buffer in which the B variant is stored.
+(ediff-defvar-local ediff-buffer-B nil "")
+;; The buffer in which the C variant is stored or where the merge buffer lives.
+(ediff-defvar-local ediff-buffer-C nil "")
+;; Ancestor buffer
+(ediff-defvar-local ediff-ancestor-buffer nil "")
+;; The Ediff control buffer
+(ediff-defvar-local ediff-control-buffer nil "")
+
+(ediff-defvar-local ediff-temp-indirect-buffer nil
+ "If t, the buffer is a temporary indirect buffer.
+It needs to be killed when we quit the session.")
+
+
+;; Association between buff-type and ediff-buffer-*
+(defconst ediff-buffer-alist
+ '((?A . ediff-buffer-A)
+ (?B . ediff-buffer-B)
+ (?C . ediff-buffer-C)))
+
+;;; Macros
+(defmacro ediff-odd-p (arg)
+ `(eq (logand ,arg 1) 1))
+
+(defmacro ediff-buffer-live-p (buf)
+ `(and ,buf (get-buffer ,buf) (buffer-name (get-buffer ,buf))))
+
+(defmacro ediff-get-buffer (arg)
+ `(cond ((eq ,arg 'A) ediff-buffer-A)
+ ((eq ,arg 'B) ediff-buffer-B)
+ ((eq ,arg 'C) ediff-buffer-C)
+ ((eq ,arg 'Ancestor) ediff-ancestor-buffer)
+ ))
+
+(defmacro ediff-get-value-according-to-buffer-type (buf-type list)
+ `(cond ((eq ,buf-type 'A) (nth 0 ,list))
+ ((eq ,buf-type 'B) (nth 1 ,list))
+ ((eq ,buf-type 'C) (nth 2 ,list))
+ ))
+
+(defmacro ediff-char-to-buftype (arg)
+ `(cond ((memq ,arg '(?a ?A)) 'A)
+ ((memq ,arg '(?b ?B)) 'B)
+ ((memq ,arg '(?c ?C)) 'C)
+ ))
+
+
+;; A-list is supposed to be of the form (A . symb) (B . symb)...)
+;; where the first part of any association is a buffer type and the second is
+;; an appropriate symbol. Given buffer-type, this function returns the
+;; symbol. This is used to avoid using `intern'
+(defsubst ediff-get-symbol-from-alist (buf-type alist)
+ (cdr (assoc buf-type alist)))
+
+(defconst ediff-difference-vector-alist
+ '((A . ediff-difference-vector-A)
+ (B . ediff-difference-vector-B)
+ (C . ediff-difference-vector-C)
+ (Ancestor . ediff-difference-vector-Ancestor)))
+
+(defmacro ediff-get-difference (n buf-type)
+ `(aref
+ (symbol-value
+ (ediff-get-symbol-from-alist
+ ,buf-type ediff-difference-vector-alist))
+ ,n))
+
+;; Tell if it has been previously determined that the region has
+;; no diffs other than the white space and newlines
+;; The argument, N, is the diff region number used by Ediff to index the
+;; diff vector. It is 1 less than the number seen by the user.
+;; Returns:
+;; t if the diffs are whitespace in all buffers
+;; 'A (in 3-buf comparison only) if there are only whitespace
+;; diffs in bufs B and C
+;; 'B (in 3-buf comparison only) if there are only whitespace
+;; diffs in bufs A and C
+;; 'C (in 3-buf comparison only) if there are only whitespace
+;; diffs in bufs A and B
+;;
+;; A Difference Vector has the form:
+;; [diff diff diff ...]
+;; where each diff has the form:
+;; [overlay fine-diff-vector no-fine-diffs-flag state-of-difference]
+;; fine-diff-vector is a vector [fine-diff fine-diff fine-diff ...]
+;; no-fine-diffs-flag says if there are fine differences.
+;; state-of-difference is A, B, C, or nil, indicating which buffer is
+;; different from the other two (used only in 3-way jobs).
+(defmacro ediff-no-fine-diffs-p (n)
+ `(aref (ediff-get-difference ,n 'A) 2))
+
+(defmacro ediff-get-diff-overlay-from-diff-record (diff-rec)
+ `(aref ,diff-rec 0))
+
+(defmacro ediff-get-diff-overlay (n buf-type)
+ `(ediff-get-diff-overlay-from-diff-record
+ (ediff-get-difference ,n ,buf-type)))
+
+(defmacro ediff-get-fine-diff-vector-from-diff-record (diff-rec)
+ `(aref ,diff-rec 1))
+
+(defmacro ediff-set-fine-diff-vector (n buf-type fine-vec)
+ `(aset (ediff-get-difference ,n ,buf-type) 1 ,fine-vec))
+
+(defmacro ediff-get-state-of-diff (n buf-type)
+ `(if (ediff-buffer-live-p ediff-buffer-C)
+ (aref (ediff-get-difference ,n ,buf-type) 3)))
+(defmacro ediff-set-state-of-diff (n buf-type val)
+ `(aset (ediff-get-difference ,n ,buf-type) 3 ,val))
+
+(defmacro ediff-get-state-of-merge (n)
+ `(if ediff-state-of-merge
+ (aref (aref ediff-state-of-merge ,n) 0)))
+(defmacro ediff-set-state-of-merge (n val)
+ `(if ediff-state-of-merge
+ (aset (aref ediff-state-of-merge ,n) 0 ,val)))
+
+(defmacro ediff-get-state-of-ancestor (n)
+ `(if ediff-state-of-merge
+ (aref (aref ediff-state-of-merge ,n) 1)))
+
+;; if flag is t, puts a mark on diff region saying that
+;; the differences are in white space only. If flag is nil,
+;; the region is marked as essential (i.e., differences are
+;; not just in the white space and newlines.)
+(defmacro ediff-mark-diff-as-space-only (n flag)
+ `(aset (ediff-get-difference ,n 'A) 2 ,flag))
+
+(defmacro ediff-get-fine-diff-vector (n buf-type)
+ `(ediff-get-fine-diff-vector-from-diff-record
+ (ediff-get-difference ,n ,buf-type)))
+
+;; Macro to switch to BUFFER, evaluate BODY, returns to original buffer.
+;; Doesn't save the point and mark.
+;; This is `with-current-buffer' with the added test for live buffers."
+(defmacro ediff-with-current-buffer (buffer &rest body)
+ "Evaluates BODY in BUFFER."
+ (declare (indent 1) (debug (form body)))
+ `(if (ediff-buffer-live-p ,buffer)
+ (save-current-buffer
+ (set-buffer ,buffer)
+ ,@body)
+ (or (eq this-command 'ediff-quit)
+ (error ediff-KILLED-VITAL-BUFFER))
+ ))
+
+
+(defsubst ediff-multiframe-setup-p ()
+ (and (ediff-window-display-p) ediff-multiframe))
+
+(defmacro ediff-narrow-control-frame-p ()
+ `(and (ediff-multiframe-setup-p)
+ (equal ediff-help-message ediff-brief-message-string)))
+
+(defmacro ediff-3way-comparison-job ()
+ `(memq
+ ediff-job-name
+ '(ediff-files3 ediff-buffers3)))
+(ediff-defvar-local ediff-3way-comparison-job nil "")
+
+(defmacro ediff-merge-job ()
+ `(memq
+ ediff-job-name
+ '(ediff-merge-files
+ ediff-merge-buffers
+ ediff-merge-files-with-ancestor
+ ediff-merge-buffers-with-ancestor
+ ediff-merge-revisions
+ ediff-merge-revisions-with-ancestor)))
+(ediff-defvar-local ediff-merge-job nil "")
+
+(defmacro ediff-patch-job ()
+ `(eq ediff-job-name 'epatch))
+
+(defmacro ediff-merge-with-ancestor-job ()
+ `(memq
+ ediff-job-name
+ '(ediff-merge-files-with-ancestor
+ ediff-merge-buffers-with-ancestor
+ ediff-merge-revisions-with-ancestor)))
+(ediff-defvar-local ediff-merge-with-ancestor-job nil "")
+
+(defmacro ediff-3way-job ()
+ `(or ediff-3way-comparison-job ediff-merge-job))
+(ediff-defvar-local ediff-3way-job nil "")
+
+;; A diff3 job is like a 3way job, but ediff-merge doesn't require the use
+;; of diff3.
+(defmacro ediff-diff3-job ()
+ `(or ediff-3way-comparison-job
+ ediff-merge-with-ancestor-job))
+(ediff-defvar-local ediff-diff3-job nil "")
+
+(defmacro ediff-windows-job ()
+ `(memq ediff-job-name '(ediff-windows-wordwise ediff-windows-linewise)))
+(ediff-defvar-local ediff-windows-job nil "")
+
+(defmacro ediff-word-mode-job ()
+ `(memq ediff-job-name '(ediff-windows-wordwise ediff-regions-wordwise)))
+(ediff-defvar-local ediff-word-mode-job nil "")
+
+(defmacro ediff-narrow-job ()
+ `(memq ediff-job-name '(ediff-windows-wordwise
+ ediff-regions-wordwise
+ ediff-windows-linewise
+ ediff-regions-linewise)))
+(ediff-defvar-local ediff-narrow-job nil "")
+
+;; Note: ediff-merge-directory-revisions-with-ancestor is not treated as an
+;; ancestor metajob, since it behaves differently.
+(defsubst ediff-ancestor-metajob (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-merge-directories-with-ancestor
+ ediff-merge-filegroups-with-ancestor)))
+(defsubst ediff-revision-metajob (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-directory-revisions
+ ediff-merge-directory-revisions
+ ediff-merge-directory-revisions-with-ancestor)))
+(defsubst ediff-patch-metajob (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-multifile-patch)))
+;; metajob involving only one group of files, such as multipatch or directory
+;; revision
+(defsubst ediff-one-filegroup-metajob (&optional metajob)
+ (or (ediff-revision-metajob metajob)
+ (ediff-patch-metajob metajob)
+ ;; add more here
+ ))
+;; jobs suitable for the operation of collecting diffs into a multifile patch
+(defsubst ediff-collect-diffs-metajob (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-directories
+ ediff-merge-directories
+ ediff-merge-directories-with-ancestor
+ ediff-directory-revisions
+ ediff-merge-directory-revisions
+ ediff-merge-directory-revisions-with-ancestor
+ ;; add more here
+ )))
+(defsubst ediff-merge-metajob (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-merge-directories
+ ediff-merge-directories-with-ancestor
+ ediff-merge-directory-revisions
+ ediff-merge-directory-revisions-with-ancestor
+ ediff-merge-filegroups-with-ancestor
+ ;; add more here
+ )))
+
+(defsubst ediff-metajob3 (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-merge-directories-with-ancestor
+ ediff-merge-filegroups-with-ancestor
+ ediff-directories3
+ ediff-filegroups3)))
+(defsubst ediff-comparison-metajob3 (&optional metajob)
+ (memq (or metajob ediff-metajob-name)
+ '(ediff-directories3 ediff-filegroups3)))
+
+;; with no argument, checks if we are in ediff-control-buffer
+;; with argument, checks if we are in ediff-meta-buffer
+(defun ediff-in-control-buffer-p (&optional meta-buf-p)
+ (and (boundp 'ediff-control-buffer)
+ (eq (if meta-buf-p ediff-meta-buffer ediff-control-buffer)
+ (current-buffer))))
+
+(defsubst ediff-barf-if-not-control-buffer (&optional meta-buf-p)
+ (or (ediff-in-control-buffer-p meta-buf-p)
+ (error "%S: This command runs in Ediff Control Buffer only!"
+ this-command)))
+
+(defgroup ediff-highlighting nil
+ "Hilighting of difference regions in Ediff."
+ :prefix "ediff-"
+ :group 'ediff)
+
+(defgroup ediff-merge nil
+ "Merging utilities."
+ :prefix "ediff-"
+ :group 'ediff)
+
+(defgroup ediff-hook nil
+ "Hooks run by Ediff."
+ :prefix "ediff-"
+ :group 'ediff)
+
+;; Hook variables
+
+(defcustom ediff-before-setup-hook nil
+ "Hooks to run before Ediff begins to set up windows and buffers.
+This hook can be used to save the previous window config, which can be restored
+on ediff-quit or ediff-suspend."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-before-setup-windows-hook nil
+ "Hooks to run before Ediff sets its window configuration.
+This hook is run every time when Ediff arranges its windows.
+This happens each time Ediff detects that the windows were messed up by the
+user."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-after-setup-windows-hook nil
+ "Hooks to run after Ediff sets its window configuration.
+This can be used to set up control window or icon in a desired place."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-before-setup-control-frame-hook nil
+ "Hooks run before setting up the frame to display Ediff Control Panel.
+Can be used to change control frame parameters to position it where it
+is desirable."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-after-setup-control-frame-hook nil
+ "Hooks run after setting up the frame to display Ediff Control Panel.
+Can be used to move the frame where it is desired."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-startup-hook nil
+ "Hooks to run in the control buffer after Ediff has been set up and is ready for the job."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-select-hook nil
+ "Hooks to run after a difference has been selected."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-unselect-hook nil
+ "Hooks to run after a difference has been unselected."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-prepare-buffer-hook nil
+ "Hooks run after buffers A, B, and C are set up.
+For each buffer, the hooks are run with that buffer made current."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-load-hook nil
+ "Hook run after Ediff is loaded. Can be used to change defaults."
+ :type 'hook
+ :group 'ediff-hook)
+
+(defcustom ediff-mode-hook nil
+ "Hook run just after ediff-mode is set up in the control buffer.
+This is done before any windows or frames are created. One can use it to
+set local variables that determine how the display looks like."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-keymap-setup-hook nil
+ "Hook run just after the default bindings in Ediff keymap are set up."
+ :type 'hook
+ :group 'ediff-hook)
+
+(defcustom ediff-display-help-hook nil
+ "Hooks run after preparing the help message."
+ :type 'hook
+ :group 'ediff-hook)
+
+(defcustom ediff-suspend-hook nil
+ "Hooks to run in the Ediff control buffer when Ediff is suspended."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-quit-hook nil
+ "Hooks to run in the Ediff control buffer after finishing Ediff."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-cleanup-hook nil
+ "Hooks to run on exiting Ediff but before killing the control and variant buffers."
+ :type 'hook
+ :group 'ediff-hook)
+
+;; Error messages
+(defconst ediff-KILLED-VITAL-BUFFER
+ "You have killed a vital Ediff buffer---you must leave Ediff now!")
+(defconst ediff-NO-DIFFERENCES
+ "Sorry, comparison of identical variants is not what I am made for...")
+(defconst ediff-BAD-DIFF-NUMBER
+ ;; %S stands for this-command, %d - diff number, %d - max diff
+ "%S: Bad diff region number, %d. Valid numbers are 1 to %d")
+(defconst ediff-BAD-INFO (format "
+*** The Info file for Ediff, a part of the standard distribution
+*** of %sEmacs, does not seem to be properly installed.
+***
+*** Please contact your system administrator. "
+ (if (featurep 'xemacs) "X" "")))
+
+;; Selective browsing
+
+(ediff-defvar-local ediff-skip-diff-region-function 'ediff-show-all-diffs
+ "Function that determines the next/previous diff region to show.
+Should return t for regions to be ignored and nil otherwise.
+This function gets a region number as an argument. The region number
+is the one used internally by Ediff. It is 1 less than the number seen
+by the user.")
+
+(ediff-defvar-local ediff-hide-regexp-matches-function
+ 'ediff-hide-regexp-matches
+ "Function to use in determining which regions to hide.
+See the documentation string of `ediff-hide-regexp-matches' for details.")
+(ediff-defvar-local ediff-focus-on-regexp-matches-function
+ 'ediff-focus-on-regexp-matches
+ "Function to use in determining which regions to focus on.
+See the documentation string of `ediff-focus-on-regexp-matches' for details.")
+
+;; Regexp that determines buf A regions to focus on when skipping to diff
+(ediff-defvar-local ediff-regexp-focus-A "" "")
+;; Regexp that determines buf B regions to focus on when skipping to diff
+(ediff-defvar-local ediff-regexp-focus-B "" "")
+;; Regexp that determines buf C regions to focus on when skipping to diff
+(ediff-defvar-local ediff-regexp-focus-C "" "")
+;; connective that determines whether to focus regions that match both or
+;; one of the regexps
+(ediff-defvar-local ediff-focus-regexp-connective 'and "")
+
+;; Regexp that determines buf A regions to ignore when skipping to diff
+(ediff-defvar-local ediff-regexp-hide-A "" "")
+;; Regexp that determines buf B regions to ignore when skipping to diff
+(ediff-defvar-local ediff-regexp-hide-B "" "")
+;; Regexp that determines buf C regions to ignore when skipping to diff
+(ediff-defvar-local ediff-regexp-hide-C "" "")
+;; connective that determines whether to hide regions that match both or
+;; one of the regexps
+(ediff-defvar-local ediff-hide-regexp-connective 'and "")
+
+
+;;; Copying difference regions between buffers.
+
+;; A list of killed diffs.
+;; A diff is saved here if it is replaced by a diff
+;; from another buffer. This alist has the form:
+;; \((num (buff-object . diff) (buff-object . diff) (buff-object . diff)) ...),
+;; where some buffer-objects may be missing.
+(ediff-defvar-local ediff-killed-diffs-alist nil "")
+
+;; Syntax table to use in ediff-forward-word-function
+;; This is chosen by a heuristic. The important thing is for all buffers to
+;; have the same syntax table. Which is not too important.
+(ediff-defvar-local ediff-syntax-table nil "")
+
+
+;; Highlighting
+(defcustom ediff-before-flag-bol (if (featurep 'xemacs) (make-glyph "->>") "->>")
+ "Flag placed before a highlighted block of differences, if block starts at beginning of a line."
+ :type 'string
+ :tag "Region before-flag at beginning of line"
+ :group 'ediff)
+
+(defcustom ediff-after-flag-eol (if (featurep 'xemacs) (make-glyph "<<-") "<<-")
+ "Flag placed after a highlighted block of differences, if block ends at end of a line."
+ :type 'string
+ :tag "Region after-flag at end of line"
+ :group 'ediff)
+
+(defcustom ediff-before-flag-mol (if (featurep 'xemacs) (make-glyph "->>") "->>")
+ "Flag placed before a highlighted block of differences, if block starts in mid-line."
+ :type 'string
+ :tag "Region before-flag in the middle of line"
+ :group 'ediff)
+(defcustom ediff-after-flag-mol (if (featurep 'xemacs) (make-glyph "<<-") "<<-")
+ "Flag placed after a highlighted block of differences, if block ends in mid-line."
+ :type 'string
+ :tag "Region after-flag in the middle of line"
+ :group 'ediff)
+
+
+(ediff-defvar-local ediff-use-faces t "")
+(defcustom ediff-use-faces t
+ "If t, differences are highlighted using faces, if device supports faces.
+If nil, differences are highlighted using ASCII flags, ediff-before-flag
+and ediff-after-flag. On a non-window system, differences are always
+highlighted using ASCII flags."
+ :type 'boolean
+ :group 'ediff-highlighting)
+
+;; this indicates that diff regions are word-size, so fine diffs are
+;; permanently nixed; used in ediff-windows-wordwise and ediff-regions-wordwise
+(ediff-defvar-local ediff-word-mode nil "")
+;; Name of the job (ediff-files, ediff-windows, etc.)
+(ediff-defvar-local ediff-job-name nil "")
+
+;; Narrowing and ediff-region/windows support
+;; This is a list (overlay-A overlay-B overlay-C)
+;; If set, Ediff compares only those parts of buffers A/B/C that lie within
+;; the bounds of these overlays.
+(ediff-defvar-local ediff-narrow-bounds nil "")
+
+;; List (overlay-A overlay-B overlay-C), where each overlay spans the
+;; entire corresponding buffer.
+(ediff-defvar-local ediff-wide-bounds nil "")
+
+;; Current visibility boundaries in buffers A, B, and C.
+;; This is also a list of overlays. When the user toggles narrow/widen,
+;; this list changes from ediff-wide-bounds to ediff-narrow-bounds.
+;; and back.
+(ediff-defvar-local ediff-visible-bounds nil "")
+
+(ediff-defvar-local ediff-start-narrowed t
+ "Non-nil means start narrowed, if doing ediff-windows-* or ediff-regions-*")
+(ediff-defvar-local ediff-quit-widened t
+ "*Non-nil means: when finished, Ediff widens buffers A/B.
+Actually, Ediff restores the scope of visibility that existed at startup.")
+
+(defcustom ediff-keep-variants t
+ "nil means prompt to remove unmodified buffers A/B/C at session end.
+Supplying a prefix argument to the quit command `q' temporarily reverses the
+meaning of this variable."
+ :type 'boolean
+ :group 'ediff)
+
+(ediff-defvar-local ediff-highlight-all-diffs t "")
+(defcustom ediff-highlight-all-diffs t
+ "If nil, only the selected differences are highlighted.
+Otherwise, all difference regions are highlighted, but the selected region is
+shown in brighter colors."
+ :type 'boolean
+ :group 'ediff-highlighting)
+
+
+;; The suffix of the control buffer name.
+(ediff-defvar-local ediff-control-buffer-suffix nil "")
+;; Same as ediff-control-buffer-suffix, but without <,>.
+;; It's a number rather than string.
+(ediff-defvar-local ediff-control-buffer-number nil "")
+
+
+;; The original values of ediff-protected-variables for buffer A
+(ediff-defvar-local ediff-buffer-values-orig-A nil "")
+;; The original values of ediff-protected-variables for buffer B
+(ediff-defvar-local ediff-buffer-values-orig-B nil "")
+;; The original values of ediff-protected-variables for buffer C
+(ediff-defvar-local ediff-buffer-values-orig-C nil "")
+;; The original values of ediff-protected-variables for buffer Ancestor
+(ediff-defvar-local ediff-buffer-values-orig-Ancestor nil "")
+
+;; association between buff-type and ediff-buffer-values-orig-*
+(defconst ediff-buffer-values-orig-alist
+ '((A . ediff-buffer-values-orig-A)
+ (B . ediff-buffer-values-orig-B)
+ (C . ediff-buffer-values-orig-C)
+ (Ancestor . ediff-buffer-values-orig-Ancestor)))
+
+;; Buffer-local variables to be saved then restored during Ediff sessions
+(defconst ediff-protected-variables '(
+ ;;buffer-read-only
+ mode-line-format))
+
+;; Vector of differences between the variants. Each difference is
+;; represented by a vector of two overlays plus a vector of fine diffs,
+;; plus a no-fine-diffs flag. The first overlay spans the
+;; difference region in the A buffer and the second overlays the diff in
+;; the B buffer. If a difference section is empty, the corresponding
+;; overlay's endpoints coincide.
+;;
+;; The precise form of a Difference Vector for one buffer is:
+;; [diff diff diff ...]
+;; where each diff has the form:
+;; [diff-overlay fine-diff-vector no-fine-diffs-flag state-of-diff]
+;; fine-diff-vector is a vector [fine-diff-overlay fine-diff-overlay ...]
+;; no-fine-diffs-flag says if there are fine differences.
+;; state-of-difference is A, B, C, or nil, indicating which buffer is
+;; different from the other two (used only in 3-way jobs.
+(ediff-defvar-local ediff-difference-vector-A nil "")
+(ediff-defvar-local ediff-difference-vector-B nil "")
+(ediff-defvar-local ediff-difference-vector-C nil "")
+(ediff-defvar-local ediff-difference-vector-Ancestor nil "")
+;; A-list of diff vector types associated with buffer types
+(defconst ediff-difference-vector-alist
+ '((A . ediff-difference-vector-A)
+ (B . ediff-difference-vector-B)
+ (C . ediff-difference-vector-C)
+ (Ancestor . ediff-difference-vector-Ancestor)))
+
+;; [ status status status ...]
+;; Each status: [state-of-merge state-of-ancestor]
+;; state-of-merge is default-A, default-B, prefer-A, or prefer-B. It
+;; indicates the way a diff region was created in buffer C.
+;; state-of-ancestor says if the corresponding region in ancestor buffer is
+;; empty.
+(ediff-defvar-local ediff-state-of-merge nil "")
+
+;; The difference that is currently selected.
+(ediff-defvar-local ediff-current-difference -1 "")
+;; Number of differences found.
+(ediff-defvar-local ediff-number-of-differences nil "")
+
+;; Buffer containing the output of diff, which is used by Ediff to step
+;; through files.
+(ediff-defvar-local ediff-diff-buffer nil "")
+;; Like ediff-diff-buffer, but contains context diff. It is not used by
+;; Ediff, but it is saved in a file, if user requests so.
+(ediff-defvar-local ediff-custom-diff-buffer nil "")
+;; Buffer used for diff-style fine differences between regions.
+(ediff-defvar-local ediff-fine-diff-buffer nil "")
+;; Temporary buffer used for computing fine differences.
+(defconst ediff-tmp-buffer " *ediff-tmp*" "")
+;; Buffer used for messages
+(defconst ediff-msg-buffer " *ediff-message*" "")
+;; Buffer containing the output of diff when diff returns errors.
+(ediff-defvar-local ediff-error-buffer nil "")
+;; Buffer to display debug info
+(ediff-defvar-local ediff-debug-buffer "*ediff-debug*" "")
+
+;; List of ediff control panels associated with each buffer A/B/C/Ancestor.
+;; Not used any more, but may be needed in the future.
+(ediff-defvar-local ediff-this-buffer-ediff-sessions nil "")
+
+;; to be deleted in due time
+;; List of difference overlays disturbed by working with the current diff.
+(defvar ediff-disturbed-overlays nil "")
+
+;; Priority of non-selected overlays.
+(defvar ediff-shadow-overlay-priority 100 "")
+
+(defcustom ediff-version-control-package 'vc
+ "Version control package used.
+Currently, Ediff supports vc.el, rcs.el, pcl-cvs.el, and generic-sc.el. The
+standard Emacs interface to RCS, CVS, SCCS, etc., is vc.el. However, some
+people find the other two packages more convenient. Set this variable to the
+appropriate symbol: `rcs', `pcl-cvs', or `generic-sc' if you so desire."
+ :type 'symbol
+ :group 'ediff)
+
+(defcustom ediff-coding-system-for-read 'raw-text
+ "The coding system for read to use when running the diff program as a subprocess.
+In most cases, the default will do. However, under certain circumstances in
+MS-Windows you might need to use something like 'raw-text-dos here.
+So, if the output that your diff program sends to Emacs contains extra ^M's,
+you might need to experiment here, if the default or 'raw-text-dos doesn't
+work."
+ :type 'symbol
+ :group 'ediff)
+
+(defcustom ediff-coding-system-for-write (if (featurep 'xemacs)
+ 'escape-quoted
+ 'emacs-internal)
+ "The coding system for write to use when writing out difference regions
+to temp files in buffer jobs and when Ediff needs to find fine differences."
+ :type 'symbol
+ :group 'ediff)
+
+
+(defalias 'ediff-read-event
+ (if (featurep 'xemacs) 'next-command-event 'read-event))
+
+(defalias 'ediff-overlayp
+ (if (featurep 'xemacs) 'extentp 'overlayp))
+
+(defalias 'ediff-make-overlay
+ (if (featurep 'xemacs) 'make-extent 'make-overlay))
+
+(defalias 'ediff-delete-overlay
+ (if (featurep 'xemacs) 'delete-extent 'delete-overlay))
+
+;; Assumes that emacs-major-version and emacs-minor-version are defined.
+(defun ediff-check-version (op major minor &optional type-of-emacs)
+ "Check the current version against MAJOR and MINOR version numbers.
+The comparison uses operator OP, which may be any of: =, >, >=, <, <=.
+TYPE-OF-EMACS is either 'xemacs or 'emacs."
+ (and (cond ((eq type-of-emacs 'xemacs) (featurep 'xemacs))
+ ((eq type-of-emacs 'emacs) (featurep 'emacs))
+ (t))
+ (cond ((eq op '=) (and (= emacs-minor-version minor)
+ (= emacs-major-version major)))
+ ((memq op '(> >= < <=))
+ (and (or (funcall op emacs-major-version major)
+ (= emacs-major-version major))
+ (if (= emacs-major-version major)
+ (funcall op emacs-minor-version minor)
+ t)))
+ (t
+ (error "%S: Invalid op in ediff-check-version" op)))))
+
+;; ediff-check-version seems to be totally unused anyway.
+(make-obsolete 'ediff-check-version 'version< "23.1")
+
+(defun ediff-color-display-p ()
+ (condition-case nil
+ (if (featurep 'xemacs)
+ (eq (device-class (selected-device)) 'color) ; xemacs form
+ (display-color-p)) ; emacs form
+ (error nil)))
+
+
+;; A var local to each control panel buffer. Indicates highlighting style
+;; in effect for this buffer: `face', `ascii',
+;; `off' -- turned off \(on a dumb terminal only\).
+(ediff-defvar-local ediff-highlighting-style
+ (if (and (ediff-has-face-support-p) ediff-use-faces) 'face 'ascii)
+ "")
+
+
+(if (ediff-has-face-support-p)
+ (if (featurep 'xemacs)
+ (progn
+ (defalias 'ediff-valid-color-p 'valid-color-name-p)
+ (defalias 'ediff-get-face 'get-face))
+ (defalias 'ediff-valid-color-p (if (fboundp 'color-defined-p)
+ 'color-defined-p
+ 'x-color-defined-p))
+ (defalias 'ediff-get-face 'internal-get-face)))
+
+(if (ediff-window-display-p)
+ (if (featurep 'xemacs)
+ (progn
+ (defalias 'ediff-display-pixel-width 'device-pixel-width)
+ (defalias 'ediff-display-pixel-height 'device-pixel-height))
+ (defalias 'ediff-display-pixel-width
+ (if (fboundp 'display-pixel-width)
+ 'display-pixel-width
+ 'x-display-pixel-width))
+ (defalias 'ediff-display-pixel-height
+ (if (fboundp 'display-pixel-height)
+ 'display-pixel-height
+ 'x-display-pixel-height))))
+
+;; A-list of current-diff-overlay symbols associated with buf types
+(defconst ediff-current-diff-overlay-alist
+ '((A . ediff-current-diff-overlay-A)
+ (B . ediff-current-diff-overlay-B)
+ (C . ediff-current-diff-overlay-C)
+ (Ancestor . ediff-current-diff-overlay-Ancestor)))
+
+;; A-list of current-diff-face-* symbols associated with buf types
+(defconst ediff-current-diff-face-alist
+ '((A . ediff-current-diff-A)
+ (B . ediff-current-diff-B)
+ (C . ediff-current-diff-C)
+ (Ancestor . ediff-current-diff-Ancestor)))
+
+
+(defun ediff-set-overlay-face (extent face)
+ (ediff-overlay-put extent 'face face)
+ (ediff-overlay-put extent 'help-echo 'ediff-region-help-echo))
+
+(defun ediff-region-help-echo (extent-or-window &optional overlay point)
+ (unless overlay
+ (setq overlay extent-or-window))
+ (let ((is-current (ediff-overlay-get overlay 'ediff))
+ (face (ediff-overlay-get overlay 'face))
+ (diff-num (ediff-overlay-get overlay 'ediff-diff-num))
+ face-help)
+
+ ;; This happens only for refinement overlays
+ (if (stringp face)
+ (setq face (intern face)))
+ (setq face-help (and face (get face 'ediff-help-echo)))
+
+ (cond ((and is-current diff-num) ; current diff region
+ (format "Difference region %S -- current" (1+ diff-num)))
+ (face-help) ; refinement of current diff region
+ (diff-num ; non-current
+ (format "Difference region %S -- non-current" (1+ diff-num)))
+ (t "")) ; none
+ ))
+
+
+(defun ediff-set-face-pixmap (face pixmap)
+ "Set face pixmap on a monochrome display."
+ (if (and (ediff-window-display-p) (not (ediff-color-display-p)))
+ (condition-case nil
+ (set-face-background-pixmap face pixmap)
+ (error
+ (message "Pixmap not found for %S: %s" (face-name face) pixmap)
+ (sit-for 1)))))
+
+(defun ediff-hide-face (face)
+ (if (and (ediff-has-face-support-p)
+ (boundp 'add-to-list)
+ (boundp 'facemenu-unlisted-faces))
+ (add-to-list 'facemenu-unlisted-faces face)))
+
+
+
+(defface ediff-current-diff-A
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "firebrick" :background "pale green"))
+ (((class color))
+ (:foreground "blue3" :background "yellow3"))
+ (t (:inverse-video t)))
+ '((((type tty)) (:foreground "blue3" :background "yellow3"))
+ (((class color)) (:foreground "firebrick" :background "pale green"))
+ (t (:inverse-video t))))
+ "Face for highlighting the selected difference in buffer A."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-current-diff-face-A 'ediff-current-diff-A
+ "Face for highlighting the selected difference in buffer A.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-current-diff-A'
+this variable represents.")
+(ediff-hide-face ediff-current-diff-face-A)
+;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
+;; This means that some user customization may be trashed.
+(and (featurep 'xemacs)
+ (ediff-has-face-support-p)
+ (not (ediff-color-display-p))
+ (copy-face 'modeline ediff-current-diff-face-A))
+
+
+
+(defface ediff-current-diff-B
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "DarkOrchid" :background "Yellow"))
+ (((class color))
+ (:foreground "magenta3" :background "yellow3"
+ :weight bold))
+ (t (:inverse-video t)))
+ '((((type tty)) (:foreground "magenta3" :background "yellow3"
+ :weight bold))
+ (((class color)) (:foreground "DarkOrchid" :background "Yellow"))
+ (t (:inverse-video t))))
+ "Face for highlighting the selected difference in buffer B."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-current-diff-face-B 'ediff-current-diff-B
+ "Face for highlighting the selected difference in buffer B.
+ this variable. Instead, use the customization
+widget to customize the actual face `ediff-current-diff-B'
+this variable represents.")
+(ediff-hide-face ediff-current-diff-face-B)
+;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
+;; This means that some user customization may be trashed.
+(and (featurep 'xemacs)
+ (ediff-has-face-support-p)
+ (not (ediff-color-display-p))
+ (copy-face 'modeline ediff-current-diff-face-B))
+
+
+(defface ediff-current-diff-C
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "Navy" :background "Pink"))
+ (((class color))
+ (:foreground "cyan3" :background "yellow3" :weight bold))
+ (t (:inverse-video t)))
+ '((((type tty)) (:foreground "cyan3" :background "yellow3" :weight bold))
+ (((class color)) (:foreground "Navy" :background "Pink"))
+ (t (:inverse-video t))))
+ "Face for highlighting the selected difference in buffer C."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-current-diff-face-C 'ediff-current-diff-C
+ "Face for highlighting the selected difference in buffer C.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-current-diff-C'
+this variable represents.")
+(ediff-hide-face ediff-current-diff-face-C)
+;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
+;; This means that some user customization may be trashed.
+(and (featurep 'xemacs)
+ (ediff-has-face-support-p)
+ (not (ediff-color-display-p))
+ (copy-face 'modeline ediff-current-diff-face-C))
+
+
+(defface ediff-current-diff-Ancestor
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "Black" :background "VioletRed"))
+ (((class color))
+ (:foreground "black" :background "magenta3"))
+ (t (:inverse-video t)))
+ '((((type tty)) (:foreground "black" :background "magenta3"))
+ (((class color)) (:foreground "Black" :background "VioletRed"))
+ (t (:inverse-video t))))
+ "Face for highlighting the selected difference in buffer Ancestor."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-current-diff-face-Ancestor 'ediff-current-diff-Ancestor
+ "Face for highlighting the selected difference in buffer Ancestor.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-current-diff-Ancestor'
+this variable represents.")
+(ediff-hide-face ediff-current-diff-face-Ancestor)
+;; Until custom.el for XEmacs starts supporting :inverse-video we do this.
+;; This means that some user customization may be trashed.
+(and (featurep 'xemacs)
+ (ediff-has-face-support-p)
+ (not (ediff-color-display-p))
+ (copy-face 'modeline ediff-current-diff-face-Ancestor))
+
+
+(defface ediff-fine-diff-A
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "Navy" :background "sky blue"))
+ (((class color))
+ (:foreground "white" :background "sky blue" :weight bold))
+ (t (:underline t :stipple "gray3")))
+ '((((type tty)) (:foreground "white" :background "sky blue" :weight bold))
+ (((class color)) (:foreground "Navy" :background "sky blue"))
+ (t (:underline t :stipple "gray3"))))
+ "Face for highlighting the refinement of the selected diff in buffer A."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-fine-diff-face-A 'ediff-fine-diff-A
+ "Face for highlighting the fine differences in buffer A.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-fine-diff-A'
+this variable represents.")
+(ediff-hide-face ediff-fine-diff-face-A)
+
+(defface ediff-fine-diff-B
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "Black" :background "cyan"))
+ (((class color))
+ (:foreground "magenta3" :background "cyan3"))
+ (t (:underline t :stipple "gray3")))
+ '((((type tty)) (:foreground "magenta3" :background "cyan3"))
+ (((class color)) (:foreground "Black" :background "cyan"))
+ (t (:underline t :stipple "gray3"))))
+ "Face for highlighting the refinement of the selected diff in buffer B."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-fine-diff-face-B 'ediff-fine-diff-B
+ "Face for highlighting the fine differences in buffer B.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-fine-diff-B'
+this variable represents.")
+(ediff-hide-face ediff-fine-diff-face-B)
+
+(defface ediff-fine-diff-C
+ (if (featurep 'emacs)
+ '((((type pc))
+ (:foreground "white" :background "Turquoise"))
+ (((class color) (min-colors 16))
+ (:foreground "Black" :background "Turquoise"))
+ (((class color))
+ (:foreground "yellow3" :background "Turquoise"
+ :weight bold))
+ (t (:underline t :stipple "gray3")))
+ '((((type tty)) (:foreground "yellow3" :background "Turquoise"
+ :weight bold))
+ (((type pc)) (:foreground "white" :background "Turquoise"))
+ (((class color)) (:foreground "Black" :background "Turquoise"))
+ (t (:underline t :stipple "gray3"))))
+ "Face for highlighting the refinement of the selected diff in buffer C."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-fine-diff-face-C 'ediff-fine-diff-C
+ "Face for highlighting the fine differences in buffer C.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-fine-diff-C'
+this variable represents.")
+(ediff-hide-face ediff-fine-diff-face-C)
+
+(defface ediff-fine-diff-Ancestor
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "Black" :background "Green"))
+ (((class color))
+ (:foreground "red3" :background "green"))
+ (t (:underline t :stipple "gray3")))
+ '((((type tty)) (:foreground "red3" :background "green"))
+ (((class color)) (:foreground "Black" :background "Green"))
+ (t (:underline t :stipple "gray3"))))
+ "Face for highlighting the refinement of the selected diff in the ancestor buffer.
+At present, this face is not used and no fine differences are computed for the
+ancestor buffer."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-fine-diff-face-Ancestor 'ediff-fine-diff-Ancestor
+ "Face for highlighting the fine differences in buffer Ancestor.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-fine-diff-Ancestor'
+this variable represents.")
+(ediff-hide-face ediff-fine-diff-face-Ancestor)
+
+;; Some installs don't have stipple or Stipple. So, try them in turn.
+(defvar stipple-pixmap
+ (cond ((not (ediff-has-face-support-p)) nil)
+ ((and (boundp 'x-bitmap-file-path)
+ (locate-library "stipple" t x-bitmap-file-path)) "stipple")
+ ((and (boundp 'mswindowsx-bitmap-file-path)
+ (locate-library "stipple" t mswindowsx-bitmap-file-path)) "stipple")
+ (t "Stipple")))
+
+(defface ediff-even-diff-A
+ (if (featurep 'emacs)
+ `((((type pc))
+ (:foreground "green3" :background "light grey"))
+ (((class color) (min-colors 16))
+ (:foreground "Black" :background "light grey"))
+ (((class color))
+ (:foreground "red3" :background "light grey"
+ :weight bold))
+ (t (:italic t :stipple ,stipple-pixmap)))
+ `((((type tty)) (:foreground "red3" :background "light grey"
+ :weight bold))
+ (((type pc)) (:foreground "green3" :background "light grey"))
+ (((class color)) (:foreground "Black" :background "light grey"))
+ (t (:italic t :stipple ,stipple-pixmap))))
+ "Face for highlighting even-numbered non-current differences in buffer A."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-even-diff-face-A 'ediff-even-diff-A
+ "Face for highlighting even-numbered non-current differences in buffer A.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-even-diff-A'
+this variable represents.")
+(ediff-hide-face ediff-even-diff-face-A)
+
+(defface ediff-even-diff-B
+ (if (featurep 'emacs)
+ `((((class color) (min-colors 16))
+ (:foreground "White" :background "Grey"))
+ (((class color))
+ (:foreground "blue3" :background "Grey" :weight bold))
+ (t (:italic t :stipple ,stipple-pixmap)))
+ `((((type tty)) (:foreground "blue3" :background "Grey" :weight bold))
+ (((class color)) (:foreground "White" :background "Grey"))
+ (t (:italic t :stipple ,stipple-pixmap))))
+ "Face for highlighting even-numbered non-current differences in buffer B."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-even-diff-face-B 'ediff-even-diff-B
+ "Face for highlighting even-numbered non-current differences in buffer B.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-even-diff-B'
+this variable represents.")
+(ediff-hide-face ediff-even-diff-face-B)
+
+(defface ediff-even-diff-C
+ (if (featurep 'emacs)
+ `((((type pc))
+ (:foreground "yellow3" :background "light grey"))
+ (((class color) (min-colors 16))
+ (:foreground "Black" :background "light grey"))
+ (((class color))
+ (:foreground "yellow3" :background "light grey"
+ :weight bold))
+ (t (:italic t :stipple ,stipple-pixmap)))
+ `((((type tty)) (:foreground "yellow3" :background "light grey"
+ :weight bold))
+ (((type pc)) (:foreground "yellow3" :background "light grey"))
+ (((class color)) (:foreground "Black" :background "light grey"))
+ (t (:italic t :stipple ,stipple-pixmap))))
+ "Face for highlighting even-numbered non-current differences in buffer C."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-even-diff-face-C 'ediff-even-diff-C
+ "Face for highlighting even-numbered non-current differences in buffer C.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-even-diff-C'
+this variable represents.")
+(ediff-hide-face ediff-even-diff-face-C)
+
+(defface ediff-even-diff-Ancestor
+ (if (featurep 'emacs)
+ `((((type pc))
+ (:foreground "cyan3" :background "light grey"))
+ (((class color) (min-colors 16))
+ (:foreground "White" :background "Grey"))
+ (((class color))
+ (:foreground "cyan3" :background "light grey"
+ :weight bold))
+ (t (:italic t :stipple ,stipple-pixmap)))
+ `((((type tty)) (:foreground "cyan3" :background "light grey"
+ :weight bold))
+ (((type pc)) (:foreground "cyan3" :background "light grey"))
+ (((class color)) (:foreground "White" :background "Grey"))
+ (t (:italic t :stipple ,stipple-pixmap))))
+ "Face for highlighting even-numbered non-current differences in the ancestor buffer."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-even-diff-face-Ancestor 'ediff-even-diff-Ancestor
+ "Face for highlighting even-numbered non-current differences in buffer Ancestor.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-even-diff-Ancestor'
+this variable represents.")
+(ediff-hide-face ediff-even-diff-face-Ancestor)
+
+;; Association between buffer types and even-diff-face symbols
+(defconst ediff-even-diff-face-alist
+ '((A . ediff-even-diff-A)
+ (B . ediff-even-diff-B)
+ (C . ediff-even-diff-C)
+ (Ancestor . ediff-even-diff-Ancestor)))
+
+(defface ediff-odd-diff-A
+ (if (featurep 'emacs)
+ '((((type pc))
+ (:foreground "green3" :background "gray40"))
+ (((class color) (min-colors 16))
+ (:foreground "White" :background "Grey"))
+ (((class color))
+ (:foreground "red3" :background "black" :weight bold))
+ (t (:italic t :stipple "gray1")))
+ '((((type tty)) (:foreground "red3" :background "black" :weight bold))
+ (((type pc)) (:foreground "green3" :background "gray40"))
+ (((class color)) (:foreground "White" :background "Grey"))
+ (t (:italic t :stipple "gray1"))))
+ "Face for highlighting odd-numbered non-current differences in buffer A."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-odd-diff-face-A 'ediff-odd-diff-A
+ "Face for highlighting odd-numbered non-current differences in buffer A.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-odd-diff-A'
+this variable represents.")
+(ediff-hide-face ediff-odd-diff-face-A)
+
+
+(defface ediff-odd-diff-B
+ (if (featurep 'emacs)
+ '((((type pc))
+ (:foreground "White" :background "gray40"))
+ (((class color) (min-colors 16))
+ (:foreground "Black" :background "light grey"))
+ (((class color))
+ (:foreground "cyan3" :background "black" :weight bold))
+ (t (:italic t :stipple "gray1")))
+ '((((type tty)) (:foreground "cyan3" :background "black" :weight bold))
+ (((type pc)) (:foreground "White" :background "gray40"))
+ (((class color)) (:foreground "Black" :background "light grey"))
+ (t (:italic t :stipple "gray1"))))
+ "Face for highlighting odd-numbered non-current differences in buffer B."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-odd-diff-face-B 'ediff-odd-diff-B
+ "Face for highlighting odd-numbered non-current differences in buffer B.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-odd-diff-B'
+this variable represents.")
+(ediff-hide-face ediff-odd-diff-face-B)
+
+(defface ediff-odd-diff-C
+ (if (featurep 'emacs)
+ '((((type pc))
+ (:foreground "yellow3" :background "gray40"))
+ (((class color) (min-colors 16))
+ (:foreground "White" :background "Grey"))
+ (((class color))
+ (:foreground "yellow3" :background "black" :weight bold))
+ (t (:italic t :stipple "gray1")))
+ '((((type tty)) (:foreground "yellow3" :background "black" :weight bold))
+ (((type pc)) (:foreground "yellow3" :background "gray40"))
+ (((class color)) (:foreground "White" :background "Grey"))
+ (t (:italic t :stipple "gray1"))))
+ "Face for highlighting odd-numbered non-current differences in buffer C."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-odd-diff-face-C 'ediff-odd-diff-C
+ "Face for highlighting odd-numbered non-current differences in buffer C.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-odd-diff-C'
+this variable represents.")
+(ediff-hide-face ediff-odd-diff-face-C)
+
+(defface ediff-odd-diff-Ancestor
+ (if (featurep 'emacs)
+ '((((class color) (min-colors 16))
+ (:foreground "cyan3" :background "gray40"))
+ (((class color))
+ (:foreground "green3" :background "black" :weight bold))
+ (t (:italic t :stipple "gray1")))
+ '((((type tty)) (:foreground "green3" :background "black" :weight bold))
+ (((class color)) (:foreground "cyan3" :background "gray40"))
+ (t (:italic t :stipple "gray1"))))
+ "Face for highlighting odd-numbered non-current differences in the ancestor buffer."
+ :group 'ediff-highlighting)
+;; An internal variable. Ediff takes the face from here. When unhighlighting,
+;; this variable is set to nil, then again to the appropriate face.
+(defvar ediff-odd-diff-face-Ancestor 'ediff-odd-diff-Ancestor
+ "Face for highlighting odd-numbered non-current differences in buffer Ancestor.
+DO NOT CHANGE this variable. Instead, use the customization
+widget to customize the actual face object `ediff-odd-diff-Ancestor'
+this variable represents.")
+(ediff-hide-face ediff-odd-diff-face-Ancestor)
+
+;; Association between buffer types and odd-diff-face symbols
+(defconst ediff-odd-diff-face-alist
+ '((A . ediff-odd-diff-A)
+ (B . ediff-odd-diff-B)
+ (C . ediff-odd-diff-C)
+ (Ancestor . ediff-odd-diff-Ancestor)))
+
+;; A-list of fine-diff face symbols associated with buffer types
+(defconst ediff-fine-diff-face-alist
+ '((A . ediff-fine-diff-A)
+ (B . ediff-fine-diff-B)
+ (C . ediff-fine-diff-C)
+ (Ancestor . ediff-fine-diff-Ancestor)))
+
+;; Help echo
+(put ediff-fine-diff-face-A 'ediff-help-echo
+ "A `refinement' of the current difference region")
+(put ediff-fine-diff-face-B 'ediff-help-echo
+ "A `refinement' of the current difference region")
+(put ediff-fine-diff-face-C 'ediff-help-echo
+ "A `refinement' of the current difference region")
+(put ediff-fine-diff-face-Ancestor 'ediff-help-echo
+ "A `refinement' of the current difference region")
+
+(add-hook 'ediff-quit-hook 'ediff-cleanup-mess)
+(add-hook 'ediff-suspend-hook 'ediff-default-suspend-function)
+
+
+;;; Overlays
+
+(ediff-defvar-local ediff-current-diff-overlay-A nil
+ "Overlay for the current difference region in buffer A.")
+(ediff-defvar-local ediff-current-diff-overlay-B nil
+ "Overlay for the current difference region in buffer B.")
+(ediff-defvar-local ediff-current-diff-overlay-C nil
+ "Overlay for the current difference region in buffer C.")
+(ediff-defvar-local ediff-current-diff-overlay-Ancestor nil
+ "Overlay for the current difference region in the ancestor buffer.")
+
+;; Compute priority of a current ediff overlay.
+(defun ediff-highest-priority (start end buffer)
+ (let ((pos (max 1 (1- start)))
+ ovr-list)
+ (if (featurep 'xemacs)
+ (1+ ediff-shadow-overlay-priority)
+ (ediff-with-current-buffer buffer
+ (while (< pos (min (point-max) (1+ end)))
+ (setq ovr-list (append (overlays-at pos) ovr-list))
+ (setq pos (next-overlay-change pos)))
+ (+ 1 ediff-shadow-overlay-priority
+ (apply 'max
+ (cons
+ 1
+ (mapcar
+ (lambda (ovr)
+ (if (and ovr
+ ;; exclude ediff overlays from priority
+ ;; calculation, or else priority will keep
+ ;; increasing
+ (null (ediff-overlay-get ovr 'ediff))
+ (null (ediff-overlay-get ovr 'ediff-diff-num)))
+ ;; use the overlay priority or 0
+ (or (ediff-overlay-get ovr 'priority) 0)
+ 0))
+ ovr-list))))))))
+
+
+(defvar ediff-toggle-read-only-function nil
+ "*Specifies the function to be used to toggle read-only.
+If nil, Ediff tries to deduce the function from the binding of C-x C-q.
+Normally, this is the `toggle-read-only' function, but, if version
+control is used, it could be `vc-toggle-read-only' or `rcs-toggle-read-only'.")
+
+(defcustom ediff-make-buffers-readonly-at-startup nil
+ "Make all variant buffers read-only when Ediff starts up.
+This property can be toggled interactively."
+ :type 'boolean
+ :group 'ediff)
+
+
+;;; Misc
+
+;; if nil, this silences some messages
+(defvar ediff-verbose-p t)
+
+(defcustom ediff-autostore-merges 'group-jobs-only
+ "Save the results of merge jobs automatically.
+With value nil, don't save automatically. With value t, always
+save. Anything else means save automatically only if the merge
+job is part of a group of jobs, such as `ediff-merge-directory'
+or `ediff-merge-directory-revisions'."
+ :type '(choice (const nil) (const t) (const group-jobs-only))
+ :group 'ediff-merge)
+(make-variable-buffer-local 'ediff-autostore-merges)
+
+;; file where the result of the merge is to be saved. used internally
+(ediff-defvar-local ediff-merge-store-file nil "")
+
+(defcustom ediff-merge-filename-prefix "merge_"
+ "Prefix to be attached to saved merge buffers."
+ :type 'string
+ :group 'ediff-merge)
+
+(defcustom ediff-no-emacs-help-in-control-buffer nil
+ "Non-nil means C-h should not invoke Emacs help in control buffer.
+Instead, C-h would jump to previous difference."
+ :type 'boolean
+ :group 'ediff)
+
+;; This is the same as temporary-file-directory from Emacs 20.3.
+;; Copied over here because XEmacs doesn't have this variable.
+(defcustom ediff-temp-file-prefix
+ (file-name-as-directory
+ (cond ((boundp 'temporary-file-directory) temporary-file-directory)
+ ((fboundp 'temp-directory) (temp-directory))
+ (t "/tmp/")))
+;;; (file-name-as-directory
+;;; (cond ((memq system-type '(ms-dos windows-nt))
+;;; (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp"))
+;;; (t
+;;; (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
+ "Prefix to put on Ediff temporary file names.
+Do not start with `~/' or `~USERNAME/'."
+ :type 'string
+ :group 'ediff)
+
+(defcustom ediff-temp-file-mode 384 ; u=rw only
+ "Mode for Ediff temporary files."
+ :type 'integer
+ :group 'ediff)
+
+;; Metacharacters that have to be protected from the shell when executing
+;; a diff/diff3 command.
+(defcustom ediff-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]"
+ "Regexp that matches characters that must be quoted with `\\' in shell command line.
+This default should work without changes."
+ :type 'string
+ :group 'ediff)
+
+;; needed to simulate frame-char-width in XEmacs.
+(defvar ediff-H-glyph (if (featurep 'xemacs) (make-glyph "H")))
+
+
+;; Temporary file used for refining difference regions in buffer A.
+(ediff-defvar-local ediff-temp-file-A nil "")
+;; Temporary file used for refining difference regions in buffer B.
+(ediff-defvar-local ediff-temp-file-B nil "")
+;; Temporary file used for refining difference regions in buffer C.
+(ediff-defvar-local ediff-temp-file-C nil "")
+
+
+(defun ediff-file-remote-p (file-name)
+ (file-remote-p file-name))
+
+;; File for which we can get attributes, such as size or date
+(defun ediff-listable-file (file-name)
+ (let ((handler (find-file-name-handler file-name 'file-local-copy)))
+ (or (null handler) (eq handler 'dired-handler-fn))))
+
+
+(defsubst ediff-frame-unsplittable-p (frame)
+ (cdr (assq 'unsplittable (frame-parameters frame))))
+
+(defsubst ediff-get-next-window (wind prev-wind)
+ (cond ((window-live-p wind) wind)
+ (prev-wind (next-window wind))
+ (t (selected-window))
+ ))
+
+
+(defsubst ediff-kill-buffer-carefully (buf)
+ "Kill buffer BUF if it exists."
+ (if (ediff-buffer-live-p buf)
+ (kill-buffer (get-buffer buf))))
+
+(defsubst ediff-background-face (buf-type dif-num)
+ ;; The value of dif-num is always 1- the one that user sees.
+ ;; This is why even face is used when dif-num is odd.
+ (ediff-get-symbol-from-alist
+ buf-type (if (ediff-odd-p dif-num)
+ ediff-even-diff-face-alist
+ ediff-odd-diff-face-alist)
+ ))
+
+
+;; activate faces on diff regions in buffer
+(defun ediff-paint-background-regions-in-one-buffer (buf-type unhighlight)
+ (let ((diff-vector
+ (eval (ediff-get-symbol-from-alist
+ buf-type ediff-difference-vector-alist)))
+ overl diff-num)
+ (mapcar (lambda (rec)
+ (setq overl (ediff-get-diff-overlay-from-diff-record rec)
+ diff-num (ediff-overlay-get overl 'ediff-diff-num))
+ (if (ediff-overlay-buffer overl)
+ ;; only if overlay is alive
+ (ediff-set-overlay-face
+ overl
+ (if (not unhighlight)
+ (ediff-background-face buf-type diff-num))))
+ )
+ diff-vector)))
+
+
+;; activate faces on diff regions in all buffers
+(defun ediff-paint-background-regions (&optional unhighlight)
+ (ediff-paint-background-regions-in-one-buffer
+ 'A unhighlight)
+ (ediff-paint-background-regions-in-one-buffer
+ 'B unhighlight)
+ (ediff-paint-background-regions-in-one-buffer
+ 'C unhighlight)
+ (ediff-paint-background-regions-in-one-buffer
+ 'Ancestor unhighlight))
+
+
+;; arg is a record for a given diff in a difference vector
+;; this record is itself a vector
+(defsubst ediff-clear-fine-diff-vector (diff-record)
+ (if diff-record
+ (mapc 'ediff-delete-overlay
+ (ediff-get-fine-diff-vector-from-diff-record diff-record))))
+
+(defsubst ediff-clear-fine-differences-in-one-buffer (n buf-type)
+ (ediff-clear-fine-diff-vector (ediff-get-difference n buf-type))
+ (ediff-set-fine-diff-vector n buf-type nil))
+
+(defsubst ediff-clear-fine-differences (n)
+ (ediff-clear-fine-differences-in-one-buffer n 'A)
+ (ediff-clear-fine-differences-in-one-buffer n 'B)
+ (if ediff-3way-job
+ (ediff-clear-fine-differences-in-one-buffer n 'C)))
+
+
+(defsubst ediff-mouse-event-p (event)
+ (if (featurep 'xemacs)
+ (button-event-p event)
+ (string-match "mouse" (format "%S" (event-basic-type event)))))
+
+
+(defsubst ediff-key-press-event-p (event)
+ (if (featurep 'xemacs)
+ (key-press-event-p event)
+ (or (char-or-string-p event) (symbolp event))))
+
+(defun ediff-event-point (event)
+ (cond ((ediff-mouse-event-p event)
+ (if (featurep 'xemacs)
+ (event-point event)
+ (posn-point (event-start event))))
+ ((ediff-key-press-event-p event)
+ (point))
+ (t (error "Error"))))
+
+(defun ediff-event-buffer (event)
+ (cond ((ediff-mouse-event-p event)
+ (if (featurep 'xemacs)
+ (event-buffer event)
+ (window-buffer (posn-window (event-start event)))))
+ ((ediff-key-press-event-p event)
+ (current-buffer))
+ (t (error "Error"))))
+
+(defun ediff-event-key (event-or-key)
+ (if (featurep 'xemacs)
+ ;;(if (eventp event-or-key) (event-key event-or-key) event-or-key)
+ (if (eventp event-or-key) (event-to-character event-or-key t t) event-or-key)
+ event-or-key))
+
+(defun ediff-last-command-char ()
+ (ediff-event-key last-command-event))
+
+
+(defsubst ediff-frame-iconified-p (frame)
+ (and (ediff-window-display-p) (frame-live-p frame)
+ (if (featurep 'xemacs)
+ (frame-iconified-p frame)
+ (eq (frame-visible-p frame) 'icon))))
+
+(defsubst ediff-window-visible-p (wind)
+ ;; under TTY, window-live-p also means window is visible
+ (and (window-live-p wind)
+ (or (not (ediff-window-display-p))
+ (frame-visible-p (window-frame wind)))))
+
+
+(defsubst ediff-frame-char-width (frame)
+ (if (featurep 'xemacs)
+ (/ (frame-pixel-width frame) (frame-width frame))
+ (frame-char-width frame)))
+
+(defun ediff-reset-mouse (&optional frame do-not-grab-mouse)
+ (or frame (setq frame (selected-frame)))
+ (if (ediff-window-display-p)
+ (let ((frame-or-wind frame))
+ (if (featurep 'xemacs)
+ (setq frame-or-wind (frame-selected-window frame)))
+ (or do-not-grab-mouse
+ ;; don't set mouse if the user said to never do this
+ (not ediff-grab-mouse)
+ ;; Don't grab on quit, if the user doesn't want to.
+ ;; If ediff-grab-mouse = t, then mouse won't be grabbed for
+ ;; sessions that are not part of a group (this is done in
+ ;; ediff-recenter). The condition below affects only terminating
+ ;; sessions in session groups (in which case mouse is warped into
+ ;; a meta buffer).
+ (and (eq ediff-grab-mouse 'maybe)
+ (memq this-command '(ediff-quit ediff-update-diffs)))
+ (set-mouse-position frame-or-wind 1 0))
+ )))
+
+(defsubst ediff-spy-after-mouse ()
+ (setq ediff-mouse-pixel-position (mouse-pixel-position)))
+
+;; It is not easy to find out when the user grabs the mouse, since emacs and
+;; xemacs behave differently when mouse is not in any frame. Also, this is
+;; sensitive to when the user grabbed mouse. Not used for now.
+(defun ediff-user-grabbed-mouse ()
+ (if ediff-mouse-pixel-position
+ (cond ((not (eq (car ediff-mouse-pixel-position)
+ (car (mouse-pixel-position)))))
+ ((and (car (cdr ediff-mouse-pixel-position))
+ (car (cdr (mouse-pixel-position)))
+ (cdr (cdr ediff-mouse-pixel-position))
+ (cdr (cdr (mouse-pixel-position))))
+ (not (and (< (abs (- (car (cdr ediff-mouse-pixel-position))
+ (car (cdr (mouse-pixel-position)))))
+ ediff-mouse-pixel-threshold)
+ (< (abs (- (cdr (cdr ediff-mouse-pixel-position))
+ (cdr (cdr (mouse-pixel-position)))))
+ ediff-mouse-pixel-threshold))))
+ (t nil))))
+
+(defsubst ediff-frame-char-height (frame)
+ (if (featurep 'xemacs)
+ (glyph-height ediff-H-glyph (frame-selected-window frame))
+ (frame-char-height frame)))
+
+;; Some overlay functions
+
+(defsubst ediff-overlay-start (overl)
+ (if (ediff-overlayp overl)
+ (if (featurep 'xemacs)
+ (extent-start-position overl)
+ (overlay-start overl))))
+
+(defsubst ediff-overlay-end (overl)
+ (if (ediff-overlayp overl)
+ (if (featurep 'xemacs)
+ (extent-end-position overl)
+ (overlay-end overl))))
+
+(defsubst ediff-empty-overlay-p (overl)
+ (= (ediff-overlay-start overl) (ediff-overlay-end overl)))
+
+;; like overlay-buffer in Emacs. In XEmacs, returns nil if the extent is
+;; dead. Otherwise, works like extent-buffer
+(defun ediff-overlay-buffer (overl)
+ (if (featurep 'xemacs)
+ (and (extent-live-p overl) (extent-object overl))
+ (overlay-buffer overl)))
+
+;; like overlay-get in Emacs. In XEmacs, returns nil if the extent is
+;; dead. Otherwise, like extent-property
+(defun ediff-overlay-get (overl property)
+ (if (featurep 'xemacs)
+ (and (extent-live-p overl) (extent-property overl property))
+ (overlay-get overl property)))
+
+
+;; These two functions are here because XEmacs refuses to
+;; handle overlays whose buffers were deleted.
+(defun ediff-move-overlay (overlay beg end &optional buffer)
+ "Calls `move-overlay' in Emacs and `set-extent-endpoints' in Lemacs.
+Checks if overlay's buffer exists before actually doing the move."
+ (let ((buf (and overlay (ediff-overlay-buffer overlay))))
+ (if (ediff-buffer-live-p buf)
+ (if (featurep 'xemacs)
+ (set-extent-endpoints overlay beg end)
+ (move-overlay overlay beg end buffer))
+ ;; buffer's dead
+ (if overlay
+ (ediff-delete-overlay overlay)))))
+
+(defun ediff-overlay-put (overlay prop value)
+ "Calls `overlay-put' or `set-extent-property' depending on Emacs version.
+Checks if overlay's buffer exists."
+ (if (ediff-buffer-live-p (ediff-overlay-buffer overlay))
+ (if (featurep 'xemacs)
+ (set-extent-property overlay prop value)
+ (overlay-put overlay prop value))
+ (ediff-delete-overlay overlay)))
+
+;; temporarily uses DIR to abbreviate file name
+;; if DIR is nil, use default-directory
+(defun ediff-abbreviate-file-name (file &optional dir)
+ (cond ((stringp dir)
+ (let ((directory-abbrev-alist (list (cons dir ""))))
+ (abbreviate-file-name file)))
+ (t
+ (if (featurep 'xemacs)
+ ;; XEmacs requires addl argument
+ (abbreviate-file-name file t)
+ (abbreviate-file-name file)))))
+
+;; Takes a directory and returns the parent directory.
+;; does nothing to `/'. If the ARG is a regular file,
+;; strip the file AND the last dir.
+(defun ediff-strip-last-dir (dir)
+ (if (not (stringp dir)) (setq dir default-directory))
+ (setq dir (expand-file-name dir))
+ (or (file-directory-p dir) (setq dir (file-name-directory dir)))
+ (let* ((pos (1- (length dir)))
+ (last-char (aref dir pos)))
+ (if (and (> pos 0) (= last-char ?/))
+ (setq dir (substring dir 0 pos)))
+ (ediff-abbreviate-file-name (file-name-directory dir))))
+
+(defun ediff-truncate-string-left (str newlen)
+ ;; leave space for ... on the left
+ (let ((len (length str))
+ substr)
+ (if (<= len newlen)
+ str
+ (setq newlen (max 0 (- newlen 3)))
+ (setq substr (substring str (max 0 (- len 1 newlen))))
+ (concat "..." substr))))
+
+(defsubst ediff-nonempty-string-p (string)
+ (and (stringp string) (not (string= string ""))))
+
+(unless (fboundp 'subst-char-in-string)
+ (defun subst-char-in-string (fromchar tochar string &optional inplace)
+ "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
+Unless optional argument INPLACE is non-nil, return a new string."
+ (let ((i (length string))
+ (newstr (if inplace string (copy-sequence string))))
+ (while (> i 0)
+ (setq i (1- i))
+ (if (eq (aref newstr i) fromchar)
+ (aset newstr i tochar)))
+ newstr)))
+
+(defun ediff-abbrev-jobname (jobname)
+ (cond ((eq jobname 'ediff-directories)
+ "Compare two directories")
+ ((eq jobname 'ediff-files)
+ "Compare two files")
+ ((eq jobname 'ediff-buffers)
+ "Compare two buffers")
+ ((eq jobname 'ediff-directories3)
+ "Compare three directories")
+ ((eq jobname 'ediff-files3)
+ "Compare three files")
+ ((eq jobname 'ediff-buffers3)
+ "Compare three buffers")
+ ((eq jobname 'ediff-revision)
+ "Compare file with a version")
+ ((eq jobname 'ediff-directory-revisions)
+ "Compare dir files with versions")
+ ((eq jobname 'ediff-merge-directory-revisions)
+ "Merge dir files with versions")
+ ((eq jobname 'ediff-merge-directory-revisions-with-ancestor)
+ "Merge dir versions via ancestors")
+ (t
+ (capitalize
+ (subst-char-in-string ?- ?\s (substring (symbol-name jobname) 6))))
+ ))
+
+
+;; If ediff modified mode line, strip the modification
+(defsubst ediff-strip-mode-line-format ()
+ (if (member (car mode-line-format) '(" A: " " B: " " C: " " Ancestor: "))
+ (setq mode-line-format (nth 2 mode-line-format))))
+
+;; Verify that we have a difference selected.
+(defsubst ediff-valid-difference-p (&optional n)
+ (or n (setq n ediff-current-difference))
+ (and (>= n 0) (< n ediff-number-of-differences)))
+
+(defsubst ediff-show-all-diffs (n)
+ "Don't skip difference regions."
+ nil)
+
+(defsubst ediff-message-if-verbose (string &rest args)
+ (if ediff-verbose-p
+ (apply 'message string args)))
+
+(defun ediff-file-attributes (filename attr-number)
+ (if (ediff-listable-file filename)
+ (nth attr-number (file-attributes filename))
+ -1)
+ )
+
+(defsubst ediff-file-size (filename)
+ (ediff-file-attributes filename 7))
+(defsubst ediff-file-modtime (filename)
+ (ediff-file-attributes filename 5))
+
+
+(defun ediff-convert-standard-filename (fname)
+ (if (fboundp 'convert-standard-filename)
+ (convert-standard-filename fname)
+ fname))
+
+(if (featurep 'emacs)
+ (defalias 'ediff-with-syntax-table 'with-syntax-table)
+ (if (fboundp 'with-syntax-table)
+ (defalias 'ediff-with-syntax-table 'with-syntax-table)
+ ;; stolen from subr.el in emacs 21
+ (defmacro ediff-with-syntax-table (table &rest body)
+ (let ((old-table (make-symbol "table"))
+ (old-buffer (make-symbol "buffer")))
+ `(let ((,old-table (syntax-table))
+ (,old-buffer (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-syntax-table (copy-syntax-table ,table))
+ ,@body)
+ (save-current-buffer
+ (set-buffer ,old-buffer)
+ (set-syntax-table ,old-table))))))))
+
+
+(provide 'ediff-init)
+
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: fa31d384-1e70-4d4b-82a7-3e96307c46f5
+;;; ediff-init.el ends here
--- /dev/null
+;;; ediff-merg.el --- merging utilities
+
+;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+;; compiler pacifier
+(defvar ediff-window-A)
+(defvar ediff-window-B)
+(defvar ediff-window-C)
+(defvar ediff-merge-window-share)
+(defvar ediff-window-config-saved)
+
+(eval-when-compile
+ (require 'ediff-util))
+;; end pacifier
+
+(require 'ediff-init)
+
+(defcustom ediff-quit-merge-hook 'ediff-maybe-save-and-delete-merge
+ "Hooks to run before quitting a merge job.
+The most common use is to save and delete the merge buffer."
+ :type 'hook
+ :group 'ediff-merge)
+
+
+(defcustom ediff-default-variant 'combined
+ "The variant to be used as a default for buffer C in merging.
+Valid values are the symbols `default-A', `default-B', and `combined'."
+ :type '(radio (const default-A) (const default-B) (const combined))
+ :group 'ediff-merge)
+
+(defcustom ediff-combination-pattern
+ '("<<<<<<< variant A" A ">>>>>>> variant B" B "####### Ancestor" Ancestor "======= end")
+ "Pattern to be used for combining difference regions in buffers A and B.
+The value must be a list of the form
+\(STRING1 bufspec1 STRING2 bufspec2 STRING3 bufspec3 STRING4)
+where bufspec is the symbol A, B, or Ancestor. For instance, if the value is
+'(STRING1 A STRING2 Ancestor STRING3 B STRING4) then the
+combined text will look like this:
+
+STRING1
+diff region from variant A
+STRING2
+diff region from the ancestor
+STRING3
+diff region from variant B
+STRING4
+"
+ :type '(choice (list string symbol string symbol string)
+ (list string symbol string symbol string symbol string))
+ :group 'ediff-merge)
+
+(defcustom ediff-show-clashes-only nil
+ "If t, show only those diff regions where both buffers disagree with the ancestor.
+This means that regions that have status prefer-A or prefer-B will be
+skipped over. A value of nil means show all regions."
+ :type 'boolean
+ :group 'ediff-merge
+ )
+(make-variable-buffer-local 'ediff-show-clashes-only)
+
+(defcustom ediff-skip-merge-regions-that-differ-from-default nil
+ "If t, show only the regions that have not been changed by the user.
+A region is considered to have been changed if it is different from the current
+default (`default-A', `default-B', `combined') and it hasn't been marked as
+`prefer-A' or `prefer-B'.
+A region is considered to have been changed also when it is marked as
+as `prefer-A', but is different from the corresponding difference region in
+Buffer A or if it is marked as `prefer-B' and is different from the region in
+Buffer B."
+ :type 'boolean
+ :group 'ediff-merge
+ )
+(make-variable-buffer-local 'ediff-skip-merge-regions-that-differ-from-default)
+
+;; check if there is no clash between the ancestor and one of the variants.
+;; if it is not a merge job then return true
+(defun ediff-merge-region-is-non-clash (n)
+ (if (ediff-merge-job)
+ (string-match "prefer" (or (ediff-get-state-of-merge n) ""))
+ t))
+
+;; If ediff-show-clashes-only, check if there is no clash between the ancestor
+;; and one of the variants.
+(defun ediff-merge-region-is-non-clash-to-skip (n)
+ (and (ediff-merge-job)
+ ediff-show-clashes-only
+ (ediff-merge-region-is-non-clash n)))
+
+;; If ediff-skip-changed-regions, check if the merge region differs from
+;; the current default. If a region is different from the default, it means
+;; that the user has made determination as to how to merge for this particular
+;; region.
+(defun ediff-skip-merge-region-if-changed-from-default-p (n)
+ (and (ediff-merge-job)
+ ediff-skip-merge-regions-that-differ-from-default
+ (ediff-merge-changed-from-default-p n 'prefers-too)))
+
+
+(defun ediff-get-combined-region (n)
+ (let ((pattern-list ediff-combination-pattern)
+ (combo-region "")
+ (err-msg
+ "ediff-combination-pattern: Invalid format. Please consult the documentation")
+ region-delim region-spec)
+
+ (if (< (length pattern-list) 5)
+ (error err-msg))
+
+ (while (> (length pattern-list) 2)
+ (setq region-delim (nth 0 pattern-list)
+ region-spec (nth 1 pattern-list))
+ (or (and (stringp region-delim) (memq region-spec '(A B Ancestor)))
+ (error err-msg))
+
+ (condition-case nil
+ (setq combo-region
+ (concat combo-region
+ region-delim "\n"
+ (ediff-get-region-contents
+ n region-spec ediff-control-buffer)))
+ (error ""))
+ (setq pattern-list (cdr (cdr pattern-list)))
+ )
+
+ (setq region-delim (nth 0 pattern-list))
+ (or (stringp region-delim)
+ (error err-msg))
+ (setq combo-region (concat combo-region region-delim "\n"))
+ ))
+
+;;(defsubst ediff-make-combined-diff (regA regB)
+;; (concat (nth 0 ediff-combination-pattern) "\n"
+;; regA
+;; (nth 1 ediff-combination-pattern) "\n"
+;; regB
+;; (nth 2 ediff-combination-pattern) "\n"))
+
+(defsubst ediff-set-state-of-all-diffs-in-all-buffers (ctl-buf)
+ (let ((n 0))
+ (while (< n ediff-number-of-differences)
+ (ediff-set-state-of-diff-in-all-buffers n ctl-buf)
+ (setq n (1+ n)))))
+
+(defun ediff-set-state-of-diff-in-all-buffers (n ctl-buf)
+ (let ((regA (ediff-get-region-contents n 'A ctl-buf))
+ (regB (ediff-get-region-contents n 'B ctl-buf))
+ (regC (ediff-get-region-contents n 'C ctl-buf)))
+ (cond ((and (string= regA regB) (string= regA regC))
+ (ediff-set-state-of-diff n 'A "=diff(B)")
+ (ediff-set-state-of-diff n 'B "=diff(C)")
+ (ediff-set-state-of-diff n 'C "=diff(A)"))
+ ((string= regA regB)
+ (ediff-set-state-of-diff n 'A "=diff(B)")
+ (ediff-set-state-of-diff n 'B "=diff(A)")
+ (ediff-set-state-of-diff n 'C nil))
+ ((string= regA regC)
+ (ediff-set-state-of-diff n 'A "=diff(C)")
+ (ediff-set-state-of-diff n 'C "=diff(A)")
+ (ediff-set-state-of-diff n 'B nil))
+ ((string= regB regC)
+ (ediff-set-state-of-diff n 'C "=diff(B)")
+ (ediff-set-state-of-diff n 'B "=diff(C)")
+ (ediff-set-state-of-diff n 'A nil))
+ ((string= regC (ediff-get-combined-region n))
+ (ediff-set-state-of-diff n 'A nil)
+ (ediff-set-state-of-diff n 'B nil)
+ (ediff-set-state-of-diff n 'C "=diff(A+B)"))
+ (t (ediff-set-state-of-diff n 'A nil)
+ (ediff-set-state-of-diff n 'B nil)
+ (ediff-set-state-of-diff n 'C nil)))
+ ))
+
+(defun ediff-set-merge-mode ()
+ (normal-mode t)
+ (remove-hook 'local-write-file-hooks 'ediff-set-merge-mode))
+
+
+;; Go over all diffs starting with DIFF-NUM and copy regions into buffer C
+;; according to the state of the difference.
+;; Since ediff-copy-diff refuses to copy identical diff regions, there is
+;; no need to optimize ediff-do-merge any further.
+;;
+;; If re-merging, change state of merge in all diffs starting with
+;; DIFF-NUM, except those where the state is prefer-* or where it is
+;; `default-*' or `combined' but the buf C region appears to be modified
+;; since last set by default.
+(defun ediff-do-merge (diff-num &optional remerging)
+ (if (< diff-num 0) (setq diff-num 0))
+ (let ((n diff-num)
+ ;;(default-state-of-merge (format "%S" ediff-default-variant))
+ do-not-copy state-of-merge)
+ (while (< n ediff-number-of-differences)
+ (setq do-not-copy nil) ; reset after each cycle
+ (if (= (mod n 10) 0)
+ (message "%s buffers A & B into C ... region %d of %d"
+ (if remerging "Re-merging" "Merging")
+ n
+ ediff-number-of-differences))
+
+ (setq state-of-merge (ediff-get-state-of-merge n))
+
+ (if remerging
+ ;;(let ((reg-A (ediff-get-region-contents n 'A ediff-control-buffer))
+ ;; (reg-B (ediff-get-region-contents n 'B ediff-control-buffer))
+ ;; (reg-C (ediff-get-region-contents n 'C ediff-control-buffer)))
+ (progn
+
+ ;; if region was edited since it was first set by default
+ (if (or (ediff-merge-changed-from-default-p n)
+ ;; was preferred
+ (string-match "prefer" state-of-merge))
+ ;; then ignore
+ (setq do-not-copy t))
+
+ ;; change state of merge for this diff, if necessary
+ (if (and (string-match "\\(default\\|combined\\)" state-of-merge)
+ (not do-not-copy))
+ (ediff-set-state-of-merge
+ n (format "%S" ediff-default-variant)))
+ ))
+
+ ;; state-of-merge may have changed via ediff-set-state-of-merge, so
+ ;; check it once again
+ (setq state-of-merge (ediff-get-state-of-merge n))
+
+ (or do-not-copy
+ (if (string= state-of-merge "combined")
+ ;; use n+1 because ediff-combine-diffs works via user numbering
+ ;; of diffs, which is 1+ to what ediff uses internally
+ (ediff-combine-diffs (1+ n) 'batch)
+ (ediff-copy-diff
+ n (if (string-match "-A" state-of-merge) 'A 'B) 'C 'batch)))
+ (setq n (1+ n)))
+ (message "Merging buffers A & B into C ... Done")
+ ))
+
+
+(defun ediff-re-merge ()
+ "Remerge unmodified diff regions using a new default. Start with the current region."
+ (interactive)
+ (let* ((default-variant-alist
+ (list '("default-A") '("default-B") '("combined")))
+ (actual-alist
+ (delete (list (symbol-name ediff-default-variant))
+ default-variant-alist)))
+ (setq ediff-default-variant
+ (intern
+ (completing-read
+ (format "Current merge default is `%S'. New default: "
+ ediff-default-variant)
+ actual-alist nil 'must-match)))
+ (ediff-do-merge ediff-current-difference 'remerge)
+ (ediff-recenter)
+ ))
+
+(defun ediff-shrink-window-C (arg)
+ "Shrink window C to just one line.
+With a prefix argument, returns window C to its normal size.
+Used only for merging jobs."
+ (interactive "P")
+ (if (not ediff-merge-job)
+ (error "ediff-shrink-window-C can be used only for merging jobs"))
+ (cond ((eq arg '-) (setq arg -1))
+ ((not (numberp arg)) (setq arg nil)))
+ (cond ((null arg)
+ (let ((ediff-merge-window-share
+ (if (< (window-height ediff-window-C) 3)
+ ediff-merge-window-share 0)))
+ (setq ediff-window-config-saved "") ; force redisplay
+ (ediff-recenter 'no-rehighlight)))
+ ((and (< arg 0) (> (window-height ediff-window-C) 2))
+ (setq ediff-merge-window-share (* ediff-merge-window-share 0.9))
+ (setq ediff-window-config-saved "") ; force redisplay
+ (ediff-recenter 'no-rehighlight))
+ ((and (> arg 0) (> (window-height ediff-window-A) 2))
+ (setq ediff-merge-window-share (* ediff-merge-window-share 1.1))
+ (setq ediff-window-config-saved "") ; force redisplay
+ (ediff-recenter 'no-rehighlight))))
+
+
+;; N here is the user's region number. It is 1+ what Ediff uses internally.
+(defun ediff-combine-diffs (n &optional batch-invocation)
+ "Combine Nth diff regions of buffers A and B and place the combination in C.
+N is a prefix argument. If nil, combine the current difference regions.
+Combining is done according to the specifications in variable
+`ediff-combination-pattern'."
+ (interactive "P")
+ (setq n (if (numberp n) (1- n) ediff-current-difference))
+
+ (let (reg-combined)
+ ;;(setq regA (ediff-get-region-contents n 'A ediff-control-buffer)
+ ;; regB (ediff-get-region-contents n 'B ediff-control-buffer))
+ ;;(setq reg-combined (ediff-make-combined-diff regA regB))
+ (setq reg-combined (ediff-get-combined-region n))
+
+ (ediff-copy-diff n nil 'C batch-invocation reg-combined))
+ (or batch-invocation (ediff-jump-to-difference (1+ n))))
+
+
+;; Checks if the region in buff C looks like a combination of the regions
+;; in buffers A and B. Return a list (reg-a-beg reg-a-end reg-b-beg reg-b-end)
+;; These refer to where the delimiters for region A, B, Ancestor start and end
+;; in buffer C
+(defun ediff-looks-like-combined-merge (region-num)
+ (if ediff-merge-job
+ (let ((combined (string-match (regexp-quote "(A+B)")
+ (or (ediff-get-state-of-diff region-num 'C)
+ "")))
+ (mrgreg-beg (ediff-get-diff-posn 'C 'beg region-num))
+ (mrgreg-end (ediff-get-diff-posn 'C 'end region-num))
+ (pattern-list ediff-combination-pattern)
+ delim reg-beg reg-end delim-regs-list)
+
+ (if combined
+ (ediff-with-current-buffer ediff-buffer-C
+ (while pattern-list
+ (goto-char mrgreg-beg)
+ (setq delim (nth 0 pattern-list))
+ (search-forward delim mrgreg-end 'noerror)
+ (setq reg-beg (match-beginning 0))
+ (setq reg-end (match-end 0))
+ (if (and reg-beg reg-end)
+ (setq delim-regs-list
+ ;; in reverse
+ (cons reg-end (cons reg-beg delim-regs-list))))
+ (if (> (length pattern-list) 1)
+ (setq pattern-list (cdr (cdr pattern-list)))
+ (setq pattern-list nil))
+ )))
+
+ (reverse delim-regs-list)
+ )))
+
+(defvar state-of-merge) ; dynamic var
+
+;; Check if the non-preferred merge has been modified since originally set.
+;; This affects only the regions that are marked as default-A/B or combined.
+;; If PREFERS-TOO is non-nil, then look at the regions marked as prefers-A/B as
+;; well.
+(defun ediff-merge-changed-from-default-p (diff-num &optional prefers-too)
+ (let ((reg-A (ediff-get-region-contents diff-num 'A ediff-control-buffer))
+ (reg-B (ediff-get-region-contents diff-num 'B ediff-control-buffer))
+ (reg-C (ediff-get-region-contents diff-num 'C ediff-control-buffer)))
+
+ (setq state-of-merge (ediff-get-state-of-merge diff-num))
+
+ ;; if region was edited since it was first set by default
+ (or (and (string= state-of-merge "default-A")
+ (not (string= reg-A reg-C)))
+ (and (string= state-of-merge "default-B")
+ (not (string= reg-B reg-C)))
+ (and (string= state-of-merge "combined")
+ ;;(not (string= (ediff-make-combined-diff reg-A reg-B) reg-C)))
+ (not (string= (ediff-get-combined-region diff-num) reg-C)))
+ (and prefers-too
+ (string= state-of-merge "prefer-A")
+ (not (string= reg-A reg-C)))
+ (and prefers-too
+ (string= state-of-merge "prefer-B")
+ (not (string= reg-B reg-C)))
+ )))
+
+
+(provide 'ediff-merg)
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: 9b798cf9-02ba-487f-a62e-b63aa823dbfb
+;;; ediff-merg.el ends here
--- /dev/null
+;;; ediff-mult.el --- support for multi-file/multi-buffer processing in Ediff
+
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Users are encouraged to add functionality to this file.
+;; The present file contains all the infrastructure needed for that.
+;;
+;; Generally, to implement a new multisession capability within Ediff,
+;; you need to tell it
+;;
+;; 1. How to display the session group buffer.
+;; This function must indicate which Ediff sessions are active (+) and
+;; which are finished (-).
+;; See ediff-redraw-directory-group-buffer for an example.
+;; In all likelihood, ediff-redraw-directory-group-buffer can be used
+;; directly or after a small modification.
+;; 2. What action to take when the user clicks button 2 or types v,e, or
+;; RET. See ediff-filegroup-action.
+;; 3. Provide a list of pairs or triples of file names (or buffers,
+;; depending on the particular Ediff operation you want to invoke)
+;; in the following format:
+;; (HEADER (nil nil (obj1 nil) (obj2 nil) (obj3 nil))
+;; (...) ...)
+;; The function ediff-make-new-meta-list-element can be used to create
+;; 2nd and subsequent elements of that list (i.e., after the
+;; description header). See ediff-make-new-meta-list-element for the
+;; explanation of the two nil placeholders in such elements.
+;;
+;; There is API for extracting the components of the members of the
+;; above list. Search for `API for ediff-meta-list' for details.
+;;
+;; HEADER must be a list of SIX elements (nil or string):
+;; (regexp metaobj1 metaobj2 metaobj3 merge-save-buffer
+;; comparison-function)
+;; The function ediff-redraw-registry-buffer displays the
+;; 1st - 4th of these in the registry buffer.
+;; For some jobs some of the members of the header might be nil.
+;; The meaning of metaobj1, metaobj2, and metaobj3 depend on the job.
+;; Typically these are directories where the files to be compared are
+;; found.
+;; Also, keep in mind that the function ediff-prepare-meta-buffer
+;; (which see) prepends the session group buffer to the descriptor, so
+;; the descriptor becomes 7-long.
+;; Ediff expects that your function (in 2 above) will arrange to
+;; replace this prepended nil (via setcar) with the actual ediff
+;; control buffer associated with an appropriate Ediff session.
+;; This is arranged through internal startup hooks that can be passed
+;; to any of Ediff major entries (such as ediff-files, epatch, etc.).
+;; See how this is done in ediff-filegroup-action.
+;;
+;; Session descriptions are of the form
+;; (nil nil (obj1 . nil) (obj2 . nil) (obj3 . nil))
+;; which describe the objects relevant to the session.
+;; Use ediff-make-new-meta-list-element to create these things.
+;; Usually obj1/2/3 are names of files, but they may also be other
+;; things for some jobs. For instance, obj3 is nil for jobs that
+;; involve only two files. For patch jobs, obj2 and obj3 are markers
+;; that specify the patch corresponding to the file
+;; (whose name is obj1).
+;; The nil's are placeholders, which are used internally by ediff.
+;; 4. Write a function that makes a call to ediff-prepare-meta-buffer
+;; passing all this info.
+;; You may be able to use ediff-directories-internal as a template.
+;; 5. If you intend to add several related pieces of functionality,
+;; you may want to keep the function in 4 as an internal version
+;; and then write several top-level interactive functions that call it
+;; with different parameters.
+;; See how ediff-directories, ediff-merge-directories, and
+;; ediff-merge-directories-with-ancestor all use
+;; ediff-directories-internal.
+;;
+;; A useful addition here could be session groups selected by patterns
+;; (which are different in each directory). For instance, one may want to
+;; compare files of the form abc{something}.c to files old{something}.d
+;; which may be in the same or different directories. Or, one may want to
+;; compare all files of the form {something} to files of the form {something}~.
+;;
+;; Implementing this requires writing a collating function, which should pair
+;; up appropriate files. It will also require a generalization of the
+;; functions that do the layout of the meta- and differences buffers and of
+;; ediff-filegroup-action.
+
+;;; Code:
+
+
+(provide 'ediff-mult)
+
+(defgroup ediff-mult nil
+ "Multi-file and multi-buffer processing in Ediff."
+ :prefix "ediff-"
+ :group 'ediff)
+
+
+;; compiler pacifier
+(eval-when-compile
+ (require 'ediff-ptch)
+ (require 'ediff))
+;; end pacifier
+
+(require 'ediff-init)
+
+;; meta-buffer
+(ediff-defvar-local ediff-meta-buffer nil "")
+(ediff-defvar-local ediff-parent-meta-buffer nil "")
+;; the registry buffer
+(defvar ediff-registry-buffer nil)
+
+(defconst ediff-meta-buffer-brief-message "Ediff Session Group Panel: %s
+
+ Type ? to show useful commands in this buffer
+
+")
+
+(defconst ediff-meta-buffer-verbose-message "Ediff Session Group Panel: %s
+
+Useful commands (type ? to hide them and free up screen):
+ button2, v, or RET over session record: start that Ediff session
+ M:\tin sessions invoked from here, brings back this group panel
+ R:\tdisplay the registry of active Ediff sessions
+ h:\tmark session for hiding (toggle)
+ x:\thide marked sessions; with prefix arg: unhide
+ m:\tmark session for a non-hiding operation (toggle)
+ uh/um:\tunmark all sessions marked for hiding/operation
+ n,SPC:\tnext session
+ p,DEL:\tprevious session
+ E:\tbrowse Ediff on-line manual
+ T:\ttoggle truncation of long file names
+ q:\tquit this session group
+")
+
+(ediff-defvar-local ediff-meta-buffer-map nil
+ "The keymap for the meta buffer.")
+(defvar ediff-dir-diffs-buffer-map (make-sparse-keymap)
+ "The keymap to be installed in the buffer showing differences between
+directories.")
+
+;; Variable specifying the action to take when the use invokes ediff in the
+;; meta buffer. This is usually ediff-registry-action or ediff-filegroup-action
+(ediff-defvar-local ediff-meta-action-function nil "")
+;; Tells ediff-update-meta-buffer how to redraw it
+(ediff-defvar-local ediff-meta-redraw-function nil "")
+;; Tells ediff-filegroup-action and similar procedures how to invoke Ediff for
+;; the sessions in a given session group
+(ediff-defvar-local ediff-session-action-function nil "")
+
+(ediff-defvar-local ediff-metajob-name nil "")
+
+;; buffer used to collect custom diffs from individual sessions in the group
+(ediff-defvar-local ediff-meta-diff-buffer nil "")
+
+;; t means recurse into subdirs when deciding which files have same contents
+(ediff-defvar-local ediff-recurse-to-subdirectories nil "")
+
+;; history var to use for filtering groups of files
+(defvar ediff-filtering-regexp-history nil "")
+
+(defcustom ediff-default-filtering-regexp nil
+ "The default regular expression used as a filename filter in multifile comparisons.
+Should be a sexp. For instance (car ediff-filtering-regexp-history) or nil."
+ :type 'sexp
+ :group 'ediff-mult)
+
+;; This has the form ((meta-buf regexp dir1 dir2 dir3 merge-auto-store-dir)
+;; (ctl-buf session-status (file1 . eq-status) (file2 . eq-status) (file3
+;; . eq-status)) (ctl-buf session-status (file1 . eq-status) (file2
+;; . eq-status)) ...)
+;; If ctl-buf is nil, the file-pair hasn't processed yet. If it is
+;; killed-buffer object, the file pair has been processed. If it is a live
+;; buffer, this means ediff is still working on the pair.
+;; Eq-status of a file is t if the file equals some other file in the same
+;; group.
+(ediff-defvar-local ediff-meta-list nil "")
+
+(ediff-defvar-local ediff-meta-session-number nil "")
+
+
+;; the difference list between directories in a directory session group
+(ediff-defvar-local ediff-dir-difference-list nil "")
+(ediff-defvar-local ediff-dir-diffs-buffer nil "")
+
+;; The registry of Ediff sessions. A list of control buffers.
+(defvar ediff-session-registry nil)
+
+(defcustom ediff-meta-truncate-filenames t
+ "If non-nil, truncate long file names in the session group buffers.
+This can be toggled with `ediff-toggle-filename-truncation'."
+ :type 'boolean
+ :group 'ediff-mult)
+
+(defcustom ediff-meta-mode-hook nil
+ "Hooks run just after setting up meta mode."
+ :type 'hook
+ :group 'ediff-mult)
+
+(defcustom ediff-registry-setup-hook nil
+ "Hooks run just after the registry control panel is set up."
+ :type 'hook
+ :group 'ediff-mult)
+
+(defcustom ediff-before-session-group-setup-hooks nil
+ "Hooks to run before Ediff arranges the window for group-level operations.
+It is used by commands such as `ediff-directories'.
+This hook can be used to save the previous window config, which can be restored
+on `ediff-quit', `ediff-suspend', or `ediff-quit-session-group-hook'."
+ :type 'hook
+ :group 'ediff-hook)
+(defcustom ediff-after-session-group-setup-hook nil
+ "Hooks run just after a meta-buffer controlling a session group, such as
+ediff-directories, is run."
+ :type 'hook
+ :group 'ediff-mult)
+(defcustom ediff-quit-session-group-hook nil
+ "Hooks run just before exiting a session group."
+ :type 'hook
+ :group 'ediff-mult)
+(defcustom ediff-show-registry-hook nil
+ "Hooks run just after the registry buffer is shown."
+ :type 'hook
+ :group 'ediff-mult)
+(defcustom ediff-show-session-group-hook '(delete-other-windows)
+ "Hooks run just after a session group buffer is shown."
+ :type 'hook
+ :group 'ediff-mult)
+(defcustom ediff-meta-buffer-keymap-setup-hook nil
+ "Hooks run just after setting up the `ediff-meta-buffer-map'.
+This keymap controls key bindings in the meta buffer and is a local variable.
+This means that you can set different bindings for different kinds of meta
+buffers."
+ :type 'hook
+ :group 'ediff-mult)
+
+;; Buffer holding the multi-file patch. Local to the meta buffer
+(ediff-defvar-local ediff-meta-patchbufer nil "")
+
+;;; API for ediff-meta-list
+
+;; A meta-list is either ediff-meta-list, which contains a header and the list
+;; of ediff sessions or ediff-dir-difference-list, which is a header followed
+;; by the list of differences among the directories (i.e., files that are not
+;; in all directories). The header is the same in all meta lists, but the rest
+;; is different.
+;; Structure of the meta-list:
+;; (HEADER SESSION1 SESSION2 ...)
+;; HEADER: (GROUP-BUF REGEXP OBJA OBJB OBJC SAVE-DIR COMPARISON-FUNC)
+;; OBJA - first directory
+;; OBJB - second directory
+;; OBJC - third directory
+;; SESSION1/2/... are described below
+;; group buffer/regexp
+(defsubst ediff-get-group-buffer (meta-list)
+ (nth 0 (car meta-list)))
+
+(defsubst ediff-get-group-regexp (meta-list)
+ (nth 1 (car meta-list)))
+;; group objects
+(defsubst ediff-get-group-objA (meta-list)
+ (nth 2 (car meta-list)))
+(defsubst ediff-get-group-objB (meta-list)
+ (nth 3 (car meta-list)))
+(defsubst ediff-get-group-objC (meta-list)
+ (nth 4 (car meta-list)))
+(defsubst ediff-get-group-merge-autostore-dir (meta-list)
+ (nth 5 (car meta-list)))
+(defsubst ediff-get-group-comparison-func (meta-list)
+ (nth 6 (car meta-list)))
+
+;; ELT is a session meta descriptor (what is being preserved as
+;; 'ediff-meta-info)
+;; The structure is: (SESSION-CTL-BUFFER STATUS OBJA OBJB OBJC)
+;; STATUS is ?I (hidden or invalid), ?* (marked for operation), ?H (hidden)
+;; nil (nothing)
+;; OBJA/B/C is (FILENAME EQSTATUS)
+;; EQSTATUS is ?= or nil (?= means that this file is equal to some other
+;; file in this session)
+;; session buffer
+(defsubst ediff-get-session-buffer (elt)
+ (nth 0 elt))
+(defsubst ediff-get-session-status (elt)
+ (nth 1 elt))
+(defsubst ediff-set-session-status (session-info new-status)
+ (setcar (cdr session-info) new-status))
+;; session objects
+(defsubst ediff-get-session-objA (elt)
+ (nth 2 elt))
+(defsubst ediff-get-session-objB (elt)
+ (nth 3 elt))
+(defsubst ediff-get-session-objC (elt)
+ (nth 4 elt))
+;; Take the "name" component of the object into acount. ObjA/C/B is of the form
+;; (name . equality-indicator)
+(defsubst ediff-get-session-objA-name (elt)
+ (car (nth 2 elt)))
+(defsubst ediff-get-session-objB-name (elt)
+ (car (nth 3 elt)))
+(defsubst ediff-get-session-objC-name (elt)
+ (car (nth 4 elt)))
+;; equality indicators
+(defsubst ediff-get-file-eqstatus (elt)
+ (nth 1 elt))
+(defsubst ediff-set-file-eqstatus (elt value)
+ (setcar (cdr elt) value))
+
+;; Create a new element for the meta list out of obj1/2/3, which usually are
+;; files
+;;
+;; The first nil in such an element is later replaced with the session buffer.
+;; The second nil is reserved for session status.
+;;
+;; Also, session objects A/B/C are turned into lists of the form (obj nil).
+;; This nil is a placeholder for eq-indicator. It is either nil or =.
+;; If it is discovered that this file is = to some other
+;; file in the same session, eq-indicator is changed to `='.
+;; Currently, the eq-indicator is used only for 2 and 3-file jobs.
+(defun ediff-make-new-meta-list-element (obj1 obj2 obj3)
+ (list nil nil (list obj1 nil) (list obj2 nil) (list obj3 nil)))
+
+;; Constructs a meta list header.
+;; OBJA, OBJB, OBJC are usually directories involved, but can be different for
+;; different jobs. For instance, multifile patch has only OBJA, which is the
+;; patch buffer.
+(defun ediff-make-new-meta-list-header (regexp
+ objA objB objC
+ merge-auto-store-dir
+ comparison-func)
+ (list regexp objA objB objC merge-auto-store-dir comparison-func))
+
+;; The activity marker is either or + (active session, i.e., ediff is currently
+;; run in it), or - (finished session, i.e., we've ran ediff in it and then
+;; exited). Return nil, if session is neither active nor finished
+(defun ediff-get-session-activity-marker (session)
+ (let ((session-buf (ediff-get-session-buffer session)))
+ (cond ((null session-buf) nil) ; virgin session
+ ((ediff-buffer-live-p session-buf) ?+) ;active session
+ (t ?-))))
+
+;; checks if the session is a meta session
+(defun ediff-meta-session-p (session-info)
+ (and (stringp (ediff-get-session-objA-name session-info))
+ (file-directory-p (ediff-get-session-objA-name session-info))
+ (stringp (ediff-get-session-objB-name session-info))
+ (file-directory-p (ediff-get-session-objB-name session-info))
+ (if (stringp (ediff-get-session-objC-name session-info))
+ (file-directory-p (ediff-get-session-objC-name session-info)) t)))
+
+
+(ediff-defvar-local ediff-verbose-help-enabled nil
+ "If t, display redundant help in ediff-directories and other meta buffers.
+Toggled by ediff-toggle-verbose-help-meta-buffer" )
+
+;; Toggle verbose help in meta-buffers
+;; TODO: Someone who understands all this can make it better.
+(defun ediff-toggle-verbose-help-meta-buffer ()
+ "Toggle showing tediously verbose help in meta buffers."
+ (interactive)
+ (setq ediff-verbose-help-enabled (not ediff-verbose-help-enabled))
+ (ediff-update-meta-buffer (current-buffer) 'must-redraw))
+
+;; set up the keymap in the meta buffer
+(defun ediff-setup-meta-map ()
+ (setq ediff-meta-buffer-map (make-sparse-keymap))
+ (suppress-keymap ediff-meta-buffer-map)
+ (define-key ediff-meta-buffer-map "?" 'ediff-toggle-verbose-help-meta-buffer)
+ (define-key ediff-meta-buffer-map "q" 'ediff-quit-meta-buffer)
+ (define-key ediff-meta-buffer-map "T" 'ediff-toggle-filename-truncation)
+ (define-key ediff-meta-buffer-map "R" 'ediff-show-registry)
+ (define-key ediff-meta-buffer-map "E" 'ediff-documentation)
+ (define-key ediff-meta-buffer-map "v" ediff-meta-action-function)
+ (define-key ediff-meta-buffer-map "\C-m" ediff-meta-action-function)
+ (define-key ediff-meta-buffer-map " " 'ediff-next-meta-item)
+ (define-key ediff-meta-buffer-map "n" 'ediff-next-meta-item)
+ (define-key ediff-meta-buffer-map "\C-?" 'ediff-previous-meta-item)
+ (define-key ediff-meta-buffer-map "p" 'ediff-previous-meta-item)
+ (define-key ediff-meta-buffer-map [delete] 'ediff-previous-meta-item)
+ (define-key ediff-meta-buffer-map [backspace] 'ediff-previous-meta-item)
+
+ (let ((menu-map (make-sparse-keymap "Ediff-Meta")))
+ (define-key ediff-meta-buffer-map [menu-bar ediff-meta-mode]
+ (cons "Ediff-Meta" menu-map))
+ (define-key menu-map [ediff-quit-meta-buffer]
+ '(menu-item "Quit" ediff-quit-meta-buffer
+ :help "Quit the meta buffer"))
+ (define-key menu-map [ediff-toggle-filename-truncation]
+ '(menu-item "Truncate filenames" ediff-toggle-filename-truncation
+ :help "Toggle truncation of long file names in session group buffers"
+ :button (:toggle . ediff-meta-truncate-filenames)))
+ (define-key menu-map [ediff-show-registry]
+ '(menu-item "Display Ediff Registry" ediff-show-registry
+ :help "Display Ediff's registry"))
+ (define-key menu-map [ediff-documentation]
+ '(menu-item "Show Manual" ediff-documentation
+ :help "Display Ediff's manual"))
+
+ (or (ediff-one-filegroup-metajob)
+ (progn
+ (define-key ediff-meta-buffer-map "=" nil)
+ (define-key ediff-meta-buffer-map "==" 'ediff-meta-mark-equal-files)
+ (define-key ediff-meta-buffer-map "=m" 'ediff-meta-mark-equal-files)
+ (define-key ediff-meta-buffer-map "=h" 'ediff-meta-mark-equal-files)))
+
+
+ (define-key menu-map [ediff-next-meta-item]
+ '(menu-item "Next" ediff-next-meta-item
+ :help "Move to the next item in Ediff registry or session group buffer"))
+ (define-key menu-map [ediff-previous-meta-item]
+ '(menu-item "Previous" ediff-previous-meta-item
+ :help "Move to the previous item in Ediff registry or session group buffer")))
+
+
+ (if ediff-no-emacs-help-in-control-buffer
+ (define-key ediff-meta-buffer-map "\C-h" 'ediff-previous-meta-item))
+ (if (featurep 'emacs)
+ (define-key ediff-meta-buffer-map [mouse-2] ediff-meta-action-function)
+ (define-key ediff-meta-buffer-map [button2] ediff-meta-action-function))
+
+ (use-local-map ediff-meta-buffer-map)
+ ;; modify ediff-meta-buffer-map here
+ (run-hooks 'ediff-meta-buffer-keymap-setup-hook))
+
+
+(defun ediff-meta-mode ()
+ "This mode controls all operations on Ediff session groups.
+It is entered through one of the following commands:
+ `ediff-directories'
+ `edirs'
+ `ediff-directories3'
+ `edirs3'
+ `ediff-merge-directories'
+ `edirs-merge'
+ `ediff-merge-directories-with-ancestor'
+ `edirs-merge-with-ancestor'
+ `ediff-directory-revisions'
+ `edir-revisions'
+ `ediff-merge-directory-revisions'
+ `edir-merge-revisions'
+ `ediff-merge-directory-revisions-with-ancestor'
+ `edir-merge-revisions-with-ancestor'
+
+Commands:
+\\{ediff-meta-buffer-map}"
+ (kill-all-local-variables)
+ (setq major-mode 'ediff-meta-mode)
+ (setq mode-name "MetaEdiff")
+ ;; don't use run-mode-hooks here!
+ (run-hooks 'ediff-meta-mode-hook))
+
+
+;; the keymap for the buffer showing directory differences
+(suppress-keymap ediff-dir-diffs-buffer-map)
+(define-key ediff-dir-diffs-buffer-map "q" 'ediff-bury-dir-diffs-buffer)
+(define-key ediff-dir-diffs-buffer-map " " 'next-line)
+(define-key ediff-dir-diffs-buffer-map "n" 'next-line)
+(define-key ediff-dir-diffs-buffer-map "\C-?" 'previous-line)
+(define-key ediff-dir-diffs-buffer-map "p" 'previous-line)
+(define-key ediff-dir-diffs-buffer-map "C" 'ediff-dir-diff-copy-file)
+(if (featurep 'emacs)
+ (define-key ediff-dir-diffs-buffer-map [mouse-2] 'ediff-dir-diff-copy-file)
+ (define-key ediff-dir-diffs-buffer-map [button2] 'ediff-dir-diff-copy-file))
+(define-key ediff-dir-diffs-buffer-map [delete] 'previous-line)
+(define-key ediff-dir-diffs-buffer-map [backspace] 'previous-line)
+
+(defun ediff-next-meta-item (count)
+ "Move to the next item in Ediff registry or session group buffer.
+Moves in circular fashion. With numeric prefix arg, skip this many items."
+ (interactive "p")
+ (or count (setq count 1))
+ (let (overl)
+ (while (< 0 count)
+ (setq count (1- count))
+ (ediff-next-meta-item1)
+ (setq overl (ediff-get-meta-overlay-at-pos (point)))
+ ;; skip invisible ones
+ (while (and overl (ediff-overlay-get overl 'invisible))
+ (ediff-next-meta-item1)
+ (setq overl (ediff-get-meta-overlay-at-pos (point)))))))
+
+;; Move to the next meta item
+(defun ediff-next-meta-item1 ()
+ (let (pos)
+ (setq pos (ediff-next-meta-overlay-start (point)))
+ (if pos (goto-char pos))
+ (if (eq ediff-metajob-name 'ediff-registry)
+ (if (and (ediff-get-meta-info (current-buffer) pos 'noerror)
+ (search-forward "*Ediff" nil t))
+ (skip-chars-backward "a-zA-Z*"))
+ (if (> (skip-chars-forward "-+?H* \t0-9") 0)
+ (backward-char 1)))))
+
+
+(defun ediff-previous-meta-item (count)
+ "Move to the previous item in Ediff registry or session group buffer.
+Moves in circular fashion. With numeric prefix arg, skip this many items."
+ (interactive "p")
+ (or count (setq count 1))
+ (let (overl)
+ (while (< 0 count)
+ (setq count (1- count))
+ (ediff-previous-meta-item1)
+ (setq overl (ediff-get-meta-overlay-at-pos (point)))
+ ;; skip invisible ones
+ (while (and overl (ediff-overlay-get overl 'invisible))
+ (ediff-previous-meta-item1)
+ (setq overl (ediff-get-meta-overlay-at-pos (point)))))))
+
+(defun ediff-previous-meta-item1 ()
+ (let (pos)
+ (setq pos (ediff-previous-meta-overlay-start (point)))
+;;; ;; skip deleted
+;;; (while (ediff-get-session-status
+;;; (ediff-get-meta-info (current-buffer) pos 'noerror))
+;;; (setq pos (ediff-previous-meta-overlay-start pos)))
+
+ (if pos (goto-char pos))
+ (if (eq ediff-metajob-name 'ediff-registry)
+ (if (and (ediff-get-meta-info (current-buffer) pos 'noerror)
+ (search-forward "*Ediff" nil t))
+ (skip-chars-backward "a-zA-Z*"))
+ (if (> (skip-chars-forward "-+?H* \t0-9") 0)
+ (backward-char 1)))
+ ))
+
+(defsubst ediff-add-slash-if-directory (dir file)
+ (if (file-directory-p (concat dir file))
+ (file-name-as-directory file)
+ file))
+
+(defun ediff-toggle-filename-truncation ()
+ "Toggle truncation of long file names in session group buffers.
+Set `ediff-meta-truncate-filenames' variable if you want to change the default
+behavior."
+ (interactive)
+ (setq ediff-meta-truncate-filenames (not ediff-meta-truncate-filenames))
+ (ediff-update-meta-buffer (current-buffer) 'must-redraw))
+
+
+;; These are used to encode membership of files in directory1/2/3
+;; Membership code of a file is a product of codes for the directories where
+;; this file is in
+(defvar ediff-membership-code1 2)
+(defvar ediff-membership-code2 3)
+(defvar ediff-membership-code3 5)
+(defvar ediff-product-of-memcodes (* ediff-membership-code1
+ ediff-membership-code2
+ ediff-membership-code3))
+
+;; DIR1, DIR2, DIR3 are directories. DIR3 can be nil.
+;; OUTPUT-DIR is a directory for auto-storing the results of merge jobs.
+;; Can be nil.
+;; REGEXP is nil or a filter regexp; only file names that match the regexp
+;; are considered.
+;; If a file is a directory in dir1 but not dir2 (or vice versa), it is not
+;; included in the intersection. However, a regular file that is a dir in dir3
+;; is included, since dir3 files are supposed to be ancestors for merging.
+;; If COMPARISON-FUNC is given, use it. Otherwise, use string=
+;;
+;; Returns a list of the form:
+;; (COMMON-PART DIFF-LIST)
+;; COMMON-PART is car and DIFF-LIST is cdr.
+;;
+;; COMMON-PART is of the form:
+;; (META-HEADER (f1 f2 f3) (f1 f2 f3) ...)
+;; f3 can be nil if intersecting only 2 directories.
+;; Each triple (f1 f2 f3) represents the files to be compared in the
+;; corresponding ediff subsession.
+;;
+;; DIFF-LIST is of the form:
+;; (META-HEADER (file . num) (file . num)...)
+;; where num encodes the set of dirs where the file is found:
+;; 2 - only dir1; 3 - only dir2; 5 - only dir3; 6 - dir1&2; 10 - dir1&3; etc.
+;; META-HEADER:
+;; Contains the meta info about this ediff operation
+;; (regexp dir1 dir2 dir3 merge-auto-store-dir comparison-func)
+;; Later the meta-buffer is prepended to this list.
+;;
+;; Some operations might use a different meta header. For instance,
+;; ediff-multifile-patch doesn't have dir2 and dir3, and regexp,
+;; comparison-func don't apply.
+;;
+(defun ediff-intersect-directories (jobname
+ regexp dir1 dir2
+ &optional
+ dir3 merge-autostore-dir comparison-func)
+ (setq comparison-func (or comparison-func 'string=))
+ (let (lis1 lis2 lis3 common auxdir1 auxdir2 auxdir3 common-part difflist)
+
+ (setq auxdir1 (file-name-as-directory dir1)
+ lis1 (directory-files auxdir1 nil regexp)
+ lis1 (delete "." lis1)
+ lis1 (delete ".." lis1)
+ lis1 (mapcar
+ (lambda (elt)
+ (ediff-add-slash-if-directory auxdir1 elt))
+ lis1)
+ auxdir2 (file-name-as-directory dir2)
+ lis2 (directory-files auxdir2 nil regexp)
+ lis2 (delete "." lis2)
+ lis2 (delete ".." lis2)
+ lis2 (mapcar
+ (lambda (elt)
+ (ediff-add-slash-if-directory auxdir2 elt))
+ lis2))
+
+ (if (stringp dir3)
+ (setq auxdir3 (file-name-as-directory dir3)
+ lis3 (directory-files auxdir3 nil regexp)
+ lis3 (delete "." lis3)
+ lis3 (delete ".." lis3)
+ lis3 (mapcar
+ (lambda (elt)
+ (ediff-add-slash-if-directory auxdir3 elt))
+ lis3)))
+
+ (if (ediff-nonempty-string-p merge-autostore-dir)
+ (setq merge-autostore-dir
+ (file-name-as-directory merge-autostore-dir)))
+ (setq common (ediff-intersection lis1 lis2 comparison-func))
+
+ ;; In merge with ancestor jobs, we don't intersect with lis3.
+ ;; If there is no ancestor, we'll offer to merge without the ancestor.
+ ;; So, we intersect with lis3 only when we are doing 3-way file comparison
+ (if (and lis3 (ediff-comparison-metajob3 jobname))
+ (setq common (ediff-intersection common lis3 comparison-func)))
+
+ ;; copying is needed because sort sorts via side effects
+ (setq common (sort (ediff-copy-list common) 'string-lessp))
+
+ ;; compute difference list
+ (setq difflist (ediff-set-difference
+ (ediff-union (ediff-union lis1 lis2 comparison-func)
+ lis3
+ comparison-func)
+ common
+ comparison-func)
+ difflist (delete "." difflist)
+ ;; copying is needed because sort sorts via side effects
+ difflist (sort (ediff-copy-list (delete ".." difflist))
+ 'string-lessp))
+
+ (setq difflist (mapcar (lambda (elt) (cons elt 1)) difflist))
+
+ ;; check for files belonging to lis1/2/3
+ ;; Each elt is of the norm (file . number)
+ ;; Number encodes the directories to which file belongs.
+ ;; It is a product of a subset of ediff-membership-code1=2,
+ ;; ediff-membership-code2=3, and ediff-membership-code3=5.
+ ;; If file belongs to dir 1 only, the membership code is 2.
+ ;; If it is in dir1 and dir3, then the membership code is 2*5=10;
+ ;; if it is in dir1 and dir2, then the membership code is 2*3=6, etc.
+ (mapc (lambda (elt)
+ (if (member (car elt) lis1)
+ (setcdr elt (* (cdr elt) ediff-membership-code1)))
+ (if (member (car elt) lis2)
+ (setcdr elt (* (cdr elt) ediff-membership-code2)))
+ (if (member (car elt) lis3)
+ (setcdr elt (* (cdr elt) ediff-membership-code3)))
+ )
+ difflist)
+ (setq difflist (cons
+ ;; diff metalist header
+ (ediff-make-new-meta-list-header regexp
+ auxdir1 auxdir2 auxdir3
+ merge-autostore-dir
+ comparison-func)
+ difflist))
+
+ (setq common-part
+ (cons
+ ;; metalist header
+ (ediff-make-new-meta-list-header regexp
+ auxdir1 auxdir2 auxdir3
+ merge-autostore-dir
+ comparison-func)
+ (mapcar
+ (lambda (elt)
+ (ediff-make-new-meta-list-element
+ (expand-file-name (concat auxdir1 elt))
+ (expand-file-name (concat auxdir2 elt))
+ (if lis3
+ (progn
+ ;; The following is done because: In merging with
+ ;; ancestor, we don't intersect with lis3. So, it is
+ ;; possible that elt is a file in auxdir1/2 but a
+ ;; directory in auxdir3 Or elt may not exist in auxdir3 at
+ ;; all. In the first case, we add a slash at the end. In
+ ;; the second case, we insert nil.
+ (setq elt (ediff-add-slash-if-directory auxdir3 elt))
+ (if (file-exists-p (concat auxdir3 elt))
+ (expand-file-name (concat auxdir3 elt)))))))
+ common)))
+ ;; return result
+ (cons common-part difflist)
+ ))
+
+;; find directory files that are under revision. Include subdirectories, since
+;; we may visit them recursively. DIR1 is the directory to inspect.
+;; MERGE-AUTOSTORE-DIR is the directory where to auto-store the results of
+;; merges. Can be nil.
+(defun ediff-get-directory-files-under-revision (jobname
+ regexp dir1
+ &optional merge-autostore-dir)
+ (let (lis1 elt common auxdir1)
+ (setq auxdir1 (file-name-as-directory dir1)
+ lis1 (directory-files auxdir1 nil regexp))
+
+ (if (ediff-nonempty-string-p merge-autostore-dir)
+ (setq merge-autostore-dir
+ (file-name-as-directory merge-autostore-dir)))
+
+ (while lis1
+ (setq elt (car lis1)
+ lis1 (cdr lis1))
+ ;; take files under revision control
+ (cond ((file-directory-p (concat auxdir1 elt))
+ (setq common
+ (cons (ediff-add-slash-if-directory auxdir1 elt) common)))
+ ((and (featurep 'vc-hooks) (vc-backend (concat auxdir1 elt)))
+ (setq common (cons elt common)))
+ ;; The following two are needed only if vc-hooks isn't loaded.
+ ;; They won't recognize CVS files.
+ ((file-exists-p (concat auxdir1 elt ",v"))
+ (setq common (cons elt common)))
+ ((file-exists-p (concat auxdir1 "RCS/" elt ",v"))
+ (setq common (cons elt common)))
+ ) ; cond
+ ) ; while
+
+ (setq common (delete "./" common)
+ common (delete "../" common)
+ common (delete "RCS" common)
+ common (delete "CVS" common)
+ )
+
+ ;; copying is needed because sort sorts via side effects
+ (setq common (sort (ediff-copy-list common) 'string-lessp))
+
+ ;; return result
+ (cons
+ ;; header -- has 6 elements. Meta buffer is prepended later by
+ ;; ediff-prepare-meta-buffer
+ (ediff-make-new-meta-list-header regexp
+ auxdir1 nil nil
+ merge-autostore-dir nil)
+ (mapcar (lambda (elt) (ediff-make-new-meta-list-element
+ (expand-file-name (concat auxdir1 elt)) nil nil))
+ common))
+ ))
+
+
+;; If file groups selected by patterns will ever be implemented, this
+;; comparison function might become useful.
+;;;; uses external variables PAT1 PAT2 to compare str1/2
+;;;; patterns must be of the form ???*???? where ??? are strings of chars
+;;;; containing no *.
+;;(defun ediff-pattern= (str1 str2)
+;; (let (pos11 pos12 pos21 pos22 len1 len2)
+;; (setq pos11 0
+;; len (length epat1)
+;; pos12 len)
+;; (while (and (< pos11 len) (not (= (aref epat1 pos11) ?*)))
+;; (setq pos11 (1+ pos11)))
+;; (while (and (> pos12 0) (not (= (aref epat1 (1- pos12)) ?*)))
+;; (setq pos12 (1- pos12)))
+;;
+;; (setq pos21 0
+;; len (length epat2)
+;; pos22 len)
+;; (while (and (< pos21 len) (not (= (aref epat2 pos21) ?*)))
+;; (setq pos21 (1+ pos21)))
+;; (while (and (> pos22 0) (not (= (aref epat2 (1- pos22)) ?*)))
+;; (setq pos22 (1- pos22)))
+;;
+;; (if (and (> (length str1) pos12) (>= pos12 pos11) (> pos11 -1)
+;; (> (length str2) pos22) (>= pos22 pos21) (> pos21 -1))
+;; (string= (substring str1 pos11 pos12)
+;; (substring str2 pos21 pos22)))
+;; ))
+
+
+;; Prepare meta-buffer in accordance with the argument-function and
+;; redraw-function. Must return the created meta-buffer.
+(defun ediff-prepare-meta-buffer (action-func meta-list
+ meta-buffer-name redraw-function
+ jobname &optional startup-hooks)
+ (let* ((meta-buffer-name
+ (ediff-unique-buffer-name meta-buffer-name "*"))
+ (meta-buffer (get-buffer-create meta-buffer-name)))
+ (ediff-with-current-buffer meta-buffer
+
+ ;; comes first
+ (ediff-meta-mode)
+
+ (setq ediff-meta-action-function action-func
+ ediff-meta-redraw-function redraw-function
+ ediff-metajob-name jobname
+ ediff-meta-buffer meta-buffer)
+
+ ;; comes after ediff-meta-action-function is set
+ (ediff-setup-meta-map)
+
+ (if (eq ediff-metajob-name 'ediff-registry)
+ (progn
+ (setq ediff-registry-buffer meta-buffer
+ ediff-meta-list meta-list)
+ ;; this func is used only from registry buffer, not from other
+ ;; meta-buffs.
+ (define-key
+ ediff-meta-buffer-map "M" 'ediff-show-meta-buff-from-registry))
+ ;; Initialize the meta list -- we don't do this for registry.
+ (setq ediff-meta-list
+ ;; add meta-buffer to the list header
+ (cons (cons meta-buffer (car meta-list))
+ (cdr meta-list))))
+
+ (or (eq meta-buffer ediff-registry-buffer)
+ (setq ediff-session-registry
+ (cons meta-buffer ediff-session-registry)))
+
+ ;; redraw-function uses ediff-meta-list
+ (funcall redraw-function ediff-meta-list)
+
+ ;; set read-only/non-modified
+ (setq buffer-read-only t)
+ (set-buffer-modified-p nil)
+
+ (run-hooks 'startup-hooks)
+
+ ;; Arrange to show directory contents differences
+ ;; Must be after run startup-hooks, since ediff-dir-difference-list is
+ ;; set inside these hooks
+ (if (eq action-func 'ediff-filegroup-action)
+ (progn
+ ;; put meta buffer in (car ediff-dir-difference-list)
+ (setq ediff-dir-difference-list
+ (cons (cons meta-buffer (car ediff-dir-difference-list))
+ (cdr ediff-dir-difference-list)))
+
+ (or (ediff-one-filegroup-metajob jobname)
+ (ediff-draw-dir-diffs ediff-dir-difference-list))
+ (define-key
+ ediff-meta-buffer-map "h" 'ediff-mark-for-hiding-at-pos)
+ (define-key ediff-meta-buffer-map "x" 'ediff-hide-marked-sessions)
+ (define-key
+ ediff-meta-buffer-map "m" 'ediff-mark-for-operation-at-pos)
+ (define-key ediff-meta-buffer-map "u" nil)
+ (define-key
+ ediff-meta-buffer-map "um" 'ediff-unmark-all-for-operation)
+ (define-key
+ ediff-meta-buffer-map "uh" 'ediff-unmark-all-for-hiding)
+
+ (define-key ediff-meta-buffer-map
+ [menu-bar ediff-meta-mode ediff-hide-marked-sessions]
+ '(menu-item "Hide marked" ediff-hide-marked-sessions
+ :help "Hide marked sessions. With prefix arg, unhide"))
+
+ (define-key ediff-meta-buffer-map
+ [menu-bar ediff-meta-mode ediff-mark-for-hiding-at-pos]
+ '(menu-item "Mark for hiding" ediff-mark-for-hiding-at-pos
+ :help "Mark session for hiding. With prefix arg, unmark"))
+
+ (define-key ediff-meta-buffer-map
+ [menu-bar ediff-meta-mode ediff-mark-for-operation-at-pos]
+ '(menu-item "Mark for group operation" ediff-mark-for-operation-at-pos
+ :help "Mark session for a group operation. With prefix arg, unmark"))
+
+ (define-key ediff-meta-buffer-map
+ [menu-bar ediff-meta-mode ediff-unmark-all-for-hiding]
+ '(menu-item "Unmark all for hiding" ediff-unmark-all-for-hiding
+ :help "Unmark all sessions marked for hiding"))
+
+ (define-key ediff-meta-buffer-map
+ [menu-bar ediff-meta-mode ediff-unmark-all-for-operation]
+ '(menu-item "Unmark all for group operation" ediff-unmark-all-for-operation
+ :help "Unmark all sessions marked for operation"))
+
+ (cond ((ediff-collect-diffs-metajob jobname)
+ (define-key ediff-meta-buffer-map
+ [menu-bar ediff-meta-mode ediff-collect-custom-diffs]
+ '(menu-item "Collect diffs" ediff-collect-custom-diffs
+ :help "Collect custom diffs of marked sessions in buffer `*Ediff Multifile Diffs*'"))
+ (define-key
+ ediff-meta-buffer-map "P" 'ediff-collect-custom-diffs))
+ ((ediff-patch-metajob jobname)
+ (define-key ediff-meta-buffer-map
+ [menu-bar ediff-meta-mode ediff-meta-show-patch]
+ '(menu-item "Show multi-file patch" ediff-meta-show-patch
+ :help "Show the multi-file patch associated with this group session"))
+ (define-key
+ ediff-meta-buffer-map "P" 'ediff-meta-show-patch)))
+ (define-key ediff-meta-buffer-map "^" 'ediff-up-meta-hierarchy)
+ (define-key ediff-meta-buffer-map "D" 'ediff-show-dir-diffs)
+
+ (define-key ediff-meta-buffer-map
+ [menu-bar ediff-meta-mode ediff-up-meta-hierarchy]
+ '(menu-item "Go to parent session" ediff-up-meta-hierarchy
+ :help "Go to the parent session group buffer"))
+
+ (define-key ediff-meta-buffer-map
+ [menu-bar ediff-meta-mode ediff-show-dir-diffs]
+ '(menu-item "Diff directories" ediff-show-dir-diffs
+ :help "Display differences among the directories involved in session group"))))
+
+ (if (eq ediff-metajob-name 'ediff-registry)
+ (run-hooks 'ediff-registry-setup-hook)
+ (run-hooks 'ediff-after-session-group-setup-hook))
+ ) ; eval in meta-buffer
+ meta-buffer))
+
+;; Insert the activity marker for session SESSION in the meta buffer at point
+;; The activity marker is either SPC (untouched session), or + (active session,
+;; i.e., ediff is currently run in it), or - (finished session, i.e., we've ran
+;; ediff in it and then exited)
+(defun ediff-insert-session-activity-marker-in-meta-buffer (session)
+ (insert
+ (cond ((ediff-get-session-activity-marker session))
+ ;; virgin session
+ (t " "))))
+
+;; Insert session status at point. Status is either ?H (marked for hiding), or
+;; ?I (hidden or invalid), or ?* (meaning marked for an operation; currently,
+;; such op can only be checking for equality)), or SPC (meaning neither marked
+;; nor invalid)
+(defun ediff-insert-session-status-in-meta-buffer (session)
+ (insert
+ (cond ((ediff-get-session-status session)) ; session has status: ?H, ?I, ?*
+ ;; normal session, no marks or hidings
+ (t " "))))
+
+;; If NEW-MARKER is non-nil, use it to substitute the current activity marker
+;; in the meta buffer. If nil, use SPC
+(defun ediff-replace-session-activity-marker-in-meta-buffer (point new-marker)
+ (let* ((overl (ediff-get-meta-overlay-at-pos point))
+ (session-info (ediff-overlay-get overl 'ediff-meta-info))
+ (activity-marker (ediff-get-session-activity-marker session-info))
+ buffer-read-only)
+ (or new-marker activity-marker (setq new-marker ?\s))
+ (goto-char (ediff-overlay-start overl))
+ (if (eq (char-after (point)) new-marker)
+ () ; if marker shown in buffer is the same as new-marker, do nothing
+ (insert new-marker)
+ (delete-char 1)
+ (set-buffer-modified-p nil))))
+
+;; If NEW-STATUS is non-nil, use it to substitute the current status marker in
+;; the meta buffer. If nil, use SPC
+(defun ediff-replace-session-status-in-meta-buffer (point new-status)
+ (let* ((overl (ediff-get-meta-overlay-at-pos point))
+ (session-info (ediff-overlay-get overl 'ediff-meta-info))
+ (status (ediff-get-session-status session-info))
+ buffer-read-only)
+ (setq new-status (or new-status status ?\s))
+ (goto-char (ediff-overlay-start overl))
+ (forward-char 1) ; status is the second char in session record
+ (if (eq (char-after (point)) new-status)
+ () ; if marker shown in buffer is the same as new-marker, do nothing
+ (insert new-status)
+ (delete-char 1)
+ (set-buffer-modified-p nil))))
+
+;; insert all file info in meta buffer for a given session
+(defun ediff-insert-session-info-in-meta-buffer (session-info sessionNum)
+ (let ((f1 (ediff-get-session-objA session-info))
+ (f2 (ediff-get-session-objB session-info))
+ (f3 (ediff-get-session-objC session-info))
+ (pt (point))
+ (hidden (eq (ediff-get-session-status session-info) ?I)))
+ ;; insert activity marker, i.e., SPC, - or +
+ (ediff-insert-session-activity-marker-in-meta-buffer session-info)
+ ;; insert session status, i.e., *, H
+ (ediff-insert-session-status-in-meta-buffer session-info)
+ (insert " Session " (int-to-string sessionNum) ":\n")
+ (ediff-meta-insert-file-info1 f1)
+ (ediff-meta-insert-file-info1 f2)
+ (ediff-meta-insert-file-info1 f3)
+ (ediff-set-meta-overlay pt (point) session-info sessionNum hidden)))
+
+
+;; this is a setup function for ediff-directories
+;; must return meta-buffer
+(defun ediff-redraw-directory-group-buffer (meta-list)
+ ;; extract directories
+ (let ((meta-buf (ediff-get-group-buffer meta-list))
+ (empty t)
+ (sessionNum 0)
+ regexp elt merge-autostore-dir
+ point tmp-list buffer-read-only)
+ (ediff-with-current-buffer meta-buf
+ (setq point (point))
+ (erase-buffer)
+ ;; delete phony overlays that used to represent sessions before the buff
+ ;; was redrawn
+ (if (featurep 'xemacs)
+ (map-extents 'delete-extent)
+ (mapc 'delete-overlay (overlays-in 1 1)))
+
+ (setq regexp (ediff-get-group-regexp meta-list)
+ merge-autostore-dir
+ (ediff-get-group-merge-autostore-dir meta-list))
+
+ (if ediff-verbose-help-enabled
+ (progn
+ (insert (format ediff-meta-buffer-verbose-message
+ (ediff-abbrev-jobname ediff-metajob-name)))
+
+ (cond ((ediff-collect-diffs-metajob)
+ (insert
+ " P:\tcollect custom diffs of all marked sessions\n"))
+ ((ediff-patch-metajob)
+ (insert
+ " P:\tshow patch appropriately for the context (session or group)\n")))
+ (insert
+ " ^:\tshow parent session group\n")
+ (or (ediff-one-filegroup-metajob)
+ (insert
+ " D:\tshow differences among directories\n"
+ " ==:\tfor each session, show which files are identical\n"
+ " =h:\tlike ==, but also marks sessions for hiding\n"
+ " =m:\tlike ==, but also marks sessions for operation\n\n")))
+ (insert (format ediff-meta-buffer-brief-message
+ (ediff-abbrev-jobname ediff-metajob-name))))
+
+ (insert "\n")
+ (if (and (stringp regexp) (> (length regexp) 0))
+ (insert
+ (format "*** Filter-through regular expression: %s\n" regexp)))
+ (ediff-insert-dirs-in-meta-buffer meta-list)
+ (if (and ediff-autostore-merges (ediff-merge-metajob)
+ (ediff-nonempty-string-p merge-autostore-dir))
+ (insert (format
+ "\nMerge results are automatically stored in:\n\t%s\n"
+ merge-autostore-dir)))
+ (insert "\n
+ Size Last modified Name
+ ----------------------------------------------
+
+")
+
+ ;; discard info on directories and regexp
+ (setq meta-list (cdr meta-list)
+ tmp-list meta-list)
+ (while (and tmp-list empty)
+ (if (and (car tmp-list)
+ (not (eq (ediff-get-session-status (car tmp-list)) ?I)))
+ (setq empty nil))
+ (setq tmp-list (cdr tmp-list)))
+
+ (if empty
+ (insert
+ " ****** ****** This session group has no members\n"))
+
+ ;; now organize file names like this:
+ ;; use-mark sizeA dateA sizeB dateB filename
+ ;; make sure directories are displayed with a trailing slash.
+ (while meta-list
+ (setq elt (car meta-list)
+ meta-list (cdr meta-list)
+ sessionNum (1+ sessionNum))
+ (if (eq (ediff-get-session-status elt) ?I)
+ ()
+ (ediff-insert-session-info-in-meta-buffer elt sessionNum)))
+ (set-buffer-modified-p nil)
+ (goto-char point)
+ meta-buf)))
+
+(defun ediff-update-markers-in-dir-meta-buffer (meta-list)
+ (let ((meta-buf (ediff-get-group-buffer meta-list))
+ session-info point overl buffer-read-only)
+ (ediff-with-current-buffer meta-buf
+ (setq point (point))
+ (goto-char (point-min))
+ (ediff-next-meta-item1)
+ (while (not (bobp))
+ (setq session-info (ediff-get-meta-info meta-buf (point) 'no-error)
+ overl (ediff-get-meta-overlay-at-pos (point)))
+ (if session-info
+ (progn
+ (cond ((eq (ediff-get-session-status session-info) ?I)
+ ;; Do hiding
+ (if overl (ediff-overlay-put overl 'invisible t)))
+ ((and (eq (ediff-get-session-status session-info) ?H)
+ overl (ediff-overlay-get overl 'invisible))
+ ;; Do unhiding
+ (ediff-overlay-put overl 'invisible nil))
+ (t (ediff-replace-session-activity-marker-in-meta-buffer
+ (point)
+ (ediff-get-session-activity-marker session-info))
+ (ediff-replace-session-status-in-meta-buffer
+ (point)
+ (ediff-get-session-status session-info))))))
+ (ediff-next-meta-item1) ; advance to the next item
+ ) ; end while
+ (set-buffer-modified-p nil)
+ (goto-char point))
+ meta-buf))
+
+(defun ediff-update-session-marker-in-dir-meta-buffer (session-num)
+ (let (buffer-meta-overlays session-info overl buffer-read-only)
+ (setq overl
+ (if (featurep 'xemacs)
+ (map-extents
+ (lambda (ext maparg)
+ (if (and
+ (ediff-overlay-get ext 'ediff-meta-info)
+ (eq (ediff-overlay-get ext 'ediff-meta-session-number)
+ session-num))
+ ext)))
+ ;; Emacs doesn't have map-extents, so try harder
+ ;; Splice overlay lists to get all buffer overlays
+ (setq buffer-meta-overlays (overlay-lists)
+ buffer-meta-overlays (append (car buffer-meta-overlays)
+ (cdr buffer-meta-overlays)))
+ (car
+ (delq nil
+ (mapcar
+ (lambda (overl)
+ (if (and
+ (ediff-overlay-get overl 'ediff-meta-info)
+ (eq (ediff-overlay-get
+ overl 'ediff-meta-session-number)
+ session-num))
+ overl))
+ buffer-meta-overlays)))))
+ (or overl
+ (error
+ "Bug in ediff-update-session-marker-in-dir-meta-buffer: no overlay with given number %S"
+ session-num))
+ (setq session-info (ediff-overlay-get overl 'ediff-meta-info))
+ (goto-char (ediff-overlay-start overl))
+ (ediff-replace-session-activity-marker-in-meta-buffer
+ (point)
+ (ediff-get-session-activity-marker session-info))
+ (ediff-replace-session-status-in-meta-buffer
+ (point)
+ (ediff-get-session-status session-info)))
+ (ediff-next-meta-item1))
+
+
+
+;; Check if this is a problematic session.
+;; Return nil if not. Otherwise, return symbol representing the problem
+;; At present, problematic sessions occur only in -with-ancestor comparisons
+;; when the ancestor is a directory rather than a file, or when there is no
+;; suitable ancestor file in the ancestor directory
+(defun ediff-problematic-session-p (session)
+ (let ((f1 (ediff-get-session-objA-name session))
+ (f2 (ediff-get-session-objB-name session))
+ (f3 (ediff-get-session-objC-name session)))
+ (cond ((and (stringp f1) (not (file-directory-p f1))
+ (stringp f2) (not (file-directory-p f2))
+ ;; either invalid file name or a directory
+ (or (not (stringp f3)) (file-directory-p f3))
+ (ediff-ancestor-metajob))
+ ;; more may be added later
+ 'ancestor-is-dir)
+ (t nil))))
+
+(defun ediff-meta-insert-file-info1 (fileinfo)
+ (let ((fname (car fileinfo))
+ (feq (ediff-get-file-eqstatus fileinfo))
+ (max-filename-width (if ediff-meta-truncate-filenames
+ (- (window-width) 41)
+ 500))
+ file-modtime file-size)
+ (cond ((not (stringp fname)) (setq file-size -2)) ; file doesn't exits
+ ((ediff-listable-file fname)
+ (if (file-exists-p fname)
+ ;; set real size and modtime
+ (setq file-size (ediff-file-size fname)
+ file-modtime (ediff-file-modtime fname))
+ (setq file-size -2))) ; file doesn't exist
+ ( t (setq file-size -1))) ; remote file
+ (if (stringp fname)
+ (insert
+ (format
+ "%s %s %-20s %s\n"
+ (if feq "=" " ") ; equality indicator
+ (format "%10s" (cond ((= file-size -1) "--")
+ ((< file-size -1) "--")
+ (t file-size)))
+ (cond ((= file-size -1) "*remote file*")
+ ((< file-size -1) "*file doesn't exist*")
+ (t (ediff-format-date (decode-time file-modtime))))
+
+ ;; dir names in meta lists have training slashes, so we just
+ ;; abbreviate the file name, if file exists
+ (if (and (not (stringp fname)) (< file-size -1))
+ "-------" ; file doesn't exist
+ (ediff-truncate-string-left
+ (ediff-abbreviate-file-name fname)
+ max-filename-width)))))))
+
+(defconst ediff-months '((1 . "Jan") (2 . "Feb") (3 . "Mar") (4 . "Apr")
+ (5 . "May") (6 . "Jun") (7 . "Jul") (8 . "Aug")
+ (9 . "Sep") (10 . "Oct") (11 . "Nov") (12 . "Dec"))
+ "Months' associative array.")
+
+;; returns 2char string
+(defsubst ediff-fill-leading-zero (num)
+ (if (< num 10)
+ (format "0%d" num)
+ (number-to-string num)))
+
+;; TIME is like the output of decode-time
+(defun ediff-format-date (time)
+ (format "%s %2d %4d %s:%s:%s"
+ (cdr (assoc (nth 4 time) ediff-months)) ; month
+ (nth 3 time) ; day
+ (nth 5 time) ; year
+ (ediff-fill-leading-zero (nth 2 time)) ; hour
+ (ediff-fill-leading-zero (nth 1 time)) ; min
+ (ediff-fill-leading-zero (nth 0 time)) ; sec
+ ))
+
+;; Draw the directories
+(defun ediff-insert-dirs-in-meta-buffer (meta-list)
+ (let* ((dir1 (ediff-abbreviate-file-name (ediff-get-group-objA meta-list)))
+ (dir2 (ediff-get-group-objB meta-list))
+ (dir2 (if (stringp dir2) (ediff-abbreviate-file-name dir2)))
+ (dir3 (ediff-get-group-objC meta-list))
+ (dir3 (if (stringp dir3) (ediff-abbreviate-file-name dir3))))
+ (insert "*** Directory A: " dir1 "\n")
+ (if dir2 (insert "*** Directory B: " dir2 "\n"))
+ (if dir3 (insert "*** Directory C: " dir3 "\n"))
+ (insert "\n")))
+
+(defun ediff-draw-dir-diffs (diff-list &optional buf-name)
+ (if (null diff-list) (error "Lost difference info on these directories"))
+ (setq buf-name
+ (or buf-name
+ (ediff-unique-buffer-name "*Ediff File Group Differences" "*")))
+ (let* ((regexp (ediff-get-group-regexp diff-list))
+ (dir1 (ediff-abbreviate-file-name (ediff-get-group-objA diff-list)))
+ (dir2 (ediff-abbreviate-file-name (ediff-get-group-objB diff-list)))
+ (dir3 (ediff-get-group-objC diff-list))
+ (dir3 (if (stringp dir3) (ediff-abbreviate-file-name dir3)))
+ (meta-buf (ediff-get-group-buffer diff-list))
+ (underline (make-string 26 ?-))
+ file membership-code saved-point
+ buffer-read-only)
+ ;; skip the directory part
+ (setq diff-list (cdr diff-list))
+ (setq ediff-dir-diffs-buffer (get-buffer-create buf-name))
+ (ediff-with-current-buffer ediff-dir-diffs-buffer
+ (setq saved-point (point))
+ (use-local-map ediff-dir-diffs-buffer-map)
+ (erase-buffer)
+ (setq ediff-meta-buffer meta-buf)
+ (insert "\t\t*** Directory Differences ***\n")
+ (insert "
+Useful commands:
+ C,button2: over file name -- copy this file to directory that doesn't have it
+ q: hide this buffer
+ n,SPC: next line
+ p,DEL: previous line\n\n")
+
+ (insert (format "\n*** Directory A: %s\n" dir1))
+ (if dir2 (insert (format "*** Directory B: %s\n" dir2)))
+ (if dir3 (insert (format "*** Directory C: %s\n" dir3)))
+ (if (and (stringp regexp) (> (length regexp) 0))
+ (insert
+ (format "*** Filter-through regular expression: %s\n" regexp)))
+ (insert "\n")
+ (insert (format "\n%-27s%-26s" "Directory A" "Directory B"))
+ (if dir3
+ (insert (format " %-25s\n" "Directory C"))
+ (insert "\n"))
+ (insert (format "%s%s" underline underline))
+ (if (stringp dir3)
+ (insert (format "%s\n\n" underline))
+ (insert "\n\n"))
+
+ (if (null diff-list)
+ (insert "\n\t*** No differences ***\n"))
+
+ (while diff-list
+ (setq file (car (car diff-list))
+ membership-code (cdr (car diff-list))
+ diff-list (cdr diff-list))
+ (if (= (mod membership-code ediff-membership-code1) 0) ; dir1
+ (let ((beg (point)))
+ (insert (format "%-27s"
+ (ediff-truncate-string-left
+ (ediff-abbreviate-file-name
+ (if (file-directory-p (concat dir1 file))
+ (file-name-as-directory file)
+ file))
+ 24)))
+ ;; format of meta info in the dir-diff-buffer:
+ ;; (filename-tail filename-full otherdir1 otherdir2 otherdir3)
+ (ediff-set-meta-overlay
+ beg (point)
+ (list meta-buf file (concat dir1 file) dir1 dir2 dir3)))
+ (insert (format "%-27s" "---")))
+ (if (= (mod membership-code ediff-membership-code2) 0) ; dir2
+ (let ((beg (point)))
+ (insert (format "%-26s"
+ (ediff-truncate-string-left
+ (ediff-abbreviate-file-name
+ (if (file-directory-p (concat dir2 file))
+ (file-name-as-directory file)
+ file))
+ 24)))
+ (ediff-set-meta-overlay
+ beg (point)
+ (list meta-buf file (concat dir2 file) dir1 dir2 dir3)))
+ (insert (format "%-26s" "---")))
+ (if (stringp dir3)
+ (if (= (mod membership-code ediff-membership-code3) 0) ; dir3
+ (let ((beg (point)))
+ (insert (format " %-25s"
+ (ediff-truncate-string-left
+ (ediff-abbreviate-file-name
+ (if (file-directory-p (concat dir3 file))
+ (file-name-as-directory file)
+ file))
+ 24)))
+ (ediff-set-meta-overlay
+ beg (point)
+ (list meta-buf file (concat dir3 file) dir1 dir2 dir3)))
+ (insert (format " %-25s" "---"))))
+ (insert "\n"))
+ (setq buffer-read-only t)
+ (set-buffer-modified-p nil)
+ (goto-char saved-point)) ; end eval in diff buffer
+ ))
+
+(defun ediff-bury-dir-diffs-buffer ()
+ "Bury the directory difference buffer. Display the meta buffer instead."
+ (interactive)
+ ;; ediff-meta-buffer is set in ediff-draw-dir-diffs so the directory
+ ;; difference buffer remembers the meta buffer
+ (let ((buf ediff-meta-buffer)
+ wind)
+ (ediff-kill-buffer-carefully ediff-dir-diffs-buffer)
+ (if (setq wind (ediff-get-visible-buffer-window buf))
+ (select-window wind)
+ (set-window-buffer (selected-window) buf))))
+
+;; executes in dir session group buffer
+;; show buffer differences
+(defun ediff-show-dir-diffs ()
+ "Display differences among the directories involved in session group."
+ (interactive)
+ (if (ediff-one-filegroup-metajob)
+ (error "This command is inapplicable in the present context"))
+ (or (ediff-buffer-live-p ediff-dir-diffs-buffer)
+ (ediff-draw-dir-diffs ediff-dir-difference-list))
+ (let ((buf ediff-dir-diffs-buffer))
+ (other-window 1)
+ (set-window-buffer (selected-window) buf)
+ (goto-char (point-min))))
+
+;; Format of meta info in dir-diff-buffer:
+;; (filename-tail filename-full otherdir1 otherdir2)
+(defun ediff-dir-diff-copy-file ()
+ "Copy file described at point to directories where this file is missing."
+ (interactive)
+ (let* ((pos (ediff-event-point last-command-event))
+ (info (ediff-get-meta-info (current-buffer) pos 'noerror))
+ (meta-buf (car info))
+ (file-tail (nth 1 info))
+ (file-abs (nth 2 info))
+ (otherdir1 (nth 3 info))
+ (otherfile1 (if otherdir1 (concat otherdir1 file-tail)))
+ (otherdir2 (nth 4 info))
+ (otherfile2 (if otherdir2 (concat otherdir2 file-tail)))
+ (otherdir3 (nth 5 info))
+ (otherfile3 (if otherdir3 (concat otherdir3 file-tail)))
+ meta-list dir-diff-list
+ )
+ (if (null info)
+ (error "No file suitable for copying described at this location"))
+ (ediff-with-current-buffer meta-buf
+ (setq meta-list ediff-meta-list
+ dir-diff-list ediff-dir-difference-list))
+
+ ;; copy file to directories where it doesn't exist, update
+ ;; ediff-dir-difference-list and redisplay
+ (mapc
+ (lambda (otherfile-struct)
+ (let ((otherfile (car otherfile-struct))
+ (file-mem-code (cdr otherfile-struct)))
+ (if otherfile
+ (or (file-exists-p otherfile)
+ (if (y-or-n-p
+ (format "Copy %s to %s? " file-abs otherfile))
+ (let* ((file-diff-record (assoc file-tail dir-diff-list))
+ (new-mem-code
+ (* (cdr file-diff-record) file-mem-code)))
+ (copy-file file-abs otherfile)
+ (setcdr file-diff-record new-mem-code)
+ (ediff-draw-dir-diffs dir-diff-list (buffer-name))
+ (sit-for 0)
+ ;; if file is in all three dirs or in two dirs and only
+ ;; two dirs are involved, delete this file's record
+ (if (or (= new-mem-code ediff-product-of-memcodes)
+ (and (> new-mem-code ediff-membership-code3)
+ (null otherfile3)))
+ (delq file-diff-record dir-diff-list))
+ ))))
+ ))
+ ;; 2,3,5 are numbers used to encode membership of a file in
+ ;; dir1/2/3. See ediff-intersect-directories.
+ (list (cons otherfile1 2) (cons otherfile2 3) (cons otherfile3 5)))
+
+ (if (and (file-exists-p otherfile1)
+ (file-exists-p otherfile2)
+ (or (not otherfile3) (file-exists-p otherfile3)))
+ ;; update ediff-meta-list by direct modification
+ (nconc meta-list
+ (list (ediff-make-new-meta-list-element
+ (expand-file-name otherfile1)
+ (expand-file-name otherfile2)
+ (if otherfile3
+ (expand-file-name otherfile3)))))
+ )
+ (ediff-update-meta-buffer meta-buf 'must-redraw)
+ ))
+
+(defun ediff-up-meta-hierarchy ()
+ "Go to the parent session group buffer."
+ (interactive)
+ (if (ediff-buffer-live-p ediff-parent-meta-buffer)
+ (ediff-show-meta-buffer
+ ediff-parent-meta-buffer ediff-meta-session-number)
+ (error "This session group has no parent")))
+
+
+;; argument is ignored
+(defun ediff-redraw-registry-buffer (&optional ignore)
+ (ediff-with-current-buffer ediff-registry-buffer
+ (let ((point (point))
+ elt bufAname bufBname bufCname cur-diff total-diffs pt
+ job-name meta-list registry-list buffer-read-only)
+ (erase-buffer)
+ ;; delete phony overlays that used to represent sessions before the buff
+ ;; was redrawn
+ (if (featurep 'xemacs)
+ (map-extents 'delete-extent)
+ (mapc 'delete-overlay (overlays-in 1 1)))
+
+ (insert "This is a registry of all active Ediff sessions.
+
+Useful commands:
+ button2, `v', RET over a session record: switch to that session
+ M over a session record: display the associated session group
+ R in any Ediff session: display session registry
+ n,SPC: next session
+ p,DEL: previous session
+ E: browse Ediff on-line manual
+ q: bury registry
+
+
+\t\tActive Ediff Sessions:
+\t\t----------------------
+
+")
+ ;; purge registry list from dead buffers
+ (mapc (lambda (elt)
+ (if (not (ediff-buffer-live-p elt))
+ (setq ediff-session-registry
+ (delq elt ediff-session-registry))))
+ ediff-session-registry)
+
+ (if (null ediff-session-registry)
+ (insert " ******* No active Ediff sessions *******\n"))
+
+ (setq registry-list ediff-session-registry)
+ (while registry-list
+ (setq elt (car registry-list)
+ registry-list (cdr registry-list))
+
+ (if (ediff-buffer-live-p elt)
+ (if (ediff-with-current-buffer elt
+ (setq job-name ediff-metajob-name
+ meta-list ediff-meta-list)
+ (and ediff-metajob-name
+ (not (eq ediff-metajob-name 'ediff-registry))))
+ (progn
+ (setq pt (point))
+ (insert (format " *group*\t%s: %s\n"
+ (buffer-name elt)
+ (ediff-abbrev-jobname job-name)))
+ (insert (format "\t\t %s %s %s\n"
+ (ediff-abbreviate-file-name
+ (ediff-get-group-objA meta-list))
+ (ediff-abbreviate-file-name
+ (if (stringp
+ (ediff-get-group-objB meta-list))
+ (ediff-get-group-objB meta-list)
+ ""))
+ (ediff-abbreviate-file-name
+ (if (stringp
+ (ediff-get-group-objC meta-list))
+ (ediff-get-group-objC meta-list)
+ ""))))
+ (ediff-set-meta-overlay pt (point) elt))
+ (progn
+ (ediff-with-current-buffer elt
+ (setq bufAname (if (ediff-buffer-live-p ediff-buffer-A)
+ (buffer-name ediff-buffer-A)
+ "!!!killed buffer!!!")
+ bufBname (if (ediff-buffer-live-p ediff-buffer-B)
+ (buffer-name ediff-buffer-B)
+ "!!!killed buffer!!!")
+ bufCname (cond ((not (ediff-3way-job))
+ "")
+ ((ediff-buffer-live-p ediff-buffer-C)
+ (buffer-name ediff-buffer-C))
+ (t "!!!killed buffer!!!")))
+ (setq total-diffs (format "%-4d" ediff-number-of-differences)
+ cur-diff
+ (cond ((= ediff-current-difference -1) " _")
+ ((= ediff-current-difference
+ ediff-number-of-differences)
+ " $")
+ (t (format
+ "%4d" (1+ ediff-current-difference))))
+ job-name ediff-job-name))
+ ;; back in the meta buf
+ (setq pt (point))
+ (insert cur-diff "/" total-diffs "\t"
+ (buffer-name elt)
+ (format ": %s" (ediff-abbrev-jobname job-name)))
+ (insert
+ "\n\t\t " bufAname " " bufBname " " bufCname "\n")
+ (ediff-set-meta-overlay pt (point) elt))))
+ ) ; while
+ (set-buffer-modified-p nil)
+ (goto-char point)
+ )))
+
+;; Sets overlay around a meta record with 'ediff-meta-info property PROP
+;; If optional SESSION-NUMBER, make it a property of the overlay,
+;; ediff-meta-session-number
+;; PROP is either the ctl or meta buffer (used when we work with the registry)
+;; or a session meta descriptor of the form
+;; (SESSION-CTL-BUFFER STATUS OBJA OBJB OBJC)
+(defun ediff-set-meta-overlay (b e prop &optional session-number hidden)
+ (let (overl)
+ (setq overl (ediff-make-overlay b e))
+ (if (featurep 'emacs)
+ (ediff-overlay-put overl 'mouse-face 'highlight)
+ (ediff-overlay-put overl 'highlight t))
+ (ediff-overlay-put overl 'ediff-meta-info prop)
+ (ediff-overlay-put overl 'invisible hidden)
+ (ediff-overlay-put overl 'follow-link t)
+ (if (numberp session-number)
+ (ediff-overlay-put overl 'ediff-meta-session-number session-number))))
+
+(defun ediff-mark-for-hiding-at-pos (unmark)
+ "Mark session for hiding. With prefix arg, unmark."
+ (interactive "P")
+ (let* ((pos (ediff-event-point last-command-event))
+ (meta-buf (ediff-event-buffer last-command-event))
+ ;; ediff-get-meta-info gives error if meta-buf or pos are invalid
+ (info (ediff-get-meta-info meta-buf pos))
+ (session-number (ediff-get-session-number-at-pos pos)))
+ (ediff-mark-session-for-hiding info unmark)
+ (ediff-next-meta-item 1)
+ (save-excursion
+ (ediff-update-meta-buffer meta-buf nil session-number))
+ ))
+
+;; Returns whether session was marked or unmarked
+(defun ediff-mark-session-for-hiding (info unmark)
+ (let ((session-buf (ediff-get-session-buffer info))
+ ignore)
+ (cond ((eq unmark 'mark) (setq unmark nil))
+ ((eq (ediff-get-session-status info) ?H) (setq unmark t))
+ (unmark ; says unmark, but the marker is different from H
+ (setq ignore t)))
+ (cond (ignore)
+ (unmark (ediff-set-session-status info nil))
+;;; (if (ediff-buffer-live-p session-buf)
+;;; (error "Can't hide active session, %s" (buffer-name session-buf)))
+ (t (ediff-set-session-status info ?H))))
+ unmark)
+
+
+(defun ediff-mark-for-operation-at-pos (unmark)
+ "Mark session for a group operation. With prefix arg, unmark."
+ (interactive "P")
+ (let* ((pos (ediff-event-point last-command-event))
+ (meta-buf (ediff-event-buffer last-command-event))
+ ;; ediff-get-meta-info gives error if meta-buf or pos are invalid
+ (info (ediff-get-meta-info meta-buf pos))
+ (session-number (ediff-get-session-number-at-pos pos)))
+ (ediff-mark-session-for-operation info unmark)
+ (ediff-next-meta-item 1)
+ (save-excursion
+ (ediff-update-meta-buffer meta-buf nil session-number))
+ ))
+
+
+;; returns whether session was unmarked.
+;; remember: this is a toggle op
+(defun ediff-mark-session-for-operation (info unmark)
+ (let (ignore)
+ (cond ((eq unmark 'mark) (setq unmark nil))
+ ((eq (ediff-get-session-status info) ?*) (setq unmark t))
+ (unmark ; says unmark, but the marker is different from *
+ (setq ignore t)))
+ (cond (ignore)
+ (unmark (ediff-set-session-status info nil))
+ (t (ediff-set-session-status info ?*))))
+ unmark)
+
+
+(defun ediff-hide-marked-sessions (unhide)
+ "Hide marked sessions. With prefix arg, unhide."
+ (interactive "P")
+ (let ((grp-buf (ediff-get-group-buffer ediff-meta-list))
+ (meta-list (cdr ediff-meta-list))
+ (from (if unhide ?I ?H))
+ (to (if unhide ?H ?I))
+ (numMarked 0)
+ active-sessions-exist session-buf elt)
+ (while meta-list
+ (setq elt (car meta-list)
+ meta-list (cdr meta-list)
+ session-buf (ediff-get-session-buffer elt))
+
+ (if (eq (ediff-get-session-status elt) from)
+ (progn
+ (setq numMarked (1+ numMarked))
+ (if (and (eq to ?I) (buffer-live-p session-buf))
+ ;; shouldn't hide active sessions
+ (setq active-sessions-exist t)
+ (ediff-set-session-status elt to)))))
+ (if (> numMarked 0)
+ (ediff-update-meta-buffer grp-buf 'must-redraw)
+ (beep)
+ (if unhide
+ (message "Nothing to reveal...")
+ (message "Nothing to hide...")))
+ (if active-sessions-exist
+ (message "Note: Ediff didn't hide active sessions!"))
+ ))
+
+;; Apply OPERATION to marked sessions. Operation expects one argument of type
+;; meta-list member (not the first one), i.e., a regular session description.
+;; Returns number of marked sessions on which operation was performed
+(defun ediff-operate-on-marked-sessions (operation)
+ (let ((grp-buf (ediff-get-group-buffer ediff-meta-list))
+ (meta-list (cdr ediff-meta-list))
+ (marksym ?*)
+ (numMarked 0)
+ (sessionNum 0)
+ (diff-buffer ediff-meta-diff-buffer)
+ session-buf elt)
+ (while meta-list
+ (setq elt (car meta-list)
+ meta-list (cdr meta-list)
+ sessionNum (1+ sessionNum))
+ (cond ((eq (ediff-get-session-status elt) marksym)
+ (save-excursion
+ (setq numMarked (1+ numMarked))
+ (funcall operation elt sessionNum)))
+ ;; The following goes into a session represented by a subdirectory
+ ;; and applies operation to marked sessions there
+ ((and (ediff-meta-session-p elt)
+ (ediff-buffer-live-p
+ (setq session-buf (ediff-get-session-buffer elt))))
+ (setq numMarked
+ (+ numMarked
+ (ediff-with-current-buffer session-buf
+ ;; pass meta-diff along
+ (setq ediff-meta-diff-buffer diff-buffer)
+ ;; collect diffs in child group
+ (ediff-operate-on-marked-sessions operation)))))))
+ (ediff-update-meta-buffer grp-buf 'must-redraw) ; just in case
+ numMarked
+ ))
+
+(defun ediff-append-custom-diff (session sessionNum)
+ (or (ediff-collect-diffs-metajob)
+ (error "Can't compute multifile patch in this context"))
+ (let ((session-buf (ediff-get-session-buffer session))
+ (meta-diff-buff ediff-meta-diff-buffer)
+ (metajob ediff-metajob-name)
+ tmp-buf custom-diff-buf)
+ (if (ediff-buffer-live-p session-buf)
+ (ediff-with-current-buffer session-buf
+ (if (eq ediff-control-buffer session-buf) ; individual session
+ (progn
+ (ediff-compute-custom-diffs-maybe)
+ (setq custom-diff-buf ediff-custom-diff-buffer)))))
+
+ (or (ediff-buffer-live-p meta-diff-buff)
+ (error "Ediff: something wrong--killed multiple diff's buffer"))
+
+ (cond ((ediff-buffer-live-p custom-diff-buf)
+ ;; for live session buffers we do them first because the user may
+ ;; have changed them with respect to the underlying files
+ (with-current-buffer meta-diff-buff
+ (goto-char (point-max))
+ (insert-buffer-substring custom-diff-buf)
+ (insert "\n")))
+ ;; if ediff session is not live, run diff directly on the files
+ ((memq metajob '(ediff-directories
+ ediff-merge-directories
+ ediff-merge-directories-with-ancestor))
+ ;; get diffs by calling shell command on ediff-custom-diff-program
+ (with-current-buffer
+ (setq tmp-buf (get-buffer-create ediff-tmp-buffer))
+ (erase-buffer)
+ (shell-command
+ (format
+ "%s %s %s %s"
+ (shell-quote-argument ediff-custom-diff-program)
+ ediff-custom-diff-options
+ (shell-quote-argument (ediff-get-session-objA-name session))
+ (shell-quote-argument (ediff-get-session-objB-name session))
+ )
+ t)
+ )
+ (with-current-buffer meta-diff-buff
+ (goto-char (point-max))
+ (insert-buffer-substring tmp-buf)
+ (insert "\n")))
+ (t
+ (ediff-kill-buffer-carefully meta-diff-buff)
+ (error "Session %d compares versions of file. Such session must be active to enable multifile patch collection" sessionNum )))
+ ))
+
+(defun ediff-collect-custom-diffs ()
+ "Collect custom diffs of marked sessions in buffer `*Ediff Multifile Diffs*'.
+This operation is defined only for `ediff-directories' and
+`ediff-directory-revisions', since its intent is to produce
+multifile patches. For `ediff-directory-revisions', we insist that
+all marked sessions must be active."
+ (interactive)
+ (let ((coding-system-for-read ediff-coding-system-for-read))
+ (or (ediff-buffer-live-p ediff-meta-diff-buffer)
+ (setq ediff-meta-diff-buffer
+ (get-buffer-create
+ (ediff-unique-buffer-name "*Ediff Multifile Diffs" "*"))))
+ (ediff-with-current-buffer ediff-meta-diff-buffer
+ (setq buffer-read-only nil)
+ (erase-buffer))
+ (if (> (ediff-operate-on-marked-sessions 'ediff-append-custom-diff) 0)
+ ;; did something
+ (progn
+ (display-buffer ediff-meta-diff-buffer 'not-this-window)
+ (ediff-with-current-buffer ediff-meta-diff-buffer
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t))
+ (if (fboundp 'diff-mode)
+ (with-current-buffer ediff-meta-diff-buffer
+ (diff-mode))))
+ (beep)
+ (message "No marked sessions found"))))
+
+(defun ediff-meta-show-patch ()
+ "Show the multi-file patch associated with this group session."
+ (interactive)
+ (let* ((pos (ediff-event-point last-command-event))
+ (meta-buf (ediff-event-buffer last-command-event))
+ (info (ediff-get-meta-info meta-buf pos 'noerror))
+ (patchbuffer ediff-meta-patchbufer))
+ (if (ediff-buffer-live-p patchbuffer)
+ (ediff-with-current-buffer patchbuffer
+ (save-restriction
+ (if (not info)
+ (widen)
+ (narrow-to-region
+ (ediff-get-session-objB-name info)
+ (ediff-get-session-objC-name info)))
+ (set-buffer (get-buffer-create ediff-tmp-buffer))
+ (erase-buffer)
+ (insert-buffer-substring patchbuffer)
+ (goto-char (point-min))
+ (display-buffer ediff-tmp-buffer 'not-this-window)
+ ))
+ (error "The patch buffer wasn't found"))))
+
+
+;; This function executes in meta buffer. It knows where event happened.
+(defun ediff-filegroup-action ()
+ "Execute appropriate action for a selected session."
+ (interactive)
+ (let* ((pos (ediff-event-point last-command-event))
+ (meta-buf (ediff-event-buffer last-command-event))
+ ;; ediff-get-meta-info gives error if meta-buf or pos are invalid
+ (info (ediff-get-meta-info meta-buf pos))
+ (session-buf (ediff-get-session-buffer info))
+ (session-number (ediff-get-session-number-at-pos pos meta-buf))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ merge-autostore-dir file1 file2 file3 regexp)
+
+ (setq file1 (ediff-get-session-objA-name info)
+ file2 (ediff-get-session-objB-name info)
+ file3 (ediff-get-session-objC-name info))
+
+ ;; make sure we don't start on hidden sessions
+ ;; ?H means marked for hiding. ?I means invalid (hidden).
+ (if (memq (ediff-get-session-status info) '(?I))
+ (progn
+ (beep)
+ (if (y-or-n-p "This session is marked as hidden, unmark? ")
+ (progn
+ (ediff-set-session-status info nil)
+ (ediff-update-meta-buffer meta-buf nil session-number))
+ (error "Aborted"))))
+
+ (ediff-with-current-buffer meta-buf
+ (setq merge-autostore-dir
+ (ediff-get-group-merge-autostore-dir ediff-meta-list))
+ (goto-char pos) ; if the user clicked on session--move point there
+ ;; First handle sessions involving directories (which are themselves
+ ;; session groups)
+ ;; After that handle individual sessions
+ (cond ((ediff-meta-session-p info)
+ ;; do ediff/ediff-merge on subdirectories
+ (if (ediff-buffer-live-p session-buf)
+ (ediff-show-meta-buffer session-buf)
+ (setq regexp
+ (read-string
+ (if (stringp default-regexp)
+ (format
+ "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp)))
+ (ediff-directories-internal
+ file1 file2 file3 regexp
+ ediff-session-action-function
+ ediff-metajob-name
+ ;; make it update (car info) after startup
+ `(list (lambda ()
+ ;; child session group should know its parent
+ (setq ediff-parent-meta-buffer
+ (quote ,ediff-meta-buffer)
+ ediff-meta-session-number
+ ,session-number)
+ ;; and parent will know its child
+ (setcar (quote ,info) ediff-meta-buffer))))))
+
+ ;; Do ediff-revision on a subdirectory
+ ((and (ediff-one-filegroup-metajob)
+ (ediff-revision-metajob)
+ (file-directory-p file1))
+ (if (ediff-buffer-live-p session-buf)
+ (ediff-show-meta-buffer session-buf)
+ (setq regexp (read-string "Filter through regular expression: "
+ nil 'ediff-filtering-regexp-history))
+ (ediff-directory-revisions-internal
+ file1 regexp
+ ediff-session-action-function ediff-metajob-name
+ ;; make it update (car info) after startup
+ `(list (lambda ()
+ ;; child session group should know its parent and
+ ;; its number
+ (setq ediff-parent-meta-buffer
+ (quote ,ediff-meta-buffer)
+ ediff-meta-session-number
+ ,session-number)
+ ;; and parent will know its child
+ (setcar (quote ,info) ediff-meta-buffer))))))
+
+ ;; From here on---only individual session handlers
+
+ ;; handle an individual session with a live control buffer
+ ((ediff-buffer-live-p session-buf)
+ (ediff-with-current-buffer session-buf
+ (setq ediff-mouse-pixel-position (mouse-pixel-position))
+ (ediff-recenter 'no-rehighlight)))
+
+ ((ediff-problematic-session-p info)
+ (beep)
+ (if (y-or-n-p
+ "This session has no ancestor. Merge without the ancestor? ")
+ (ediff-merge-files
+ file1 file2
+ ;; provide startup hooks
+ `(list (lambda ()
+ (add-hook
+ 'ediff-after-quit-hook-internal
+ (lambda ()
+ (if (ediff-buffer-live-p ,(current-buffer))
+ (ediff-show-meta-buffer
+ ,(current-buffer) ,session-number)))
+ nil 'local)
+ (setq ediff-meta-buffer ,(current-buffer)
+ ediff-meta-session-number
+ ,session-number)
+ (setq ediff-merge-store-file
+ ,(if (ediff-nonempty-string-p
+ merge-autostore-dir)
+ (concat
+ merge-autostore-dir
+ ediff-merge-filename-prefix
+ (file-name-nondirectory file1))
+ ))
+ ;; make ediff-startup pass
+ ;; ediff-control-buffer back to the meta
+ ;; level; see below
+ (setcar
+ (quote ,info) ediff-control-buffer))))
+ (error "Aborted")))
+ ((ediff-one-filegroup-metajob) ; needs 1 file arg
+ (funcall ediff-session-action-function
+ file1
+ ;; provide startup hooks
+ `(list (lambda ()
+ (add-hook
+ 'ediff-after-quit-hook-internal
+ (lambda ()
+ (if (ediff-buffer-live-p
+ ,(current-buffer))
+ (ediff-show-meta-buffer
+ ,(current-buffer)
+ ,session-number)))
+ nil 'local)
+ (setq ediff-meta-buffer ,(current-buffer)
+ ediff-meta-session-number
+ ,session-number)
+ (setq ediff-merge-store-file
+ ,(if (ediff-nonempty-string-p
+ merge-autostore-dir)
+ (concat
+ merge-autostore-dir
+ ediff-merge-filename-prefix
+ (file-name-nondirectory file1))) )
+ ;; make ediff-startup pass
+ ;; ediff-control-buffer back to the meta
+ ;; level; see below
+ (setcar
+ (quote ,info) ediff-control-buffer)))))
+ ((not (ediff-metajob3)) ; need 2 file args
+ (funcall ediff-session-action-function
+ file1 file2
+ ;; provide startup hooks
+ `(list (lambda ()
+ (add-hook
+ 'ediff-after-quit-hook-internal
+ (lambda ()
+ (if (ediff-buffer-live-p
+ ,(current-buffer))
+ (ediff-show-meta-buffer
+ ,(current-buffer)
+ ,session-number)))
+ nil 'local)
+ (setq ediff-meta-buffer ,(current-buffer)
+ ediff-meta-session-number
+ ,session-number)
+ (setq ediff-merge-store-file
+ ,(if (ediff-nonempty-string-p
+ merge-autostore-dir)
+ (concat
+ merge-autostore-dir
+ ediff-merge-filename-prefix
+ (file-name-nondirectory file1))) )
+ ;; make ediff-startup pass
+ ;; ediff-control-buffer back to the meta
+ ;; level; see below
+ (setcar
+ (quote ,info) ediff-control-buffer)))))
+ ((ediff-metajob3) ; need 3 file args
+ (funcall ediff-session-action-function
+ file1 file2 file3
+ ;; arrange startup hooks
+ `(list (lambda ()
+ (add-hook
+ 'ediff-after-quit-hook-internal
+ (lambda ()
+ (if (ediff-buffer-live-p
+ ,(current-buffer))
+ (ediff-show-meta-buffer
+ ,(current-buffer)
+ ,session-number)))
+ nil 'local)
+ (setq ediff-merge-store-file
+ ,(if (ediff-nonempty-string-p
+ merge-autostore-dir)
+ (concat
+ merge-autostore-dir
+ ediff-merge-filename-prefix
+ (file-name-nondirectory file1))) )
+ (setq ediff-meta-buffer , (current-buffer)
+ ediff-meta-session-number
+ ,session-number)
+ ;; this arranges that ediff-startup will pass
+ ;; the value of ediff-control-buffer back to
+ ;; the meta level, to the record in the meta
+ ;; list containing the information about the
+ ;; session associated with that
+ ;; ediff-control-buffer
+ (setcar
+ (quote ,info) ediff-control-buffer)))))
+ ) ; cond
+ ) ; eval in meta-buf
+ ))
+
+(defun ediff-registry-action ()
+ "Switch to a selected session."
+ (interactive)
+ (let* ((pos (ediff-event-point last-command-event))
+ (buf (ediff-event-buffer last-command-event))
+ (ctl-buf (ediff-get-meta-info buf pos)))
+
+ (if (ediff-buffer-live-p ctl-buf)
+ ;; check if this is ediff-control-buffer or ediff-meta-buffer
+ (if (ediff-with-current-buffer ctl-buf
+ (eq (key-binding "q") 'ediff-quit-meta-buffer))
+ ;; it's a meta-buffer -- last action should just display it
+ (ediff-show-meta-buffer ctl-buf t)
+ ;; it's a session buffer -- invoke go back to session
+ (ediff-with-current-buffer ctl-buf
+ (setq ediff-mouse-pixel-position (mouse-pixel-position))
+ (ediff-recenter 'no-rehighlight)))
+ (beep)
+ (message "You've selected a stale session --- try again")
+ (ediff-update-registry))
+ (ediff-with-current-buffer buf
+ (goto-char pos))
+ ))
+
+
+;; If session number is t, means don't update meta buffer
+(defun ediff-show-meta-buffer (&optional meta-buf session-number)
+ "Show the session group buffer."
+ (interactive)
+ (run-hooks 'ediff-before-directory-setup-hooks)
+ (let (wind frame silent)
+ (if meta-buf (setq silent t))
+
+ (setq meta-buf (or meta-buf ediff-meta-buffer))
+ (cond ((not (bufferp meta-buf))
+ (error "This Ediff session is not part of a session group"))
+ ((not (ediff-buffer-live-p meta-buf))
+ (error
+ "Can't find this session's group panel -- session itself is ok")))
+
+ (cond ((numberp session-number)
+ (ediff-update-meta-buffer meta-buf nil session-number))
+ ;; if session-number is t, don't update
+ (session-number)
+ (t (ediff-cleanup-meta-buffer meta-buf)))
+
+ (ediff-with-current-buffer meta-buf
+ (save-excursion
+ (cond ((setq wind (ediff-get-visible-buffer-window meta-buf))
+ (or silent
+ (message
+ "Already showing the group panel for this session"))
+ (set-window-buffer wind meta-buf)
+ (select-window wind))
+ ((window-live-p (setq wind ediff-window-C)) ;in merge--merge buf
+ (set-window-buffer ediff-window-C meta-buf)
+ (select-window wind))
+ ((window-live-p (setq wind ediff-window-A))
+ (set-window-buffer ediff-window-A meta-buf)
+ (select-window wind))
+ ((window-live-p (setq wind ediff-window-B))
+ (set-window-buffer ediff-window-B meta-buf)
+ (select-window wind))
+ ((and
+ (setq wind
+ (ediff-get-visible-buffer-window ediff-registry-buffer))
+ (ediff-window-display-p))
+ (select-window wind)
+ (other-window 1)
+ (set-window-buffer (selected-window) meta-buf))
+ (t (ediff-skip-unsuitable-frames 'ok-unsplittable)
+ (set-window-buffer (selected-window) meta-buf)))
+ ))
+ (if (and (ediff-window-display-p)
+ (window-live-p
+ (setq wind (ediff-get-visible-buffer-window meta-buf))))
+ (progn
+ (setq frame (window-frame wind))
+ (raise-frame frame)
+ (ediff-reset-mouse frame)))
+ (sit-for 0) ; sometimes needed to synch the display and ensure that the
+ ; point ends up after the just completed session
+ (run-hooks 'ediff-show-session-group-hook)
+ ))
+
+(defun ediff-show-current-session-meta-buffer ()
+ (interactive)
+ (ediff-show-meta-buffer nil ediff-meta-session-number))
+
+(defun ediff-show-meta-buff-from-registry ()
+ "Display the session group buffer for a selected session group."
+ (interactive)
+ (let* ((pos (ediff-event-point last-command-event))
+ (meta-buf (ediff-event-buffer last-command-event))
+ (info (ediff-get-meta-info meta-buf pos))
+ (meta-or-session-buf info))
+ (ediff-with-current-buffer meta-or-session-buf
+ (ediff-show-meta-buffer nil t))))
+
+;;;###autoload
+(defun ediff-show-registry ()
+ "Display Ediff's registry."
+ (interactive)
+ (ediff-update-registry)
+ (if (not (ediff-buffer-live-p ediff-registry-buffer))
+ (error "No active Ediff sessions or corrupted session registry"))
+ (let (wind frame)
+ ;; for some reason, point moves in ediff-registry-buffer, so we preserve it
+ ;; explicitly
+ (ediff-with-current-buffer ediff-registry-buffer
+ (save-excursion
+ (cond ((setq wind
+ (ediff-get-visible-buffer-window ediff-registry-buffer))
+ (message "Already showing the registry")
+ (set-window-buffer wind ediff-registry-buffer)
+ (select-window wind))
+ ((window-live-p ediff-window-C)
+ (set-window-buffer ediff-window-C ediff-registry-buffer)
+ (select-window ediff-window-C))
+ ((window-live-p ediff-window-A)
+ (set-window-buffer ediff-window-A ediff-registry-buffer)
+ (select-window ediff-window-A))
+ ((window-live-p ediff-window-B)
+ (set-window-buffer ediff-window-B ediff-registry-buffer)
+ (select-window ediff-window-B))
+ ((and (setq wind
+ (ediff-get-visible-buffer-window ediff-meta-buffer))
+ (ediff-window-display-p))
+ (select-window wind)
+ (other-window 1)
+ (set-window-buffer (selected-window) ediff-registry-buffer))
+ (t (ediff-skip-unsuitable-frames 'ok-unsplittable)
+ (set-window-buffer (selected-window) ediff-registry-buffer)))
+ ))
+ (if (ediff-window-display-p)
+ (progn
+ (setq frame
+ (window-frame
+ (ediff-get-visible-buffer-window ediff-registry-buffer)))
+ (raise-frame frame)
+ (ediff-reset-mouse frame)))
+ (run-hooks 'ediff-show-registry-hook)
+ ))
+
+;;;###autoload
+(defalias 'eregistry 'ediff-show-registry)
+
+;; If meta-buf doesn't exist, it is created. In that case, id doesn't have a
+;; parent meta-buf
+;; Check if META-BUF exists before calling this function
+;; Optional MUST-REDRAW, if non-nil, would force redrawal of the whole meta
+;; buffer. Otherwise, it will just go over the buffer and update activity marks
+;; and session status.
+;; SESSION-NUMBER, if specified, says which session caused the update.
+(defun ediff-update-meta-buffer (meta-buf &optional must-redraw session-number)
+ (if (ediff-buffer-live-p meta-buf)
+ (ediff-with-current-buffer meta-buf
+ (let (overl)
+ (cond (must-redraw ; completely redraw the meta buffer
+ (funcall ediff-meta-redraw-function ediff-meta-list))
+ ((numberp session-number) ; redraw only for the given session
+ (ediff-update-session-marker-in-dir-meta-buffer
+ session-number))
+ (t ; update what changed only, but scan the entire meta buffer
+ (ediff-update-markers-in-dir-meta-buffer ediff-meta-list)))
+ (setq overl (ediff-get-meta-overlay-at-pos (point)))
+ ;; skip the invisible sessions
+ (while (and overl (ediff-overlay-get overl 'invisible))
+ (ediff-next-meta-item1)
+ (setq overl (ediff-get-meta-overlay-at-pos (point))))
+ ))))
+
+(defun ediff-update-registry ()
+ (ediff-with-current-buffer (current-buffer)
+ (if (ediff-buffer-live-p ediff-registry-buffer)
+ (ediff-redraw-registry-buffer)
+ (ediff-prepare-meta-buffer
+ 'ediff-registry-action
+ ediff-session-registry
+ "*Ediff Registry"
+ 'ediff-redraw-registry-buffer
+ 'ediff-registry))
+ ))
+
+;; If meta-buf exists, it is redrawn along with parent.
+;; Otherwise, nothing happens.
+(defun ediff-cleanup-meta-buffer (meta-buffer)
+ (if (ediff-buffer-live-p meta-buffer)
+ (ediff-with-current-buffer meta-buffer
+ (ediff-update-meta-buffer meta-buffer)
+ (if (ediff-buffer-live-p ediff-parent-meta-buffer)
+ (ediff-update-meta-buffer
+ ediff-parent-meta-buffer nil ediff-meta-session-number)))))
+
+;; t if no session is in progress
+(defun ediff-safe-to-quit (meta-buffer)
+ (if (ediff-buffer-live-p meta-buffer)
+ (let ((lis ediff-meta-list)
+ (cont t)
+ buffer-read-only)
+ ;;(ediff-update-meta-buffer meta-buffer)
+ (ediff-with-current-buffer meta-buffer
+ (setq lis (cdr lis)) ; discard the description part of meta-list
+ (while (and cont lis)
+ (if (ediff-buffer-live-p
+ (ediff-get-group-buffer lis)) ; in progress
+ (setq cont nil))
+ (setq lis (cdr lis)))
+ cont))))
+
+(defun ediff-quit-meta-buffer ()
+ "If the group has no active session, delete the meta buffer.
+If no session is in progress, ask to confirm before deleting meta buffer.
+Otherwise, bury the meta buffer.
+If this is a session registry buffer then just bury it."
+ (interactive)
+ (let* ((buf (current-buffer))
+ (dir-diffs-buffer ediff-dir-diffs-buffer)
+ (meta-diff-buffer ediff-meta-diff-buffer)
+ (session-number ediff-meta-session-number)
+ (parent-buf ediff-parent-meta-buffer)
+ (dont-show-registry (eq buf ediff-registry-buffer)))
+ (if dont-show-registry
+ (bury-buffer)
+ ;;(ediff-cleanup-meta-buffer buf)
+ (cond ((and (ediff-safe-to-quit buf)
+ (y-or-n-p "Quit this session group? "))
+ (run-hooks 'ediff-quit-session-group-hook)
+ (message "")
+ (ediff-dispose-of-meta-buffer buf))
+ ((ediff-safe-to-quit buf)
+ (bury-buffer))
+ (t
+ (error
+ "This session group has active sessions---cannot exit")))
+ (ediff-update-meta-buffer parent-buf nil session-number)
+ (ediff-kill-buffer-carefully dir-diffs-buffer)
+ (ediff-kill-buffer-carefully meta-diff-buffer)
+ (if (ediff-buffer-live-p parent-buf)
+ (progn
+ (setq dont-show-registry t)
+ (ediff-show-meta-buffer parent-buf session-number)))
+ )
+ (or dont-show-registry
+ (ediff-show-registry))))
+
+(defun ediff-dispose-of-meta-buffer (buf)
+ (setq ediff-session-registry (delq buf ediff-session-registry))
+ (ediff-with-current-buffer buf
+ (if (ediff-buffer-live-p ediff-dir-diffs-buffer)
+ (kill-buffer ediff-dir-diffs-buffer)))
+ (kill-buffer buf))
+
+
+;; Obtain information on a meta record where the user clicked or typed
+;; BUF is the buffer where this happened and POINT is the position
+;; If optional NOERROR arg is given, don't report error and return nil if no
+;; meta info is found on line.
+(defun ediff-get-meta-info (buf point &optional noerror)
+ (let (result olist tmp)
+ (if (and point (ediff-buffer-live-p buf))
+ (ediff-with-current-buffer buf
+ (if (featurep 'xemacs)
+ (setq result
+ (if (setq tmp (extent-at point buf 'ediff-meta-info))
+ (ediff-overlay-get tmp 'ediff-meta-info)))
+ (setq olist
+ (mapcar (lambda (elt)
+ (unless (overlay-get elt 'invisible)
+ (overlay-get elt 'ediff-meta-info)))
+ (overlays-at point)))
+ (while (and olist (null (car olist)))
+ (setq olist (cdr olist)))
+ (setq result (car olist)))))
+ (or result
+ (unless noerror
+ (ediff-update-registry)
+ (error "No session info in this line")))))
+
+
+(defun ediff-get-meta-overlay-at-pos (point)
+ (if (featurep 'xemacs)
+ (extent-at point (current-buffer) 'ediff-meta-info)
+ (let* ((overl-list (overlays-at point))
+ (overl (car overl-list)))
+ (while (and overl (null (overlay-get overl 'ediff-meta-info)))
+ (setq overl-list (cdr overl-list)
+ overl (car overl-list)))
+ overl)))
+
+(defun ediff-get-session-number-at-pos (point &optional meta-buffer)
+ (setq meta-buffer (if (ediff-buffer-live-p meta-buffer)
+ meta-buffer
+ (current-buffer)))
+ (ediff-with-current-buffer meta-buffer
+ (ediff-overlay-get
+ (ediff-get-meta-overlay-at-pos point) 'ediff-meta-session-number)))
+
+
+;; Return location of the next meta overlay after point
+(defun ediff-next-meta-overlay-start (point)
+ (if (eobp)
+ (goto-char (point-min))
+ (let ((overl (ediff-get-meta-overlay-at-pos point)))
+ (if (featurep 'xemacs)
+ (progn ; xemacs
+ (if overl
+ (setq overl (next-extent overl))
+ (setq overl (next-extent (current-buffer))))
+ (if overl
+ (extent-start-position overl)
+ (point-max)))
+ ;; emacs
+ (if overl
+ ;; note: end of current overlay is the beginning of the next one
+ (overlay-end overl)
+ (next-overlay-change point))))))
+
+
+(defun ediff-previous-meta-overlay-start (point)
+ (if (bobp)
+ (goto-char (point-max))
+ (let ((overl (ediff-get-meta-overlay-at-pos point)))
+ (if (featurep 'xemacs)
+ (progn
+ (if overl
+ (setq overl (previous-extent overl))
+ (setq overl (previous-extent (current-buffer))))
+ (if overl
+ (extent-start-position overl)
+ (point-min)))
+ (if overl (setq point (overlay-start overl)))
+ ;; to get to the beginning of prev overlay
+ (if (not (bobp))
+ ;; trick to overcome an emacs bug--doesn't always find previous
+ ;; overlay change correctly
+ (setq point (1- point)))
+ (setq point (previous-overlay-change point))
+ ;; If we are not over an overlay after subtracting 1, it means we are
+ ;; in the description area preceding session records. In this case,
+ ;; goto the top of the registry buffer.
+ (or (car (overlays-at point))
+ (setq point (point-min)))
+ point))))
+
+;; this is the action invoked when the user selects a patch from the meta
+;; buffer.
+(defun ediff-patch-file-form-meta (file &optional startup-hooks)
+ (let* ((pos (ediff-event-point last-command-event))
+ (meta-buf (ediff-event-buffer last-command-event))
+ ;; ediff-get-meta-info gives error if meta-buf or pos are invalid
+ (info (ediff-get-meta-info meta-buf pos))
+ (meta-patchbuf ediff-meta-patchbufer)
+ session-buf beg-marker end-marker)
+
+ (if (or (file-directory-p file) (string-match "/dev/null" file))
+ (error "`%s' is not an ordinary file" (file-name-as-directory file)))
+ (setq session-buf (ediff-get-session-buffer info)
+ beg-marker (ediff-get-session-objB-name info)
+ end-marker (ediff-get-session-objC-name info))
+
+ (or (ediff-buffer-live-p session-buf) ; either an active patch session
+ (null session-buf) ; or it is a virgin session
+ (error
+ "Patch has already been applied to this file -- can't repeat!"))
+
+ (ediff-with-current-buffer meta-patchbuf
+ (save-restriction
+ (widen)
+ (narrow-to-region beg-marker end-marker)
+ (ediff-patch-file-internal meta-patchbuf file startup-hooks)))))
+
+
+(defun ediff-unmark-all-for-operation ()
+ "Unmark all sessions marked for operation."
+ (interactive)
+ (let ((list (cdr ediff-meta-list))
+ elt)
+ (while (setq elt (car list))
+ (ediff-mark-session-for-operation elt 'unmark)
+ (setq list (cdr list))))
+ (ediff-update-meta-buffer (current-buffer) 'must-redraw))
+
+(defun ediff-unmark-all-for-hiding ()
+ "Unmark all sessions marked for hiding."
+ (interactive)
+ (let ((list (cdr ediff-meta-list))
+ elt)
+ (while (setq elt (car list))
+ (ediff-mark-session-for-hiding elt 'unmark)
+ (setq list (cdr list))))
+ (ediff-update-meta-buffer (current-buffer) 'must-redraw))
+
+
+;; ACTION is ?h, ?m, ?=: to mark for hiding, mark for operation, or simply
+;; indicate which are equal files
+(defun ediff-meta-mark-equal-files (&optional action)
+ "Run through the session list and mark identical files.
+This is used only for sessions that involve 2 or 3 files at the same time.
+ACTION is an optional argument that can be ?h, ?m, ?=, to mark for hiding, mark
+for operation, or simply indicate which are equal files. If it is nil, then
+`(ediff-last-command-char)' is used to decide which action to take."
+ (interactive)
+ (if (null action)
+ (setq action (ediff-last-command-char)))
+ (let ((list (cdr ediff-meta-list))
+ marked1 marked2 marked3
+ fileinfo1 fileinfo2 fileinfo3 elt)
+ (message "Comparing files...")
+ (while (setq elt (car list))
+ (setq fileinfo1 (ediff-get-session-objA elt)
+ fileinfo2 (ediff-get-session-objB elt)
+ fileinfo3 (ediff-get-session-objC elt))
+ (ediff-set-file-eqstatus fileinfo1 nil)
+ (ediff-set-file-eqstatus fileinfo2 nil)
+ (ediff-set-file-eqstatus fileinfo3 nil)
+
+ (setq marked1 t
+ marked2 t
+ marked3 t)
+ (or (ediff-mark-if-equal fileinfo1 fileinfo2)
+ (setq marked1 nil))
+ (if (ediff-metajob3)
+ (progn
+ (or (ediff-mark-if-equal fileinfo1 fileinfo3)
+ (setq marked2 nil))
+ (or (ediff-mark-if-equal fileinfo2 fileinfo3)
+ (setq marked3 nil))))
+ (if (and marked1 marked2 marked3)
+ (cond ((eq action ?h)
+ (ediff-mark-session-for-hiding elt 'mark))
+ ((eq action ?m)
+ (ediff-mark-session-for-operation elt 'mark))
+ ))
+ (setq list (cdr list)))
+ (message "Comparing files... Done"))
+ (setq ediff-recurse-to-subdirectories nil)
+ (ediff-update-meta-buffer (current-buffer) 'must-redraw))
+
+;; mark files 1 and 2 as equal, if they are.
+;; returns t, if something was marked
+(defun ediff-mark-if-equal (fileinfo1 fileinfo2)
+ (let ((f1 (car fileinfo1))
+ (f2 (car fileinfo2)))
+ (if (and (stringp f1) (stringp f2) (ediff-same-contents f1 f2))
+ (progn
+ (ediff-set-file-eqstatus fileinfo1 t)
+ (ediff-set-file-eqstatus fileinfo2 t)
+ ))
+ ))
+
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: c8a76898-f96f-4d9c-be9d-129134017188
+;;; ediff-mult.el ends here
--- /dev/null
+;;; ediff-ptch.el --- Ediff's patch support
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+(provide 'ediff-ptch)
+
+(defgroup ediff-ptch nil
+ "Ediff patch support."
+ :tag "Patch"
+ :prefix "ediff-"
+ :group 'ediff)
+
+;; compiler pacifier
+(eval-when-compile
+ (require 'ediff))
+;; end pacifier
+
+(require 'ediff-init)
+
+(defcustom ediff-patch-program "patch"
+ "Name of the program that applies patches.
+It is recommended to use GNU-compatible versions."
+ :type 'string
+ :group 'ediff-ptch)
+(defcustom ediff-patch-options "-f"
+ "Options to pass to ediff-patch-program.
+
+Note: the `-b' option should be specified in `ediff-backup-specs'.
+
+It is recommended to pass the `-f' option to the patch program, so it won't ask
+questions. However, some implementations don't accept this option, in which
+case the default value for this variable should be changed."
+ :type 'string
+ :group 'ediff-ptch)
+
+(defvar ediff-last-dir-patch nil
+ "Last directory used by an Ediff command for file to patch.")
+
+;; the default backup extension
+(defconst ediff-default-backup-extension
+ (if (memq system-type '(emx ms-dos))
+ "_orig" ".orig"))
+
+
+(defcustom ediff-backup-extension ediff-default-backup-extension
+ "Backup extension used by the patch program.
+See also `ediff-backup-specs'."
+ :type 'string
+ :group 'ediff-ptch)
+
+(defun ediff-test-patch-utility ()
+ (condition-case nil
+ (cond ((eq 0 (call-process ediff-patch-program nil nil nil "-z." "-b"))
+ ;; GNU `patch' v. >= 2.2
+ 'gnu)
+ ((eq 0 (call-process ediff-patch-program nil nil nil "-b"))
+ 'posix)
+ (t 'traditional))
+ (file-error nil)))
+
+(defcustom ediff-backup-specs
+ (let ((type (ediff-test-patch-utility)))
+ (cond ((eq type 'gnu)
+ ;; GNU `patch' v. >= 2.2
+ (format "-z%s -b" ediff-backup-extension))
+ ((eq type 'posix)
+ ;; POSIX `patch' -- ediff-backup-extension must be ".orig"
+ (setq ediff-backup-extension ediff-default-backup-extension)
+ "-b")
+ (t
+ ;; traditional `patch'
+ (format "-b %s" ediff-backup-extension))))
+ "Backup directives to pass to the patch program.
+Ediff requires that the old version of the file \(before applying the patch\)
+be saved in a file named `the-patch-file.extension'. Usually `extension' is
+`.orig', but this can be changed by the user and may depend on the system.
+Therefore, Ediff needs to know the backup extension used by the patch program.
+
+Some versions of the patch program let you specify `-b backup-extension'.
+Other versions only permit `-b', which assumes the extension `.orig'
+\(in which case ediff-backup-extension MUST be also `.orig'\). The latest
+versions of GNU patch require `-b -z backup-extension'.
+
+Note that both `ediff-backup-extension' and `ediff-backup-specs'
+must be set properly. If your patch program takes the option `-b',
+but not `-b extension', the variable `ediff-backup-extension' must
+still be set so Ediff will know which extension to use.
+
+Ediff tries to guess the appropriate value for this variables. It is believed
+to be working for `traditional' patch, all versions of GNU patch, and for POSIX
+patch. So, don't change these variables, unless the default doesn't work."
+ :type 'string
+ :group 'ediff-ptch)
+
+
+(defcustom ediff-patch-default-directory nil
+ "Default directory to look for patches."
+ :type '(choice (const nil) string)
+ :group 'ediff-ptch)
+
+;; This context diff does not recognize spaces inside files, but removing ' '
+;; from [^ \t] breaks normal patches for some reason
+(defcustom ediff-context-diff-label-regexp
+ (concat "\\(" ; context diff 2-liner
+ "^\\*\\*\\* +\\([^ \t]+\\)[^*]+[\t ]*\n--- +\\([^ \t]+\\)"
+ "\\|" ; unified format diff 2-liner
+ "^--- +\\([^ \t]+\\).*\n\\+\\+\\+ +\\([^ \t]+\\)"
+ "\\)")
+ "Regexp matching filename 2-liners at the start of each context diff.
+You probably don't want to change that, unless you are using an obscure patch
+program."
+ :type 'regexp
+ :group 'ediff-ptch)
+
+;; The buffer of the patch file. Local to control buffer.
+(ediff-defvar-local ediff-patchbufer nil "")
+
+;; The buffer where patch displays its diagnostics.
+(ediff-defvar-local ediff-patch-diagnostics nil "")
+
+;; Map of patch buffer. Has the form:
+;; ((filename1 marker1 marker2) (filename2 marker1 marker2) ...)
+;; where filenames are files to which patch would have applied the patch;
+;; marker1 delimits the beginning of the corresponding patch and marker2 does
+;; it for the end.
+(ediff-defvar-local ediff-patch-map nil "")
+
+;; strip prefix from filename
+;; returns /dev/null, if can't strip prefix
+(defsubst ediff-file-name-sans-prefix (filename prefix)
+ (if prefix
+ (save-match-data
+ (if (string-match (concat "^" (if (stringp prefix)
+ (regexp-quote prefix)
+ ""))
+ filename)
+ (substring filename (match-end 0))
+ (concat "/null/" filename)))
+ filename)
+ )
+
+
+
+;; no longer used
+;; return the number of matches of regexp in buf starting from the beginning
+(defun ediff-count-matches (regexp buf)
+ (ediff-with-current-buffer buf
+ (let ((count 0) opoint)
+ (save-excursion
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (progn (setq opoint (point))
+ (re-search-forward regexp nil t)))
+ (if (= opoint (point))
+ (forward-char 1)
+ (setq count (1+ count)))))
+ count)))
+
+;; Scan BUF (which is supposed to contain a patch) and make a list of the form
+;; ((nil nil filename-spec1 marker1 marker2)
+;; (nil nil filename-spec2 marker1 marker2) ...)
+;; where filename-spec[12] are files to which the `patch' program would
+;; have applied the patch.
+;; nin, nil are placeholders. See ediff-make-new-meta-list-element in
+;; ediff-meta.el for the explanations.
+;; In the beginning we don't know exactly which files need to be patched.
+;; We usually come up with two candidates and ediff-file-name-sans-prefix
+;; resolves this later.
+;;
+;; The marker `marker1' delimits the beginning of the corresponding patch and
+;; `marker2' does it for the end.
+;; The result of ediff-map-patch-buffer is a list, which is then assigned
+;; to ediff-patch-map.
+;; The function returns the number of elements in the list ediff-patch-map
+(defun ediff-map-patch-buffer (buf)
+ (ediff-with-current-buffer buf
+ (let ((count 0)
+ (mark1 (move-marker (make-marker) (point-min)))
+ (mark1-end (point-min))
+ (possible-file-names '("/dev/null" . "/dev/null"))
+ mark2-end mark2 filenames
+ beg1 beg2 end1 end2
+ patch-map opoint)
+ (save-excursion
+ (goto-char (point-min))
+ (setq opoint (point))
+ (while (and (not (eobp))
+ (re-search-forward ediff-context-diff-label-regexp nil t))
+ (if (= opoint (point))
+ (forward-char 1) ; ensure progress towards the end
+ (setq mark2 (move-marker (make-marker) (match-beginning 0))
+ mark2-end (match-end 0)
+ beg1 (or (match-beginning 2) (match-beginning 4))
+ end1 (or (match-end 2) (match-end 4))
+ beg2 (or (match-beginning 3) (match-beginning 5))
+ end2 (or (match-end 3) (match-end 5)))
+ ;; possible-file-names is holding the new file names until we
+ ;; insert the old file name in the patch map
+ ;; It is a pair
+ ;; (filename-from-1st-header-line . filename-from-2nd-line)
+ (setq possible-file-names
+ (cons (if (and beg1 end1)
+ (buffer-substring beg1 end1)
+ "/dev/null")
+ (if (and beg2 end2)
+ (buffer-substring beg2 end2)
+ "/dev/null")))
+ ;; check for any `Index:' or `Prereq:' lines, but don't use them
+ (if (re-search-backward "^Index:" mark1-end 'noerror)
+ (move-marker mark2 (match-beginning 0)))
+ (if (re-search-backward "^Prereq:" mark1-end 'noerror)
+ (move-marker mark2 (match-beginning 0)))
+
+ (goto-char mark2-end)
+
+ (if filenames
+ (setq patch-map
+ (cons (ediff-make-new-meta-list-element
+ filenames mark1 mark2)
+ patch-map)))
+ (setq mark1 mark2
+ mark1-end mark2-end
+ filenames possible-file-names))
+ (setq opoint (point)
+ count (1+ count))))
+ (setq mark2 (point-max-marker)
+ patch-map (cons (ediff-make-new-meta-list-element
+ possible-file-names mark1 mark2)
+ patch-map))
+ (setq ediff-patch-map (nreverse patch-map))
+ count)))
+
+;; Fix up the file names in the list using the argument FILENAME
+;; Algorithm: find the files' directories in the patch and, if a directory is
+;; absolute, cut it out from the corresponding file name in the patch.
+;; Relative directories are not cut out.
+;; Prepend the directory of FILENAME to each resulting file (which came
+;; originally from the patch).
+;; In addition, the first file in the patch document is replaced by FILENAME.
+;; Each file is actually a pair of files found in the context diff header
+;; In the end, for each pair, we ask the user which file to patch.
+;; Note: Ediff doesn't recognize multi-file patches that are separated
+;; with the `Index:' line. It treats them as a single-file patch.
+;;
+;; Executes inside the patch buffer
+(defun ediff-fixup-patch-map (filename)
+ (setq filename (expand-file-name filename))
+ (let ((actual-dir (if (file-directory-p filename)
+ ;; directory part of filename
+ (file-name-as-directory filename)
+ (file-name-directory filename)))
+ ;; In case 2 files are possible patch targets, the user will be offered
+ ;; to choose file1 or file2. In a multifile patch, if the user chooses
+ ;; 1 or 2, this choice is preserved to decide future alternatives.
+ chosen-alternative
+ )
+
+ ;; chop off base-dirs
+ (mapc (lambda (session-info)
+ (let* ((proposed-file-names
+ ;; Filename-spec is objA; it is represented as
+ ;; (file1 . file2). Get it using ediff-get-session-objA.
+ (ediff-get-session-objA-name session-info))
+ ;; base-dir1 is the dir part of the 1st file in the patch
+ (base-dir1
+ (or (file-name-directory (car proposed-file-names))
+ ""))
+ ;; directory part of the 2nd file in the patch
+ (base-dir2
+ (or (file-name-directory (cdr proposed-file-names))
+ ""))
+ )
+ ;; If both base-dir1 and base-dir2 are relative and exist,
+ ;; assume that
+ ;; these dirs lead to the actual files starting at the present
+ ;; directory. So, we don't strip these relative dirs from the
+ ;; file names. This is a heuristic intended to improve guessing
+ (let ((default-directory (file-name-directory filename)))
+ (unless (or (file-name-absolute-p base-dir1)
+ (file-name-absolute-p base-dir2)
+ (not (file-exists-p base-dir1))
+ (not (file-exists-p base-dir2)))
+ (setq base-dir1 ""
+ base-dir2 "")))
+ (or (string= (car proposed-file-names) "/dev/null")
+ (setcar proposed-file-names
+ (ediff-file-name-sans-prefix
+ (car proposed-file-names) base-dir1)))
+ (or (string=
+ (cdr proposed-file-names) "/dev/null")
+ (setcdr proposed-file-names
+ (ediff-file-name-sans-prefix
+ (cdr proposed-file-names) base-dir2)))
+ ))
+ ediff-patch-map)
+
+ ;; take the given file name into account
+ (or (file-directory-p filename)
+ (string= "/dev/null" filename)
+ (setcar (ediff-get-session-objA (car ediff-patch-map))
+ (cons (file-name-nondirectory filename)
+ (file-name-nondirectory filename))))
+
+ ;; prepend actual-dir
+ (mapc (lambda (session-info)
+ (let ((proposed-file-names
+ (ediff-get-session-objA-name session-info)))
+ (if (and (string-match "^/null/" (car proposed-file-names))
+ (string-match "^/null/" (cdr proposed-file-names)))
+ ;; couldn't intuit the file name to patch, so
+ ;; something is amiss
+ (progn
+ (with-output-to-temp-buffer ediff-msg-buffer
+ (ediff-with-current-buffer standard-output
+ (fundamental-mode))
+ (princ
+ (format "
+The patch file contains a context diff for
+ %s
+ %s
+However, Ediff cannot infer the name of the actual file
+to be patched on your system. If you know the correct file name,
+please enter it now.
+
+If you don't know and still would like to apply patches to
+other files, enter /dev/null
+"
+ (substring (car proposed-file-names) 6)
+ (substring (cdr proposed-file-names) 6))))
+ (let ((directory t)
+ user-file)
+ (while directory
+ (setq user-file
+ (read-file-name
+ "Please enter file name: "
+ actual-dir actual-dir t))
+ (if (not (file-directory-p user-file))
+ (setq directory nil)
+ (setq directory t)
+ (beep)
+ (message "%s is a directory" user-file)
+ (sit-for 2)))
+ (setcar (ediff-get-session-objA session-info)
+ (cons user-file user-file))))
+ (setcar proposed-file-names
+ (expand-file-name
+ (concat actual-dir (car proposed-file-names))))
+ (setcdr proposed-file-names
+ (expand-file-name
+ (concat actual-dir (cdr proposed-file-names)))))
+ ))
+ ediff-patch-map)
+ ;; Check for the existing files in each pair and discard the nonexisting
+ ;; ones. If both exist, ask the user.
+ (mapcar (lambda (session-info)
+ (let* ((file1 (car (ediff-get-session-objA-name session-info)))
+ (file2 (cdr (ediff-get-session-objA-name session-info)))
+ (session-file-object
+ (ediff-get-session-objA session-info))
+ (f1-exists (file-exists-p file1))
+ (f2-exists (file-exists-p file2)))
+ (cond
+ ((and
+ ;; The patch program prefers the shortest file as the patch
+ ;; target. However, this is a questionable heuristic. In an
+ ;; interactive program, like ediff, we can offer the user a
+ ;; choice.
+ ;; (< (length file2) (length file1))
+ (not f1-exists)
+ f2-exists)
+ ;; replace file-pair with the winning file2
+ (setcar session-file-object file2))
+ ((and
+ ;; (< (length file1) (length file2))
+ (not f2-exists)
+ f1-exists)
+ ;; replace file-pair with the winning file1
+ (setcar session-file-object file1))
+ ((and f1-exists f2-exists
+ (string= file1 file2))
+ (setcar session-file-object file1))
+ ((and f1-exists f2-exists (eq chosen-alternative 1))
+ (setcar session-file-object file1))
+ ((and f1-exists f2-exists (eq chosen-alternative 2))
+ (setcar session-file-object file2))
+ ((and f1-exists f2-exists)
+ (with-output-to-temp-buffer ediff-msg-buffer
+ (ediff-with-current-buffer standard-output
+ (fundamental-mode))
+ (princ (format "
+Ediff has inferred that
+ %s
+ %s
+are two possible targets for applying the patch.
+Both files seem to be plausible alternatives.
+
+Please advice:
+ Type `y' to use %s as the target;
+ Type `n' to use %s as the target.
+"
+ file1 file2 file1 file2)))
+ (setcar session-file-object
+ (if (y-or-n-p (format "Use %s ? " file1))
+ (progn
+ (setq chosen-alternative 1)
+ file1)
+ (setq chosen-alternative 2)
+ file2))
+ )
+ (f2-exists (setcar session-file-object file2))
+ (f1-exists (setcar session-file-object file1))
+ (t
+ (with-output-to-temp-buffer ediff-msg-buffer
+ (ediff-with-current-buffer standard-output
+ (fundamental-mode))
+ (princ "\nEdiff has inferred that")
+ (if (string= file1 file2)
+ (princ (format "
+ %s
+is assumed to be the target for this patch. However, this file does not exist."
+ file1))
+ (princ (format "
+ %s
+ %s
+are two possible targets for this patch. However, these files do not exist."
+ file1 file2)))
+ (princ "
+\nPlease enter an alternative patch target ...\n"))
+ (let ((directory t)
+ target)
+ (while directory
+ (setq target (read-file-name
+ "Please enter a patch target: "
+ actual-dir actual-dir t))
+ (if (not (file-directory-p target))
+ (setq directory nil)
+ (beep)
+ (message "%s is a directory" target)
+ (sit-for 2)))
+ (setcar session-file-object target))))))
+ ediff-patch-map)
+ ))
+
+(defun ediff-show-patch-diagnostics ()
+ (interactive)
+ (cond ((window-live-p ediff-window-A)
+ (set-window-buffer ediff-window-A ediff-patch-diagnostics))
+ ((window-live-p ediff-window-B)
+ (set-window-buffer ediff-window-B ediff-patch-diagnostics))
+ (t (display-buffer ediff-patch-diagnostics 'not-this-window))))
+
+;; prompt for file, get the buffer
+(defun ediff-prompt-for-patch-file ()
+ (let ((dir (cond (ediff-use-last-dir ediff-last-dir-patch)
+ (ediff-patch-default-directory) ; try patch default dir
+ (t default-directory)))
+ (coding-system-for-read ediff-coding-system-for-read)
+ patch-file-name)
+ (setq patch-file-name
+ (read-file-name
+ (format "Patch is in file%s: "
+ (cond ((and buffer-file-name
+ (equal (expand-file-name dir)
+ (file-name-directory buffer-file-name)))
+ (concat
+ " (default "
+ (file-name-nondirectory buffer-file-name)
+ ")"))
+ (t "")))
+ dir buffer-file-name 'must-match))
+ (if (file-directory-p patch-file-name)
+ (error "Patch file cannot be a directory: %s" patch-file-name)
+ (find-file-noselect patch-file-name))
+ ))
+
+
+;; Try current buffer, then the other window's buffer. Else, give up.
+(defun ediff-prompt-for-patch-buffer ()
+ (get-buffer
+ (read-buffer
+ "Buffer that holds the patch: "
+ (cond ((save-excursion
+ (goto-char (point-min))
+ (re-search-forward ediff-context-diff-label-regexp nil t))
+ (current-buffer))
+ ((save-window-excursion
+ (other-window 1)
+ (save-excursion
+ (goto-char (point-min))
+ (and (re-search-forward ediff-context-diff-label-regexp nil t)
+ (current-buffer)))))
+ ((save-window-excursion
+ (other-window -1)
+ (save-excursion
+ (goto-char (point-min))
+ (and (re-search-forward ediff-context-diff-label-regexp nil t)
+ (current-buffer)))))
+ (t (ediff-other-buffer (current-buffer))))
+ 'must-match)))
+
+
+(defun ediff-get-patch-buffer (&optional arg patch-buf)
+ "Obtain patch buffer. If patch is already in a buffer---use it.
+Else, read patch file into a new buffer. If patch buffer is passed as an
+optional argument, then use it."
+ (let ((last-nonmenu-event t) ; Emacs: don't use dialog box
+ last-command-event) ; XEmacs: don't use dialog box
+
+ (cond ((ediff-buffer-live-p patch-buf))
+ ;; even prefix arg: patch in buffer
+ ((and (integerp arg) (eq 0 (mod arg 2)))
+ (setq patch-buf (ediff-prompt-for-patch-buffer)))
+ ;; odd prefix arg: get patch from a file
+ ((and (integerp arg) (eq 1 (mod arg 2)))
+ (setq patch-buf (ediff-prompt-for-patch-file)))
+ (t (setq patch-buf
+ (if (y-or-n-p "Is the patch already in a buffer? ")
+ (ediff-prompt-for-patch-buffer)
+ (ediff-prompt-for-patch-file)))))
+
+ (ediff-with-current-buffer patch-buf
+ (goto-char (point-min))
+ (or (ediff-get-visible-buffer-window patch-buf)
+ (progn
+ (pop-to-buffer patch-buf 'other-window)
+ (select-window (previous-window)))))
+ (ediff-map-patch-buffer patch-buf)
+ patch-buf))
+
+;; Dispatch the right patch file function: regular or meta-level,
+;; depending on how many patches are in the patch file.
+;; At present, there is no support for meta-level patches.
+;; Should return either the ctl buffer or the meta-buffer
+(defun ediff-dispatch-file-patching-job (patch-buf filename
+ &optional startup-hooks)
+ (ediff-with-current-buffer patch-buf
+ ;; relativize names in the patch with respect to source-file
+ (ediff-fixup-patch-map filename)
+ (if (< (length ediff-patch-map) 2)
+ (ediff-patch-file-internal
+ patch-buf
+ (if (and ediff-patch-map
+ (not (string-match
+ "^/dev/null"
+ ;; this is the file to patch
+ (ediff-get-session-objA-name (car ediff-patch-map))))
+ (> (length
+ (ediff-get-session-objA-name (car ediff-patch-map)))
+ 1))
+ (ediff-get-session-objA-name (car ediff-patch-map))
+ filename)
+ startup-hooks)
+ (ediff-multi-patch-internal patch-buf startup-hooks))
+ ))
+
+
+;; When patching a buffer, never change the orig file. Instead, create a new
+;; buffer, ***_patched, even if the buff visits a file.
+;; Users who want to actually patch the buffer should use
+;; ediff-patch-file, not ediff-patch-buffer.
+(defun ediff-patch-buffer-internal (patch-buf
+ buf-to-patch-name
+ &optional startup-hooks)
+ (let* ((buf-to-patch (get-buffer buf-to-patch-name))
+ (visited-file (if buf-to-patch (buffer-file-name buf-to-patch)))
+ (buf-mod-status (buffer-modified-p buf-to-patch))
+ (multifile-patch-p (> (length (ediff-with-current-buffer patch-buf
+ ediff-patch-map)) 1))
+ default-dir file-name ctl-buf)
+ (if multifile-patch-p
+ (error
+ "To apply multi-file patches, please use `ediff-patch-file'"))
+
+ ;; create a temp file to patch
+ (ediff-with-current-buffer buf-to-patch
+ (setq default-dir default-directory)
+ (setq file-name (ediff-make-temp-file buf-to-patch))
+ ;; temporarily switch visited file name, if any
+ (set-visited-file-name file-name)
+ ;; don't create auto-save file, if buff was visiting a file
+ (or visited-file
+ (setq buffer-auto-save-file-name nil))
+ ;; don't confuse the user with a new bufname
+ (rename-buffer buf-to-patch-name)
+ (set-buffer-modified-p nil)
+ (set-visited-file-modtime) ; sync buffer and temp file
+ (setq default-directory default-dir)
+ )
+
+ ;; dispatch a patch function
+ (setq ctl-buf (ediff-dispatch-file-patching-job
+ patch-buf file-name startup-hooks))
+
+ (ediff-with-current-buffer ctl-buf
+ (delete-file (buffer-file-name ediff-buffer-A))
+ (delete-file (buffer-file-name ediff-buffer-B))
+ (ediff-with-current-buffer ediff-buffer-A
+ (if default-dir (setq default-directory default-dir))
+ (set-visited-file-name visited-file) ; visited-file might be nil
+ (rename-buffer buf-to-patch-name)
+ (set-buffer-modified-p buf-mod-status))
+ (ediff-with-current-buffer ediff-buffer-B
+ (setq buffer-auto-save-file-name nil) ; don't create auto-save file
+ (if default-dir (setq default-directory default-dir))
+ (set-visited-file-name nil)
+ (rename-buffer (ediff-unique-buffer-name
+ (concat buf-to-patch-name "_patched") ""))
+ (set-buffer-modified-p t)))
+ ))
+
+
+;; Traditional patch has weird return codes.
+;; GNU and Posix return 1 if some hanks failed and 2 in case of trouble.
+;; 0 is a good code in all cases.
+;; We'll do the concervative thing.
+(defun ediff-patch-return-code-ok (code)
+ (eq code 0))
+;;; (if (eq (ediff-test-patch-utility) 'traditional)
+;;; (eq code 0)
+;;; (not (eq code 2))))
+
+(defun ediff-patch-file-internal (patch-buf source-filename
+ &optional startup-hooks)
+ (setq source-filename (expand-file-name source-filename))
+
+ (let* ((shell-file-name ediff-shell)
+ (patch-diagnostics (get-buffer-create "*ediff patch diagnostics*"))
+ ;; ediff-find-file may use a temp file to do the patch
+ ;; so, we save source-filename and true-source-filename as a var
+ ;; that initially is source-filename but may be changed to a temp
+ ;; file for the purpose of patching.
+ (true-source-filename source-filename)
+ (target-filename source-filename)
+ ;; this ensures that the patch process gets patch buffer in the
+ ;; encoding that Emacs thinks is right for that type of text
+ (coding-system-for-write
+ (if (boundp 'buffer-file-coding-system) buffer-file-coding-system))
+ target-buf buf-to-patch file-name-magic-p
+ patch-return-code ctl-buf backup-style aux-wind)
+
+ (if (string-match "V" ediff-patch-options)
+ (error
+ "Ediff doesn't take the -V option in `ediff-patch-options'--sorry"))
+
+ ;; Make a temp file, if source-filename has a magic file handler (or if
+ ;; it is handled via auto-mode-alist and similar magic).
+ ;; Check if there is a buffer visiting source-filename and if they are in
+ ;; sync; arrange for the deletion of temp file.
+ (ediff-find-file 'true-source-filename 'buf-to-patch
+ 'ediff-last-dir-patch 'startup-hooks)
+
+ ;; Check if source file name has triggered black magic, such as file name
+ ;; handlers or auto mode alist, and make a note of it.
+ ;; true-source-filename should be either the original name or a
+ ;; temporary file where we put the after-product of the file handler.
+ (setq file-name-magic-p (not (equal (file-truename true-source-filename)
+ (file-truename source-filename))))
+
+ ;; Checkout orig file, if necessary, so that the patched file
+ ;; could be checked back in.
+ (ediff-maybe-checkout buf-to-patch)
+
+ (ediff-with-current-buffer patch-diagnostics
+ (insert-buffer-substring patch-buf)
+ (message "Applying patch ... ")
+ ;; fix environment for gnu patch, so it won't make numbered extensions
+ (setq backup-style (getenv "VERSION_CONTROL"))
+ (setenv "VERSION_CONTROL" nil)
+ (setq patch-return-code
+ (call-process-region
+ (point-min) (point-max)
+ shell-file-name
+ t ; delete region (which contains the patch
+ t ; insert output (patch diagnostics) in current buffer
+ nil ; don't redisplay
+ shell-command-switch ; usually -c
+ (format "%s %s %s %s"
+ ediff-patch-program
+ ediff-patch-options
+ ediff-backup-specs
+ (expand-file-name true-source-filename))
+ ))
+
+ ;; restore environment for gnu patch
+ (setenv "VERSION_CONTROL" backup-style))
+
+ (message "Applying patch ... done")
+ (message "")
+
+ (switch-to-buffer patch-diagnostics)
+ (sit-for 0) ; synchronize - let the user see diagnostics
+
+ (or (and (ediff-patch-return-code-ok patch-return-code)
+ (file-exists-p
+ (concat true-source-filename ediff-backup-extension)))
+ (progn
+ (with-output-to-temp-buffer ediff-msg-buffer
+ (ediff-with-current-buffer standard-output
+ (fundamental-mode))
+ (princ (format
+ "Patch program has failed due to a bad patch file,
+it couldn't apply all hunks, OR
+it couldn't create the backup for the file being patched.
+
+The former could be caused by a corrupt patch file or because the %S
+program doesn't understand the format of the patch file in use.
+
+The second problem might be due to an incompatibility among these settings:
+ ediff-patch-program = %S ediff-patch-options = %S
+ ediff-backup-extension = %S ediff-backup-specs = %S
+
+See Ediff on-line manual for more details on these variables.
+In particular, check the documentation for `ediff-backup-specs'.
+
+In any of the above cases, Ediff doesn't compare files automatically.
+However, if the patch was applied partially and the backup file was created,
+you can still examine the changes via M-x ediff-files"
+ ediff-patch-program
+ ediff-patch-program
+ ediff-patch-options
+ ediff-backup-extension
+ ediff-backup-specs
+ )))
+ (beep 1)
+ (if (setq aux-wind (get-buffer-window ediff-msg-buffer))
+ (progn
+ (select-window aux-wind)
+ (goto-char (point-max))))
+ (switch-to-buffer-other-window patch-diagnostics)
+ (error "Patch appears to have failed")))
+
+ ;; If black magic is involved, apply patch to a temp copy of the
+ ;; file. Otherwise, apply patch to the orig copy. If patch is applied
+ ;; to temp copy, we name the result old-name_patched for local files
+ ;; and temp-copy_patched for remote files. The orig file name isn't
+ ;; changed, and the temp copy of the original is later deleted.
+ ;; Without magic, the original file is renamed (usually into
+ ;; old-name_orig) and the result of patching will have the same name as
+ ;; the original.
+ (if (not file-name-magic-p)
+ (ediff-with-current-buffer buf-to-patch
+ (set-visited-file-name
+ (concat source-filename ediff-backup-extension))
+ (set-buffer-modified-p nil))
+
+ ;; Black magic in effect.
+ ;; If orig file was remote, put the patched file in the temp directory.
+ ;; If orig file is local, put the patched file in the directory of
+ ;; the orig file.
+ (setq target-filename
+ (concat
+ (if (ediff-file-remote-p (file-truename source-filename))
+ true-source-filename
+ source-filename)
+ "_patched"))
+
+ (rename-file true-source-filename target-filename t)
+
+ ;; arrange that the temp copy of orig will be deleted
+ (rename-file (concat true-source-filename ediff-backup-extension)
+ true-source-filename t))
+
+ ;; make orig buffer read-only
+ (setq startup-hooks
+ (cons 'ediff-set-read-only-in-buf-A startup-hooks))
+
+ ;; set up a buf for the patched file
+ (setq target-buf (find-file-noselect target-filename))
+
+ (setq ctl-buf
+ (ediff-buffers-internal
+ buf-to-patch target-buf nil
+ startup-hooks 'epatch))
+ (ediff-with-current-buffer ctl-buf
+ (setq ediff-patchbufer patch-buf
+ ediff-patch-diagnostics patch-diagnostics))
+
+ (bury-buffer patch-diagnostics)
+ (message "Type `P', if you need to see patch diagnostics")
+ ctl-buf))
+
+(defun ediff-multi-patch-internal (patch-buf &optional startup-hooks)
+ (let (meta-buf)
+ (setq startup-hooks
+ ;; this sets various vars in the meta buffer inside
+ ;; ediff-prepare-meta-buffer
+ (cons `(lambda ()
+ ;; tell what to do if the user clicks on a session record
+ (setq ediff-session-action-function
+ 'ediff-patch-file-form-meta
+ ediff-meta-patchbufer patch-buf) )
+ startup-hooks))
+ (setq meta-buf (ediff-prepare-meta-buffer
+ 'ediff-filegroup-action
+ (ediff-with-current-buffer patch-buf
+ (cons (ediff-make-new-meta-list-header
+ nil ; regexp
+ (format "%S" patch-buf) ; obj A
+ nil nil ; objects B,C
+ nil ; merge-auto-store-dir
+ nil ; comparison-func
+ )
+ ediff-patch-map))
+ "*Ediff Session Group Panel"
+ 'ediff-redraw-directory-group-buffer
+ 'ediff-multifile-patch
+ startup-hooks))
+ (ediff-show-meta-buffer meta-buf)
+ ))
+
+
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: 2fe2161e-e116-469b-90fa-5cbb44c1bd1b
+;;; ediff-ptch.el ends here
--- /dev/null
+;;; ediff-util.el --- the core commands and utilities of ediff
+
+;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+(provide 'ediff-util)
+
+;; Compiler pacifier
+(defvar ediff-use-toolbar-p)
+(defvar ediff-toolbar-height)
+(defvar ediff-toolbar)
+(defvar ediff-toolbar-3way)
+(defvar bottom-toolbar)
+(defvar bottom-toolbar-visible-p)
+(defvar bottom-toolbar-height)
+(defvar mark-active)
+
+(defvar ediff-after-quit-hook-internal nil)
+
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
+(eval-when-compile
+ (require 'ediff))
+
+;; end pacifier
+
+
+(require 'ediff-init)
+(require 'ediff-help)
+(require 'ediff-mult)
+(require 'ediff-wind)
+(require 'ediff-diff)
+(require 'ediff-merg)
+;; for compatibility with current stable version of xemacs
+(if (featurep 'xemacs)
+ (require 'ediff-tbar))
+
+\f
+;;; Functions
+
+(defun ediff-mode ()
+ "Ediff mode controls all operations in a single Ediff session.
+This mode is entered through one of the following commands:
+ `ediff'
+ `ediff-files'
+ `ediff-buffers'
+ `ebuffers'
+ `ediff3'
+ `ediff-files3'
+ `ediff-buffers3'
+ `ebuffers3'
+ `ediff-merge'
+ `ediff-merge-files'
+ `ediff-merge-files-with-ancestor'
+ `ediff-merge-buffers'
+ `ediff-merge-buffers-with-ancestor'
+ `ediff-merge-revisions'
+ `ediff-merge-revisions-with-ancestor'
+ `ediff-windows-wordwise'
+ `ediff-windows-linewise'
+ `ediff-regions-wordwise'
+ `ediff-regions-linewise'
+ `epatch'
+ `ediff-patch-file'
+ `ediff-patch-buffer'
+ `epatch-buffer'
+ `erevision'
+ `ediff-revision'
+
+Commands:
+\\{ediff-mode-map}"
+ (kill-all-local-variables)
+ (setq major-mode 'ediff-mode)
+ (setq mode-name "Ediff")
+ ;; We use run-hooks instead of run-mode-hooks for two reasons.
+ ;; The ediff control buffer is read-only and it is not supposed to be
+ ;; modified by minor modes and such. So, run-mode-hooks doesn't do anything
+ ;; useful here on top of what run-hooks does.
+ ;; Second, changing run-hooks to run-mode-hooks would require an
+ ;; if-statement, since XEmacs doesn't have this.
+ (run-hooks 'ediff-mode-hook))
+
+
+\f
+;;; Build keymaps
+
+(ediff-defvar-local ediff-mode-map nil
+ "Local keymap used in Ediff mode.
+This is local to each Ediff Control Panel, so they may vary from invocation
+to invocation.")
+
+;; Set up the keymap in the control buffer
+(defun ediff-set-keys ()
+ "Set up Ediff keymap, if necessary."
+ (if (null ediff-mode-map)
+ (ediff-setup-keymap))
+ (use-local-map ediff-mode-map))
+
+;; Reload Ediff keymap. For debugging only.
+(defun ediff-reload-keymap ()
+ (interactive)
+ (setq ediff-mode-map nil)
+ (ediff-set-keys))
+
+
+(defun ediff-setup-keymap ()
+ "Set up the keymap used in the control buffer of Ediff."
+ (setq ediff-mode-map (make-sparse-keymap))
+ (suppress-keymap ediff-mode-map)
+
+ (define-key ediff-mode-map
+ (if (featurep 'emacs) [mouse-2] [button2]) 'ediff-help-for-quick-help)
+ (define-key ediff-mode-map "\C-m" 'ediff-help-for-quick-help)
+
+ (define-key ediff-mode-map "p" 'ediff-previous-difference)
+ (define-key ediff-mode-map "\C-?" 'ediff-previous-difference)
+ (define-key ediff-mode-map [delete] 'ediff-previous-difference)
+ (define-key ediff-mode-map "\C-h" (if ediff-no-emacs-help-in-control-buffer
+ 'ediff-previous-difference nil))
+ ;; must come after C-h, or else C-h wipes out backspace's binding in XEmacs
+ (define-key ediff-mode-map [backspace] 'ediff-previous-difference)
+ (define-key ediff-mode-map "n" 'ediff-next-difference)
+ (define-key ediff-mode-map " " 'ediff-next-difference)
+ (define-key ediff-mode-map "j" 'ediff-jump-to-difference)
+ (define-key ediff-mode-map "g" nil)
+ (define-key ediff-mode-map "ga" 'ediff-jump-to-difference-at-point)
+ (define-key ediff-mode-map "gb" 'ediff-jump-to-difference-at-point)
+ (define-key ediff-mode-map "q" 'ediff-quit)
+ (define-key ediff-mode-map "D" 'ediff-show-diff-output)
+ (define-key ediff-mode-map "z" 'ediff-suspend)
+ (define-key ediff-mode-map "\C-l" 'ediff-recenter)
+ (define-key ediff-mode-map "|" 'ediff-toggle-split)
+ (define-key ediff-mode-map "h" 'ediff-toggle-hilit)
+ (or ediff-word-mode
+ (define-key ediff-mode-map "@" 'ediff-toggle-autorefine))
+ (if ediff-narrow-job
+ (define-key ediff-mode-map "%" 'ediff-toggle-narrow-region))
+ (define-key ediff-mode-map "~" 'ediff-swap-buffers)
+ (define-key ediff-mode-map "v" 'ediff-scroll-vertically)
+ (define-key ediff-mode-map "\C-v" 'ediff-scroll-vertically)
+ (define-key ediff-mode-map "^" 'ediff-scroll-vertically)
+ (define-key ediff-mode-map "\M-v" 'ediff-scroll-vertically)
+ (define-key ediff-mode-map "V" 'ediff-scroll-vertically)
+ (define-key ediff-mode-map "<" 'ediff-scroll-horizontally)
+ (define-key ediff-mode-map ">" 'ediff-scroll-horizontally)
+ (define-key ediff-mode-map "i" 'ediff-status-info)
+ (define-key ediff-mode-map "E" 'ediff-documentation)
+ (define-key ediff-mode-map "?" 'ediff-toggle-help)
+ (define-key ediff-mode-map "!" 'ediff-update-diffs)
+ (define-key ediff-mode-map "M" 'ediff-show-current-session-meta-buffer)
+ (define-key ediff-mode-map "R" 'ediff-show-registry)
+ (or ediff-word-mode
+ (define-key ediff-mode-map "*" 'ediff-make-or-kill-fine-diffs))
+ (define-key ediff-mode-map "a" nil)
+ (define-key ediff-mode-map "b" nil)
+ (define-key ediff-mode-map "r" nil)
+ (cond (ediff-merge-job
+ ;; Will barf if no ancestor
+ (define-key ediff-mode-map "/" 'ediff-show-ancestor)
+ ;; In merging, we allow only A->C and B->C copying.
+ (define-key ediff-mode-map "a" 'ediff-copy-A-to-C)
+ (define-key ediff-mode-map "b" 'ediff-copy-B-to-C)
+ (define-key ediff-mode-map "r" 'ediff-restore-diff-in-merge-buffer)
+ (define-key ediff-mode-map "s" 'ediff-shrink-window-C)
+ (define-key ediff-mode-map "+" 'ediff-combine-diffs)
+ (define-key ediff-mode-map "$" nil)
+ (define-key ediff-mode-map "$$" 'ediff-toggle-show-clashes-only)
+ (define-key ediff-mode-map "$*" 'ediff-toggle-skip-changed-regions)
+ (define-key ediff-mode-map "&" 'ediff-re-merge))
+ (ediff-3way-comparison-job
+ (define-key ediff-mode-map "ab" 'ediff-copy-A-to-B)
+ (define-key ediff-mode-map "ba" 'ediff-copy-B-to-A)
+ (define-key ediff-mode-map "ac" 'ediff-copy-A-to-C)
+ (define-key ediff-mode-map "bc" 'ediff-copy-B-to-C)
+ (define-key ediff-mode-map "c" nil)
+ (define-key ediff-mode-map "ca" 'ediff-copy-C-to-A)
+ (define-key ediff-mode-map "cb" 'ediff-copy-C-to-B)
+ (define-key ediff-mode-map "ra" 'ediff-restore-diff)
+ (define-key ediff-mode-map "rb" 'ediff-restore-diff)
+ (define-key ediff-mode-map "rc" 'ediff-restore-diff)
+ (define-key ediff-mode-map "C" 'ediff-toggle-read-only))
+ (t ; 2-way comparison
+ (define-key ediff-mode-map "a" 'ediff-copy-A-to-B)
+ (define-key ediff-mode-map "b" 'ediff-copy-B-to-A)
+ (define-key ediff-mode-map "ra" 'ediff-restore-diff)
+ (define-key ediff-mode-map "rb" 'ediff-restore-diff))
+ ) ; cond
+ (define-key ediff-mode-map "G" 'ediff-submit-report)
+ (define-key ediff-mode-map "#" nil)
+ (define-key ediff-mode-map "#h" 'ediff-toggle-regexp-match)
+ (define-key ediff-mode-map "#f" 'ediff-toggle-regexp-match)
+ (define-key ediff-mode-map "#c" 'ediff-toggle-ignore-case)
+ (or ediff-word-mode
+ (define-key ediff-mode-map "##" 'ediff-toggle-skip-similar))
+ (define-key ediff-mode-map "o" nil)
+ (define-key ediff-mode-map "A" 'ediff-toggle-read-only)
+ (define-key ediff-mode-map "B" 'ediff-toggle-read-only)
+ (define-key ediff-mode-map "w" nil)
+ (define-key ediff-mode-map "wa" 'ediff-save-buffer)
+ (define-key ediff-mode-map "wb" 'ediff-save-buffer)
+ (define-key ediff-mode-map "wd" 'ediff-save-buffer)
+ (define-key ediff-mode-map "=" 'ediff-inferior-compare-regions)
+ (if (and (fboundp 'ediff-show-patch-diagnostics) (ediff-patch-job))
+ (define-key ediff-mode-map "P" 'ediff-show-patch-diagnostics))
+ (if ediff-3way-job
+ (progn
+ (define-key ediff-mode-map "wc" 'ediff-save-buffer)
+ (define-key ediff-mode-map "gc" 'ediff-jump-to-difference-at-point)
+ ))
+
+ (define-key ediff-mode-map "m" 'ediff-toggle-wide-display)
+
+ ;; Allow ediff-mode-map to be referenced indirectly
+ (fset 'ediff-mode-map ediff-mode-map)
+ (run-hooks 'ediff-keymap-setup-hook))
+
+
+;;; Setup functions
+
+;; Common startup entry for all Ediff functions It now returns control buffer
+;; so other functions can do post-processing SETUP-PARAMETERS is a list of the
+;; form ((param .val) (param . val)...) This serves a similar purpose to
+;; STARTUP-HOOKS, but these parameters are set in the new control buffer right
+;; after this buf is created and before any windows are set and such.
+(defun ediff-setup (buffer-A file-A buffer-B file-B buffer-C file-C
+ startup-hooks setup-parameters
+ &optional merge-buffer-file)
+ (run-hooks 'ediff-before-setup-hook)
+ ;; ediff-convert-standard-filename puts file names in the form appropriate
+ ;; for the OS at hand.
+ (setq file-A (ediff-convert-standard-filename (expand-file-name file-A)))
+ (setq file-B (ediff-convert-standard-filename (expand-file-name file-B)))
+ (if (stringp file-C)
+ (setq file-C
+ (ediff-convert-standard-filename (expand-file-name file-C))))
+ (if (stringp merge-buffer-file)
+ (progn
+ (setq merge-buffer-file
+ (ediff-convert-standard-filename
+ (expand-file-name merge-buffer-file)))
+ ;; check the directory exists
+ (or (file-exists-p (file-name-directory merge-buffer-file))
+ (error "Directory %s given as place to save the merge doesn't exist"
+ (abbreviate-file-name
+ (file-name-directory merge-buffer-file))))
+ (if (and (file-exists-p merge-buffer-file)
+ (file-directory-p merge-buffer-file))
+ (error "The merge buffer file %s must not be a directory"
+ (abbreviate-file-name merge-buffer-file)))
+ ))
+ (let* ((control-buffer-name
+ (ediff-unique-buffer-name "*Ediff Control Panel" "*"))
+ (control-buffer (ediff-with-current-buffer buffer-A
+ (get-buffer-create control-buffer-name))))
+ (ediff-with-current-buffer control-buffer
+ (ediff-mode)
+
+ (make-local-variable 'ediff-use-long-help-message)
+ (make-local-variable 'ediff-prefer-iconified-control-frame)
+ (make-local-variable 'ediff-split-window-function)
+ (make-local-variable 'ediff-default-variant)
+ (make-local-variable 'ediff-merge-window-share)
+ (make-local-variable 'ediff-window-setup-function)
+ (make-local-variable 'ediff-keep-variants)
+
+ (make-local-variable 'window-min-height)
+ (setq window-min-height 2)
+
+ (if (featurep 'xemacs)
+ (make-local-hook 'ediff-after-quit-hook-internal))
+
+ ;; unwrap set up parameters passed as argument
+ (while setup-parameters
+ (set (car (car setup-parameters)) (cdr (car setup-parameters)))
+ (setq setup-parameters (cdr setup-parameters)))
+
+ ;; set variables classifying the current ediff job
+ ;; must come AFTER setup-parameters
+ (setq ediff-3way-comparison-job (ediff-3way-comparison-job)
+ ediff-merge-job (ediff-merge-job)
+ ediff-merge-with-ancestor-job (ediff-merge-with-ancestor-job)
+ ediff-3way-job (ediff-3way-job)
+ ediff-diff3-job (ediff-diff3-job)
+ ediff-narrow-job (ediff-narrow-job)
+ ediff-windows-job (ediff-windows-job)
+ ediff-word-mode-job (ediff-word-mode-job))
+
+ ;; Don't delete variants in case of ediff-buffer-* jobs without asking.
+ ;; This is because one may loose work---dangerous.
+ (if (string-match "buffer" (symbol-name ediff-job-name))
+ (setq ediff-keep-variants t))
+
+ (if (featurep 'xemacs)
+ (make-local-hook 'pre-command-hook))
+
+ (if (ediff-window-display-p)
+ (add-hook 'pre-command-hook 'ediff-spy-after-mouse nil 'local))
+ (setq ediff-mouse-pixel-position (mouse-pixel-position))
+
+ ;; adjust for merge jobs
+ (if ediff-merge-job
+ (let ((buf
+ ;; If default variant is `combined', the right stuff is
+ ;; inserted by ediff-do-merge
+ ;; Note: at some point, we tried to put ancestor buffer here
+ ;; (which is currently buffer C. This didn't work right
+ ;; because the merge buffer will contain lossage: diff regions
+ ;; in the ancestor, which correspond to revisions that agree
+ ;; in both buf A and B.
+ (cond ((eq ediff-default-variant 'default-B)
+ buffer-B)
+ (t buffer-A))))
+
+ (setq ediff-split-window-function
+ ediff-merge-split-window-function)
+
+ ;; remember the ancestor buffer, if any
+ (setq ediff-ancestor-buffer buffer-C)
+
+ (setq buffer-C
+ (get-buffer-create
+ (ediff-unique-buffer-name "*ediff-merge" "*")))
+ (with-current-buffer buffer-C
+ (insert-buffer-substring buf)
+ (goto-char (point-min))
+ (funcall (ediff-with-current-buffer buf major-mode))
+ (widen) ; merge buffer is always widened
+ (add-hook 'local-write-file-hooks 'ediff-set-merge-mode nil t)
+ )))
+ (setq buffer-read-only nil
+ ediff-buffer-A buffer-A
+ ediff-buffer-B buffer-B
+ ediff-buffer-C buffer-C
+ ediff-control-buffer control-buffer)
+
+ (ediff-choose-syntax-table)
+
+ (setq ediff-control-buffer-suffix
+ (if (string-match "<[0-9]*>" control-buffer-name)
+ (substring control-buffer-name
+ (match-beginning 0) (match-end 0))
+ "")
+ ediff-control-buffer-number
+ (max
+ 0
+ (1-
+ (string-to-number
+ (substring
+ ediff-control-buffer-suffix
+ (or
+ (string-match "[0-9]+" ediff-control-buffer-suffix)
+ 0))))))
+
+ (setq ediff-error-buffer
+ (get-buffer-create (ediff-unique-buffer-name "*ediff-errors" "*")))
+
+ (with-current-buffer ediff-error-buffer
+ (setq buffer-undo-list t))
+
+ (ediff-with-current-buffer buffer-A (ediff-strip-mode-line-format))
+ (ediff-with-current-buffer buffer-B (ediff-strip-mode-line-format))
+ (if ediff-3way-job
+ (ediff-with-current-buffer buffer-C (ediff-strip-mode-line-format)))
+ (if (ediff-buffer-live-p ediff-ancestor-buffer)
+ (ediff-with-current-buffer ediff-ancestor-buffer
+ (ediff-strip-mode-line-format)))
+
+ (ediff-save-protected-variables) ; save variables to be restored on exit
+
+ ;; ediff-setup-diff-regions-function must be set after setup
+ ;; parameters are processed.
+ (setq ediff-setup-diff-regions-function
+ (if ediff-diff3-job
+ 'ediff-setup-diff-regions3
+ 'ediff-setup-diff-regions))
+
+ (setq ediff-wide-bounds
+ (list (ediff-make-bullet-proof-overlay
+ '(point-min) '(point-max) ediff-buffer-A)
+ (ediff-make-bullet-proof-overlay
+ '(point-min) '(point-max) ediff-buffer-B)
+ (ediff-make-bullet-proof-overlay
+ '(point-min) '(point-max) ediff-buffer-C)))
+
+ ;; This has effect only on ediff-windows/regions
+ ;; In all other cases, ediff-visible-region sets visibility bounds to
+ ;; ediff-wide-bounds, and ediff-narrow-bounds are ignored.
+ (if ediff-start-narrowed
+ (setq ediff-visible-bounds ediff-narrow-bounds)
+ (setq ediff-visible-bounds ediff-wide-bounds))
+
+ (ediff-set-keys) ; comes after parameter setup
+
+ ;; set up ediff-narrow-bounds, if not set
+ (or ediff-narrow-bounds
+ (setq ediff-narrow-bounds ediff-wide-bounds))
+
+ ;; All these must be inside ediff-with-current-buffer control-buffer,
+ ;; since these vars are local to control-buffer
+ ;; These won't run if there are errors in diff
+ (ediff-with-current-buffer ediff-buffer-A
+ (ediff-nuke-selective-display)
+ (run-hooks 'ediff-prepare-buffer-hook)
+ (if (ediff-with-current-buffer control-buffer ediff-merge-job)
+ (setq buffer-read-only t))
+ ;; add control-buffer to the list of sessions--no longer used, but may
+ ;; be used again in the future
+ (or (memq control-buffer ediff-this-buffer-ediff-sessions)
+ (setq ediff-this-buffer-ediff-sessions
+ (cons control-buffer ediff-this-buffer-ediff-sessions)))
+ (if ediff-make-buffers-readonly-at-startup
+ (setq buffer-read-only t))
+ )
+
+ (ediff-with-current-buffer ediff-buffer-B
+ (ediff-nuke-selective-display)
+ (run-hooks 'ediff-prepare-buffer-hook)
+ (if (ediff-with-current-buffer control-buffer ediff-merge-job)
+ (setq buffer-read-only t))
+ ;; add control-buffer to the list of sessions
+ (or (memq control-buffer ediff-this-buffer-ediff-sessions)
+ (setq ediff-this-buffer-ediff-sessions
+ (cons control-buffer ediff-this-buffer-ediff-sessions)))
+ (if ediff-make-buffers-readonly-at-startup
+ (setq buffer-read-only t))
+ )
+
+ (if ediff-3way-job
+ (ediff-with-current-buffer ediff-buffer-C
+ (ediff-nuke-selective-display)
+ ;; the merge bufer should never be narrowed
+ ;; (it can happen if it is on rmail-mode or similar)
+ (if (ediff-with-current-buffer control-buffer ediff-merge-job)
+ (widen))
+ (run-hooks 'ediff-prepare-buffer-hook)
+ ;; add control-buffer to the list of sessions
+ (or (memq control-buffer ediff-this-buffer-ediff-sessions)
+ (setq ediff-this-buffer-ediff-sessions
+ (cons control-buffer
+ ediff-this-buffer-ediff-sessions)))
+ (if ediff-make-buffers-readonly-at-startup
+ (setq buffer-read-only t)
+ (setq buffer-read-only nil))
+ ))
+
+ (if (ediff-buffer-live-p ediff-ancestor-buffer)
+ (ediff-with-current-buffer ediff-ancestor-buffer
+ (ediff-nuke-selective-display)
+ (setq buffer-read-only t)
+ (run-hooks 'ediff-prepare-buffer-hook)
+ (or (memq control-buffer ediff-this-buffer-ediff-sessions)
+ (setq ediff-this-buffer-ediff-sessions
+ (cons control-buffer
+ ediff-this-buffer-ediff-sessions)))
+ ))
+
+ ;; the following must be after setting up ediff-narrow-bounds AND after
+ ;; nuking selective display
+ (funcall ediff-setup-diff-regions-function file-A file-B file-C)
+ (setq ediff-number-of-differences (length ediff-difference-vector-A))
+ (setq ediff-current-difference -1)
+
+ (ediff-make-current-diff-overlay 'A)
+ (ediff-make-current-diff-overlay 'B)
+ (if ediff-3way-job
+ (ediff-make-current-diff-overlay 'C))
+ (if ediff-merge-with-ancestor-job
+ (ediff-make-current-diff-overlay 'Ancestor))
+
+ (ediff-setup-windows buffer-A buffer-B buffer-C control-buffer)
+
+ (let ((shift-A (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'A ediff-narrow-bounds)))
+ (shift-B (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'B ediff-narrow-bounds)))
+ (shift-C (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'C ediff-narrow-bounds))))
+ ;; position point in buf A
+ (save-excursion
+ (select-window ediff-window-A)
+ (goto-char shift-A))
+ ;; position point in buf B
+ (save-excursion
+ (select-window ediff-window-B)
+ (goto-char shift-B))
+ (if ediff-3way-job
+ (save-excursion
+ (select-window ediff-window-C)
+ (goto-char shift-C)))
+ )
+
+ (select-window ediff-control-window)
+ (ediff-visible-region)
+
+ (run-hooks 'startup-hooks)
+ (ediff-arrange-autosave-in-merge-jobs merge-buffer-file)
+
+ (ediff-refresh-mode-lines)
+ (setq buffer-read-only t)
+ (setq ediff-session-registry
+ (cons control-buffer ediff-session-registry))
+ (ediff-update-registry)
+ (if (ediff-buffer-live-p ediff-meta-buffer)
+ (ediff-update-meta-buffer
+ ediff-meta-buffer nil ediff-meta-session-number))
+ (run-hooks 'ediff-startup-hook)
+ ) ; eval in control-buffer
+ control-buffer))
+
+
+;; This function assumes that we are in the window where control buffer is
+;; to reside.
+(defun ediff-setup-control-buffer (ctl-buf)
+ "Set up window for control buffer."
+ (if (window-dedicated-p (selected-window))
+ (set-buffer ctl-buf) ; we are in control frame but just in case
+ (switch-to-buffer ctl-buf))
+ (let ((window-min-height 2))
+ (erase-buffer)
+ (ediff-set-help-message)
+ (insert ediff-help-message)
+ (shrink-window-if-larger-than-buffer)
+ (or (ediff-multiframe-setup-p)
+ (ediff-indent-help-message))
+ (ediff-set-help-overlays)
+
+ (set-buffer-modified-p nil)
+ (ediff-refresh-mode-lines)
+ (setq ediff-control-window (selected-window))
+ (setq ediff-window-config-saved
+ (format "%S%S%S%S%S%S%S"
+ ediff-control-window
+ ediff-window-A
+ ediff-window-B
+ ediff-window-C
+ ediff-split-window-function
+ (ediff-multiframe-setup-p)
+ ediff-wide-display-p))
+
+ (set-window-dedicated-p (selected-window) t)
+ ;; In multiframe, toolbar is set in ediff-setup-control-frame
+ (if (not (ediff-multiframe-setup-p))
+ (ediff-make-bottom-toolbar)) ; this checks if toolbar is requested
+ (goto-char (point-min))
+ (skip-chars-forward ediff-whitespace)))
+
+;; This executes in control buffer and sets auto-save, visited file name, etc,
+;; in the merge buffer
+(defun ediff-arrange-autosave-in-merge-jobs (merge-buffer-file)
+ (if (not ediff-merge-job)
+ ()
+ (if (stringp merge-buffer-file)
+ (setq ediff-autostore-merges t
+ ediff-merge-store-file merge-buffer-file))
+ (if (stringp ediff-merge-store-file)
+ (progn
+ ;; save before leaving ctl buffer
+ (ediff-verify-file-merge-buffer ediff-merge-store-file)
+ (setq merge-buffer-file ediff-merge-store-file)
+ (ediff-with-current-buffer ediff-buffer-C
+ (set-visited-file-name merge-buffer-file))))
+ (ediff-with-current-buffer ediff-buffer-C
+ (setq buffer-offer-save t) ; ask before killing buffer
+ ;; make sure the contents is auto-saved
+ (auto-save-mode 1))
+ ))
+
+\f
+;;; Commands for working with Ediff
+
+(defun ediff-update-diffs ()
+ "Recompute difference regions in buffers A, B, and C.
+Buffers are not synchronized with their respective files, so changes done
+to these buffers are not saved at this point---the user can do this later,
+if necessary."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (if (and (ediff-buffer-live-p ediff-ancestor-buffer)
+ (not
+ (y-or-n-p
+ "Ancestor buffer will not be used. Recompute diffs anyway? ")))
+ (error "Recomputation of differences canceled"))
+
+ (let ((point-A (ediff-with-current-buffer ediff-buffer-A (point)))
+ ;;(point-B (ediff-with-current-buffer ediff-buffer-B (point)))
+ (tmp-buffer (get-buffer-create ediff-tmp-buffer))
+ (buf-A-file-name (buffer-file-name ediff-buffer-A))
+ (buf-B-file-name (buffer-file-name ediff-buffer-B))
+ ;; (null ediff-buffer-C) is no problem, as we later check if
+ ;; ediff-buffer-C is alive
+ (buf-C-file-name (buffer-file-name ediff-buffer-C))
+ (overl-A (ediff-get-value-according-to-buffer-type
+ 'A ediff-narrow-bounds))
+ (overl-B (ediff-get-value-according-to-buffer-type
+ 'B ediff-narrow-bounds))
+ (overl-C (ediff-get-value-according-to-buffer-type
+ 'C ediff-narrow-bounds))
+ beg-A end-A beg-B end-B beg-C end-C
+ file-A file-B file-C)
+
+ (if (stringp buf-A-file-name)
+ (setq buf-A-file-name (file-name-nondirectory buf-A-file-name)))
+ (if (stringp buf-B-file-name)
+ (setq buf-B-file-name (file-name-nondirectory buf-B-file-name)))
+ (if (stringp buf-C-file-name)
+ (setq buf-C-file-name (file-name-nondirectory buf-C-file-name)))
+
+ (ediff-unselect-and-select-difference -1)
+
+ (setq beg-A (ediff-overlay-start overl-A)
+ beg-B (ediff-overlay-start overl-B)
+ beg-C (ediff-overlay-start overl-C)
+ end-A (ediff-overlay-end overl-A)
+ end-B (ediff-overlay-end overl-B)
+ end-C (ediff-overlay-end overl-C))
+
+ (if ediff-word-mode
+ (progn
+ (ediff-wordify beg-A end-A ediff-buffer-A tmp-buffer)
+ (setq file-A (ediff-make-temp-file tmp-buffer "regA"))
+ (ediff-wordify beg-B end-B ediff-buffer-B tmp-buffer)
+ (setq file-B (ediff-make-temp-file tmp-buffer "regB"))
+ (if ediff-3way-job
+ (progn
+ (ediff-wordify beg-C end-C ediff-buffer-C tmp-buffer)
+ (setq file-C (ediff-make-temp-file tmp-buffer "regC"))))
+ )
+ ;; not word-mode
+ (setq file-A (ediff-make-temp-file ediff-buffer-A buf-A-file-name))
+ (setq file-B (ediff-make-temp-file ediff-buffer-B buf-B-file-name))
+ (if ediff-3way-job
+ (setq file-C (ediff-make-temp-file ediff-buffer-C buf-C-file-name)))
+ )
+
+ (ediff-clear-diff-vector 'ediff-difference-vector-A 'fine-diffs-also)
+ (ediff-clear-diff-vector 'ediff-difference-vector-B 'fine-diffs-also)
+ (ediff-clear-diff-vector 'ediff-difference-vector-C 'fine-diffs-also)
+ (ediff-clear-diff-vector
+ 'ediff-difference-vector-Ancestor 'fine-diffs-also)
+ ;; let them garbage collect. we can't use the ancestor after recomputing
+ ;; the diffs.
+ (setq ediff-difference-vector-Ancestor nil
+ ediff-ancestor-buffer nil
+ ediff-state-of-merge nil)
+
+ (setq ediff-killed-diffs-alist nil) ; invalidate saved killed diff regions
+
+ ;; In case of merge job, fool it into thinking that it is just doing
+ ;; comparison
+ (let ((ediff-setup-diff-regions-function ediff-setup-diff-regions-function)
+ (ediff-3way-comparison-job ediff-3way-comparison-job)
+ (ediff-merge-job ediff-merge-job)
+ (ediff-merge-with-ancestor-job ediff-merge-with-ancestor-job)
+ (ediff-job-name ediff-job-name))
+ (if ediff-merge-job
+ (setq ediff-setup-diff-regions-function 'ediff-setup-diff-regions3
+ ediff-3way-comparison-job t
+ ediff-merge-job nil
+ ediff-merge-with-ancestor-job nil
+ ediff-job-name 'ediff-files3))
+ (funcall ediff-setup-diff-regions-function file-A file-B file-C))
+
+ (setq ediff-number-of-differences (length ediff-difference-vector-A))
+ (delete-file file-A)
+ (delete-file file-B)
+ (if file-C
+ (delete-file file-C))
+
+ (if ediff-3way-job
+ (ediff-set-state-of-all-diffs-in-all-buffers ediff-control-buffer))
+
+ (ediff-jump-to-difference (ediff-diff-at-point 'A point-A))
+ (message "")
+ ))
+
+;; Not bound to any key---to dangerous. A user can do it if necessary.
+(defun ediff-revert-buffers-then-recompute-diffs (noconfirm)
+ "Revert buffers A, B and C. Then rerun Ediff on file A and file B."
+ (interactive "P")
+ (ediff-barf-if-not-control-buffer)
+ (let ((bufA ediff-buffer-A)
+ (bufB ediff-buffer-B)
+ (bufC ediff-buffer-C)
+ (ctl-buf ediff-control-buffer)
+ (keep-variants ediff-keep-variants)
+ (ancestor-buf ediff-ancestor-buffer)
+ (ancestor-job ediff-merge-with-ancestor-job)
+ (merge ediff-merge-job)
+ (comparison ediff-3way-comparison-job))
+ (ediff-with-current-buffer bufA
+ (revert-buffer t noconfirm))
+ (ediff-with-current-buffer bufB
+ (revert-buffer t noconfirm))
+ ;; this should only be executed in a 3way comparison, not in merge
+ (if comparison
+ (ediff-with-current-buffer bufC
+ (revert-buffer t noconfirm)))
+ (if merge
+ (progn
+ (set-buffer ctl-buf)
+ ;; the argument says whether to reverse the meaning of
+ ;; ediff-keep-variants, i.e., ediff-really-quit runs here with
+ ;; variants kept.
+ (ediff-really-quit (not keep-variants))
+ (kill-buffer bufC)
+ (if ancestor-job
+ (ediff-merge-buffers-with-ancestor bufA bufB ancestor-buf)
+ (ediff-merge-buffers bufA bufB)))
+ (ediff-update-diffs))))
+
+
+;; optional NO-REHIGHLIGHT says to not rehighlight buffers
+(defun ediff-recenter (&optional no-rehighlight)
+ "Bring the highlighted region of all buffers being compared into view.
+Reestablish the default three-window display."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (let (buffer-read-only)
+ (if (and (ediff-buffer-live-p ediff-buffer-A)
+ (ediff-buffer-live-p ediff-buffer-B)
+ (or (not ediff-3way-job)
+ (ediff-buffer-live-p ediff-buffer-C)))
+ (ediff-setup-windows
+ ediff-buffer-A ediff-buffer-B ediff-buffer-C ediff-control-buffer)
+ (or (eq this-command 'ediff-quit)
+ (message ediff-KILLED-VITAL-BUFFER
+ (beep 1)))
+ ))
+
+ ;; set visibility range appropriate to this invocation of Ediff.
+ (ediff-visible-region)
+ ;; raise
+ (if (and (ediff-window-display-p)
+ (symbolp this-command)
+ (symbolp last-command)
+ ;; Either one of the display-changing commands
+ (or (memq this-command
+ '(ediff-recenter
+ ediff-dir-action ediff-registry-action
+ ediff-patch-action
+ ediff-toggle-wide-display ediff-toggle-multiframe))
+ ;; Or one of the movement cmds and prev cmd was an Ediff cmd
+ ;; This avoids raising frames unnecessarily.
+ (and (memq this-command
+ '(ediff-next-difference
+ ediff-previous-difference
+ ediff-jump-to-difference
+ ediff-jump-to-difference-at-point))
+ (not (string-match "^ediff-" (symbol-name last-command)))
+ )))
+ (progn
+ (if (window-live-p ediff-window-A)
+ (raise-frame (window-frame ediff-window-A)))
+ (if (window-live-p ediff-window-B)
+ (raise-frame (window-frame ediff-window-B)))
+ (if (window-live-p ediff-window-C)
+ (raise-frame (window-frame ediff-window-C)))))
+ (if (and (ediff-window-display-p)
+ (frame-live-p ediff-control-frame)
+ (not ediff-use-long-help-message)
+ (not (ediff-frame-iconified-p ediff-control-frame)))
+ (raise-frame ediff-control-frame))
+
+ ;; Redisplay whatever buffers are showing, if there is a selected difference
+ (let ((control-frame ediff-control-frame)
+ (control-buf ediff-control-buffer))
+ (if (and (ediff-buffer-live-p ediff-buffer-A)
+ (ediff-buffer-live-p ediff-buffer-B)
+ (or (not ediff-3way-job)
+ (ediff-buffer-live-p ediff-buffer-C)))
+ (progn
+ (or no-rehighlight
+ (ediff-select-difference ediff-current-difference))
+
+ (ediff-recenter-one-window 'A)
+ (ediff-recenter-one-window 'B)
+ (if ediff-3way-job
+ (ediff-recenter-one-window 'C))
+
+ (ediff-with-current-buffer control-buf
+ (ediff-recenter-ancestor) ; check if ancestor is alive
+
+ (if (and (ediff-multiframe-setup-p)
+ (not ediff-use-long-help-message)
+ (not (ediff-frame-iconified-p ediff-control-frame)))
+ ;; never grab mouse on quit in this place
+ (ediff-reset-mouse
+ control-frame
+ (eq this-command 'ediff-quit))))
+ ))
+
+ (or no-rehighlight
+ (ediff-restore-highlighting))
+ (ediff-with-current-buffer control-buf (ediff-refresh-mode-lines))
+ ))
+
+;; this function returns to the window it was called from
+;; (which was the control window)
+(defun ediff-recenter-one-window (buf-type)
+ (if (ediff-valid-difference-p)
+ ;; context must be saved before switching to windows A/B/C
+ (let* ((ctl-wind (selected-window))
+ (shift (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ buf-type ediff-narrow-bounds)))
+ (job-name ediff-job-name)
+ (control-buf ediff-control-buffer)
+ (window-name (ediff-get-symbol-from-alist
+ buf-type ediff-window-alist))
+ (window (if (window-live-p (symbol-value window-name))
+ (symbol-value window-name))))
+
+ (if (and window ediff-windows-job)
+ (set-window-start window shift))
+ (if window
+ (progn
+ (select-window window)
+ (ediff-deactivate-mark)
+ (ediff-position-region
+ (ediff-get-diff-posn buf-type 'beg nil control-buf)
+ (ediff-get-diff-posn buf-type 'end nil control-buf)
+ (ediff-get-diff-posn buf-type 'beg nil control-buf)
+ job-name
+ )))
+ (select-window ctl-wind)
+ )))
+
+(defun ediff-recenter-ancestor ()
+ ;; do half-hearted job by recentering the ancestor buffer, if it is alive and
+ ;; visible.
+ (if (and (ediff-buffer-live-p ediff-ancestor-buffer)
+ (ediff-valid-difference-p))
+ (let ((window (ediff-get-visible-buffer-window ediff-ancestor-buffer))
+ (ctl-wind (selected-window))
+ (job-name ediff-job-name)
+ (ctl-buf ediff-control-buffer))
+ (ediff-with-current-buffer ediff-ancestor-buffer
+ (goto-char (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf))
+ (if window
+ (progn
+ (select-window window)
+ (ediff-position-region
+ (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf)
+ (ediff-get-diff-posn 'Ancestor 'end nil ctl-buf)
+ (ediff-get-diff-posn 'Ancestor 'beg nil ctl-buf)
+ job-name))))
+ (select-window ctl-wind)
+ )))
+
+
+;; This will have to be refined for 3way jobs
+(defun ediff-toggle-split ()
+ "Toggle vertical/horizontal window split.
+Does nothing if file-A and file-B are in different frames."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (let* ((wind-A (if (window-live-p ediff-window-A) ediff-window-A))
+ (wind-B (if (window-live-p ediff-window-B) ediff-window-B))
+ (wind-C (if (window-live-p ediff-window-C) ediff-window-C))
+ (frame-A (if wind-A (window-frame wind-A)))
+ (frame-B (if wind-B (window-frame wind-B)))
+ (frame-C (if wind-C (window-frame wind-C))))
+ (if (or (eq frame-A frame-B)
+ (not (frame-live-p frame-A))
+ (not (frame-live-p frame-B))
+ (if ediff-3way-comparison-job
+ (or (not (frame-live-p frame-C))
+ (eq frame-A frame-C) (eq frame-B frame-C))))
+ (setq ediff-split-window-function
+ (if (eq ediff-split-window-function 'split-window-vertically)
+ 'split-window-horizontally
+ 'split-window-vertically))
+ (message "Buffers being compared are in different frames"))
+ (ediff-recenter 'no-rehighlight)))
+
+(defun ediff-toggle-hilit ()
+ "Switch between highlighting using ASCII flags and highlighting using faces.
+On a dumb terminal, switches between ASCII highlighting and no highlighting."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+
+ (ediff-unselect-and-select-difference
+ ediff-current-difference 'unselect-only)
+ ;; cycle through highlighting
+ (cond ((and ediff-use-faces
+ (ediff-has-face-support-p)
+ ediff-highlight-all-diffs)
+ (message "Unhighlighting unselected difference regions")
+ (setq ediff-highlight-all-diffs nil
+ ediff-highlighting-style 'face))
+ ((or (and ediff-use-faces (ediff-has-face-support-p)
+ (eq ediff-highlighting-style 'face)) ; has face support
+ (and (not (ediff-has-face-support-p)) ; no face support
+ (eq ediff-highlighting-style 'off)))
+ (message "Highlighting with ASCII flags")
+ (setq ediff-highlighting-style 'ascii
+ ediff-highlight-all-diffs nil
+ ediff-use-faces nil))
+ ((eq ediff-highlighting-style 'ascii)
+ (message "ASCII highlighting flags removed")
+ (setq ediff-highlighting-style 'off
+ ediff-highlight-all-diffs nil))
+ ((ediff-has-face-support-p) ; catch-all for cases with face support
+ (message "Re-highlighting all difference regions")
+ (setq ediff-use-faces t
+ ediff-highlighting-style 'face
+ ediff-highlight-all-diffs t)))
+
+ (if (and ediff-use-faces ediff-highlight-all-diffs)
+ (ediff-paint-background-regions)
+ (ediff-paint-background-regions 'unhighlight))
+
+ (ediff-unselect-and-select-difference
+ ediff-current-difference 'select-only))
+
+
+(defun ediff-toggle-autorefine ()
+ "Toggle auto-refine mode."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (if ediff-word-mode
+ (error "No fine differences in this mode"))
+ (cond ((eq ediff-auto-refine 'nix)
+ (setq ediff-auto-refine 'on)
+ (ediff-make-fine-diffs ediff-current-difference 'noforce)
+ (message "Auto-refining is ON"))
+ ((eq ediff-auto-refine 'on)
+ (message "Auto-refining is OFF")
+ (setq ediff-auto-refine 'off))
+ (t ;; nix 'em
+ (ediff-set-fine-diff-properties ediff-current-difference 'default)
+ (message "Refinements are HIDDEN")
+ (setq ediff-auto-refine 'nix))
+ ))
+
+(defun ediff-show-ancestor ()
+ "Show the ancestor buffer in a suitable window."
+ (interactive)
+ (ediff-recenter)
+ (or (ediff-buffer-live-p ediff-ancestor-buffer)
+ (if ediff-merge-with-ancestor-job
+ (error "Lost connection to ancestor buffer...sorry")
+ (error "Not merging with ancestor")))
+ (let (wind)
+ (cond ((setq wind (ediff-get-visible-buffer-window ediff-ancestor-buffer))
+ (raise-frame (window-frame wind)))
+ (t (set-window-buffer ediff-window-C ediff-ancestor-buffer)))))
+
+(defun ediff-make-or-kill-fine-diffs (arg)
+ "Compute fine diffs. With negative prefix arg, kill fine diffs.
+In both cases, operates on the current difference region."
+ (interactive "P")
+ (ediff-barf-if-not-control-buffer)
+ (cond ((eq arg '-)
+ (ediff-clear-fine-differences ediff-current-difference))
+ ((and (numberp arg) (< arg 0))
+ (ediff-clear-fine-differences ediff-current-difference))
+ (t (ediff-make-fine-diffs))))
+
+
+(defun ediff-toggle-help ()
+ "Toggle short/long help message."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (let (buffer-read-only)
+ (erase-buffer)
+ (setq ediff-use-long-help-message (not ediff-use-long-help-message))
+ (ediff-set-help-message))
+ ;; remember the icon status of the control frame when the user requested
+ ;; full control message
+ (if (and ediff-use-long-help-message (ediff-multiframe-setup-p))
+ (setq ediff-prefer-iconified-control-frame
+ (ediff-frame-iconified-p ediff-control-frame)))
+
+ (setq ediff-window-config-saved "") ; force redisplay
+ (ediff-recenter 'no-rehighlight))
+
+
+;; If BUF, this is the buffer to toggle, not current buffer.
+(defun ediff-toggle-read-only (&optional buf)
+ "Toggle read-only in current buffer.
+If buffer is under version control and locked, check it out first.
+If optional argument BUF is specified, toggle read-only in that buffer instead
+of the current buffer."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (let ((ctl-buf (if (null buf) (current-buffer)))
+ (buf-type (ediff-char-to-buftype (ediff-last-command-char))))
+ (or buf (ediff-recenter))
+ (or buf
+ (setq buf (ediff-get-buffer buf-type)))
+
+ (ediff-with-current-buffer buf ; eval in buf A/B/C
+ (let* ((file (buffer-file-name buf))
+ (file-writable (and file
+ (file-exists-p file)
+ (file-writable-p file)))
+ (toggle-ro-cmd (cond (ediff-toggle-read-only-function)
+ ((ediff-file-checked-out-p file)
+ 'toggle-read-only)
+ (file-writable 'toggle-read-only)
+ (t (key-binding "\C-x\C-q")))))
+ ;; If the file is checked in, make sure we don't make buffer modifiable
+ ;; without warning the user. The user can fool our checks by making the
+ ;; buffer non-RO without checking the file out. We regard this as a
+ ;; user problem.
+ (if (and (ediff-file-checked-in-p file)
+ ;; If ctl-buf is null, this means we called this
+ ;; non-interactively, in which case don't ask questions
+ ctl-buf)
+ (cond ((not buffer-read-only)
+ (setq toggle-ro-cmd 'toggle-read-only))
+ ((and (or (beep 1) t) ; always beep
+ (y-or-n-p
+ (format
+ "File %s is under version control. Check it out? "
+ (ediff-abbreviate-file-name file))))
+ ;; if we checked the file out, we should also change the
+ ;; original state of buffer-read-only to nil. If we don't
+ ;; do this, the mode line will show %%, since the file was
+ ;; RO before ediff started, so the user will think the file
+ ;; is checked in.
+ (ediff-with-current-buffer ctl-buf
+ (ediff-change-saved-variable
+ 'buffer-read-only nil buf-type)))
+ (t
+ (setq toggle-ro-cmd 'toggle-read-only)
+ (beep 1) (beep 1)
+ (message
+ "Boy, this is risky! Don't modify this file...")
+ (sit-for 3)))) ; let the user see the warning
+ (if (and toggle-ro-cmd
+ (string-match "toggle-read-only" (symbol-name toggle-ro-cmd)))
+ (save-excursion
+ (save-window-excursion
+ (select-window (ediff-get-visible-buffer-window buf))
+ (command-execute toggle-ro-cmd)))
+ (error "Don't know how to toggle read-only in buffer %S" buf))
+
+ ;; Check if we made the current buffer updatable, but its file is RO.
+ ;; Signal a warning in this case.
+ (if (and file (not buffer-read-only)
+ (eq this-command 'ediff-toggle-read-only)
+ (file-exists-p file)
+ (not (file-writable-p file)))
+ (progn
+ (beep 1)
+ (message "Warning: file %s is read-only"
+ (ediff-abbreviate-file-name file))))
+ ))))
+
+;; checkout if visited file is checked in
+(defun ediff-maybe-checkout (buf)
+ (let ((file (expand-file-name (buffer-file-name buf)))
+ (checkout-function (key-binding "\C-x\C-q")))
+ (if (and (ediff-file-checked-in-p file)
+ (or (beep 1) t)
+ (y-or-n-p
+ (format
+ "File %s is under version control. Check it out? "
+ (ediff-abbreviate-file-name file))))
+ (ediff-with-current-buffer buf
+ (command-execute checkout-function)))))
+
+
+;; This is a simple-minded check for whether a file is under version control.
+;; If file,v exists but file doesn't, this file is considered to be not checked
+;; in and not checked out for the purpose of patching (since patch won't be
+;; able to read such a file anyway).
+;; FILE is a string representing file name
+;;(defun ediff-file-under-version-control (file)
+;; (let* ((filedir (file-name-directory file))
+;; (file-nondir (file-name-nondirectory file))
+;; (trial (concat file-nondir ",v"))
+;; (full-trial (concat filedir trial))
+;; (full-rcs-trial (concat filedir "RCS/" trial)))
+;; (and (stringp file)
+;; (file-exists-p file)
+;; (or
+;; (and
+;; (file-exists-p full-trial)
+;; ;; in FAT FS, `file,v' and `file' may turn out to be the same!
+;; ;; don't be fooled by this!
+;; (not (equal (file-attributes file)
+;; (file-attributes full-trial))))
+;; ;; check if a version is in RCS/ directory
+;; (file-exists-p full-rcs-trial)))
+;; ))
+
+
+(defun ediff-file-checked-out-p (file)
+ (or (not (featurep 'vc-hooks))
+ (and (vc-backend file)
+ (if (fboundp 'vc-state)
+ (or (memq (vc-state file) '(edited needs-merge))
+ (stringp (vc-state file)))
+ ;; XEmacs has no vc-state
+ (when (featurep 'xemacs) (vc-locking-user file)))
+ )))
+
+(defun ediff-file-checked-in-p (file)
+ (and (featurep 'vc-hooks)
+ ;; Only RCS and SCCS files are considered checked in
+ (memq (vc-backend file) '(RCS SCCS))
+ (if (fboundp 'vc-state)
+ (and
+ (not (memq (vc-state file) '(edited needs-merge)))
+ (not (stringp (vc-state file))))
+ ;; XEmacs has no vc-state
+ (when (featurep 'xemacs) (not (vc-locking-user file))))
+ ))
+
+(defun ediff-file-compressed-p (file)
+ (condition-case nil
+ (require 'jka-compr)
+ (error))
+ (if (featurep 'jka-compr)
+ (string-match (jka-compr-build-file-regexp) file)))
+
+
+(defun ediff-swap-buffers ()
+ "Rotate the display of buffers A, B, and C."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (if (and (window-live-p ediff-window-A) (window-live-p ediff-window-B))
+ (let ((buf ediff-buffer-A)
+ (values ediff-buffer-values-orig-A)
+ (diff-vec ediff-difference-vector-A)
+ (hide-regexp ediff-regexp-hide-A)
+ (focus-regexp ediff-regexp-focus-A)
+ (wide-visibility-p (eq ediff-visible-bounds ediff-wide-bounds))
+ (overlay (if (ediff-has-face-support-p)
+ ediff-current-diff-overlay-A)))
+ (if ediff-3way-comparison-job
+ (progn
+ (set-window-buffer ediff-window-A ediff-buffer-C)
+ (set-window-buffer ediff-window-B ediff-buffer-A)
+ (set-window-buffer ediff-window-C ediff-buffer-B)
+ )
+ (set-window-buffer ediff-window-A ediff-buffer-B)
+ (set-window-buffer ediff-window-B ediff-buffer-A))
+ ;; swap diff buffers
+ (if ediff-3way-comparison-job
+ (setq ediff-buffer-A ediff-buffer-C
+ ediff-buffer-C ediff-buffer-B
+ ediff-buffer-B buf)
+ (setq ediff-buffer-A ediff-buffer-B
+ ediff-buffer-B buf))
+
+ ;; swap saved buffer characteristics
+ (if ediff-3way-comparison-job
+ (setq ediff-buffer-values-orig-A ediff-buffer-values-orig-C
+ ediff-buffer-values-orig-C ediff-buffer-values-orig-B
+ ediff-buffer-values-orig-B values)
+ (setq ediff-buffer-values-orig-A ediff-buffer-values-orig-B
+ ediff-buffer-values-orig-B values))
+
+ ;; swap diff vectors
+ (if ediff-3way-comparison-job
+ (setq ediff-difference-vector-A ediff-difference-vector-C
+ ediff-difference-vector-C ediff-difference-vector-B
+ ediff-difference-vector-B diff-vec)
+ (setq ediff-difference-vector-A ediff-difference-vector-B
+ ediff-difference-vector-B diff-vec))
+
+ ;; swap hide/focus regexp
+ (if ediff-3way-comparison-job
+ (setq ediff-regexp-hide-A ediff-regexp-hide-C
+ ediff-regexp-hide-C ediff-regexp-hide-B
+ ediff-regexp-hide-B hide-regexp
+ ediff-regexp-focus-A ediff-regexp-focus-C
+ ediff-regexp-focus-C ediff-regexp-focus-B
+ ediff-regexp-focus-B focus-regexp)
+ (setq ediff-regexp-hide-A ediff-regexp-hide-B
+ ediff-regexp-hide-B hide-regexp
+ ediff-regexp-focus-A ediff-regexp-focus-B
+ ediff-regexp-focus-B focus-regexp))
+
+ ;; The following is needed for XEmacs, since there one can't move
+ ;; overlay to another buffer. In Emacs, this swap is redundant.
+ (if (ediff-has-face-support-p)
+ (if ediff-3way-comparison-job
+ (setq ediff-current-diff-overlay-A ediff-current-diff-overlay-C
+ ediff-current-diff-overlay-C ediff-current-diff-overlay-B
+ ediff-current-diff-overlay-B overlay)
+ (setq ediff-current-diff-overlay-A ediff-current-diff-overlay-B
+ ediff-current-diff-overlay-B overlay)))
+
+ ;; swap wide bounds
+ (setq ediff-wide-bounds
+ (cond (ediff-3way-comparison-job
+ (list (nth 2 ediff-wide-bounds)
+ (nth 0 ediff-wide-bounds)
+ (nth 1 ediff-wide-bounds)))
+ (ediff-3way-job
+ (list (nth 1 ediff-wide-bounds)
+ (nth 0 ediff-wide-bounds)
+ (nth 2 ediff-wide-bounds)))
+ (t
+ (list (nth 1 ediff-wide-bounds)
+ (nth 0 ediff-wide-bounds)))))
+ ;; swap narrow bounds
+ (setq ediff-narrow-bounds
+ (cond (ediff-3way-comparison-job
+ (list (nth 2 ediff-narrow-bounds)
+ (nth 0 ediff-narrow-bounds)
+ (nth 1 ediff-narrow-bounds)))
+ (ediff-3way-job
+ (list (nth 1 ediff-narrow-bounds)
+ (nth 0 ediff-narrow-bounds)
+ (nth 2 ediff-narrow-bounds)))
+ (t
+ (list (nth 1 ediff-narrow-bounds)
+ (nth 0 ediff-narrow-bounds)))))
+ (if wide-visibility-p
+ (setq ediff-visible-bounds ediff-wide-bounds)
+ (setq ediff-visible-bounds ediff-narrow-bounds))
+ ))
+ (if ediff-3way-job
+ (ediff-set-state-of-all-diffs-in-all-buffers ediff-control-buffer))
+ (ediff-recenter 'no-rehighlight)
+ )
+
+
+(defun ediff-toggle-wide-display ()
+ "Toggle wide/regular display.
+This is especially useful when comparing buffers side-by-side."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (or (ediff-window-display-p)
+ (error "%sEmacs is not running as a window application"
+ (if (featurep 'emacs) "" "X")))
+ (ediff-recenter 'no-rehighlight) ; make sure buffs are displayed in windows
+ (let ((ctl-buf ediff-control-buffer))
+ (setq ediff-wide-display-p (not ediff-wide-display-p))
+ (if (not ediff-wide-display-p)
+ (ediff-with-current-buffer ctl-buf
+ (modify-frame-parameters
+ ediff-wide-display-frame ediff-wide-display-orig-parameters)
+ ;;(sit-for (if (featurep 'xemacs) 0.4 0))
+ ;; restore control buf, since ctl window may have been deleted
+ ;; during resizing
+ (set-buffer ctl-buf)
+ (setq ediff-wide-display-orig-parameters nil
+ ediff-window-B nil) ; force update of window config
+ (ediff-recenter 'no-rehighlight))
+ (funcall ediff-make-wide-display-function)
+ ;;(sit-for (if (featurep 'xemacs) 0.4 0))
+ (ediff-with-current-buffer ctl-buf
+ (setq ediff-window-B nil) ; force update of window config
+ (ediff-recenter 'no-rehighlight)))))
+
+;;;###autoload
+(defun ediff-toggle-multiframe ()
+ "Switch from multiframe display to single-frame display and back.
+To change the default, set the variable `ediff-window-setup-function',
+which see."
+ (interactive)
+ (let (window-setup-func)
+ (or (ediff-window-display-p)
+ (error "%sEmacs is not running as a window application"
+ (if (featurep 'emacs) "" "X")))
+
+ (cond ((eq ediff-window-setup-function 'ediff-setup-windows-multiframe)
+ (setq ediff-multiframe nil)
+ (setq window-setup-func 'ediff-setup-windows-plain))
+ ((eq ediff-window-setup-function 'ediff-setup-windows-plain)
+ (if (ediff-in-control-buffer-p)
+ (ediff-kill-bottom-toolbar))
+ (if (and (ediff-buffer-live-p ediff-control-buffer)
+ (window-live-p ediff-control-window))
+ (set-window-dedicated-p ediff-control-window nil))
+ (setq ediff-multiframe t)
+ (setq window-setup-func 'ediff-setup-windows-multiframe))
+ (t
+ (if (and (ediff-buffer-live-p ediff-control-buffer)
+ (window-live-p ediff-control-window))
+ (set-window-dedicated-p ediff-control-window nil))
+ (setq ediff-multiframe t)
+ (setq window-setup-func 'ediff-setup-windows-multiframe))
+ )
+
+ ;; change default
+ (setq-default ediff-window-setup-function window-setup-func)
+ ;; change in all active ediff sessions
+ (mapc (lambda(buf) (ediff-with-current-buffer buf
+ (setq ediff-window-setup-function window-setup-func
+ ediff-window-B nil)))
+ ediff-session-registry)
+ (if (ediff-in-control-buffer-p)
+ (progn
+ (set-window-dedicated-p (selected-window) nil)
+ (ediff-recenter 'no-rehighlight)))))
+
+
+;;;###autoload
+(defun ediff-toggle-use-toolbar ()
+ "Enable or disable Ediff toolbar.
+Works only in versions of Emacs that support toolbars.
+To change the default, set the variable `ediff-use-toolbar-p', which see."
+ (interactive)
+ (if (featurep 'ediff-tbar)
+ (progn
+ (or (ediff-window-display-p)
+ (error "%sEmacs is not running as a window application"
+ (if (featurep 'emacs) "" "X")))
+ (if (ediff-use-toolbar-p)
+ (ediff-kill-bottom-toolbar))
+ ;; do this only after killing the toolbar
+ (setq ediff-use-toolbar-p (not ediff-use-toolbar-p))
+
+ (mapc (lambda(buf)
+ (ediff-with-current-buffer buf
+ ;; force redisplay
+ (setq ediff-window-config-saved "")
+ ))
+ ediff-session-registry)
+ (if (ediff-in-control-buffer-p)
+ (ediff-recenter 'no-rehighlight)))))
+
+
+;; if was using toolbar, kill it
+(defun ediff-kill-bottom-toolbar ()
+ ;; Using ctl-buffer or ediff-control-window for LOCALE does not
+ ;; work properly in XEmacs 19.14: we have to use
+ ;;(selected-frame).
+ ;; The problem with this is that any previous bottom-toolbar
+ ;; will not re-appear after our cleanup here. Is there a way
+ ;; to do "push" and "pop" toolbars ? --marcpa
+ (if (featurep 'xemacs)
+ (when (ediff-use-toolbar-p)
+ (set-specifier bottom-toolbar (list (selected-frame) nil))
+ (set-specifier bottom-toolbar-visible-p (list (selected-frame) nil)))))
+
+;; If wants to use toolbar, make it.
+;; If not, zero the toolbar for XEmacs.
+;; Do nothing for Emacs.
+(defun ediff-make-bottom-toolbar (&optional frame)
+ (when (ediff-window-display-p)
+ (setq frame (or frame (selected-frame)))
+ (if (featurep 'xemacs)
+ (cond ((ediff-use-toolbar-p) ; this checks for XEmacs
+ (set-specifier
+ bottom-toolbar
+ (list frame (if (ediff-3way-comparison-job)
+ ediff-toolbar-3way ediff-toolbar)))
+ (set-specifier bottom-toolbar-visible-p (list frame t))
+ (set-specifier bottom-toolbar-height
+ (list frame ediff-toolbar-height)))
+ ((ediff-has-toolbar-support-p)
+ (set-specifier bottom-toolbar-height (list frame 0)))))))
+
+;; Merging
+
+(defun ediff-toggle-show-clashes-only ()
+ "Toggle the mode that shows only the merge regions where both variants differ from the ancestor."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (if (not ediff-merge-with-ancestor-job)
+ (error "This command makes sense only when merging with an ancestor"))
+ (setq ediff-show-clashes-only (not ediff-show-clashes-only))
+ (if ediff-show-clashes-only
+ (message "Focus on regions where both buffers differ from the ancestor")
+ (message "Canceling focus on regions where changes clash")))
+
+(defun ediff-toggle-skip-changed-regions ()
+ "Toggle the mode that skips the merge regions that differ from the default."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (setq ediff-skip-merge-regions-that-differ-from-default
+ (not ediff-skip-merge-regions-that-differ-from-default))
+ (if ediff-skip-merge-regions-that-differ-from-default
+ (message "Skipping regions that differ from default setting")
+ (message "Showing regions that differ from default setting")))
+
+
+
+;; Widening/narrowing
+
+(defun ediff-toggle-narrow-region ()
+ "Toggle narrowing in buffers A, B, and C.
+Used in ediff-windows/regions only."
+ (interactive)
+ (if (eq ediff-buffer-A ediff-buffer-B)
+ (error ediff-NO-DIFFERENCES))
+ (if (eq ediff-visible-bounds ediff-wide-bounds)
+ (setq ediff-visible-bounds ediff-narrow-bounds)
+ (setq ediff-visible-bounds ediff-wide-bounds))
+ (ediff-recenter 'no-rehighlight))
+
+;; Narrow bufs A/B/C to ediff-visible-bounds. If this is currently set to
+;; ediff-wide-bounds, then this actually widens.
+;; This function does nothing if job-name is not
+;; ediff-regions-wordwise/linewise or ediff-windows-wordwise/linewise.
+;; Does nothing if buffer-A = buffer-B since we can't narrow
+;; to two different regions in one buffer.
+(defun ediff-visible-region ()
+ (if (or (eq ediff-buffer-A ediff-buffer-B)
+ (eq ediff-buffer-A ediff-buffer-C)
+ (eq ediff-buffer-C ediff-buffer-B))
+ ()
+ ;; If ediff-*-regions/windows, ediff-visible-bounds is already set
+ ;; Otherwise, always use full range.
+ (if (not ediff-narrow-job)
+ (setq ediff-visible-bounds ediff-wide-bounds))
+ (let ((overl-A (ediff-get-value-according-to-buffer-type
+ 'A ediff-visible-bounds))
+ (overl-B (ediff-get-value-according-to-buffer-type
+ 'B ediff-visible-bounds))
+ (overl-C (ediff-get-value-according-to-buffer-type
+ 'C ediff-visible-bounds))
+ )
+ (ediff-with-current-buffer ediff-buffer-A
+ (if (ediff-overlay-buffer overl-A)
+ (narrow-to-region
+ (ediff-overlay-start overl-A) (ediff-overlay-end overl-A))))
+ (ediff-with-current-buffer ediff-buffer-B
+ (if (ediff-overlay-buffer overl-B)
+ (narrow-to-region
+ (ediff-overlay-start overl-B) (ediff-overlay-end overl-B))))
+
+ (if (and ediff-3way-job (ediff-overlay-buffer overl-C))
+ (ediff-with-current-buffer ediff-buffer-C
+ (narrow-to-region
+ (ediff-overlay-start overl-C) (ediff-overlay-end overl-C))))
+ )))
+
+
+;; Window scrolling operations
+
+;; Performs some operation on the two file windows (if they are showing).
+;; Traps all errors on the operation in windows A/B/C.
+;; Usually, errors come from scrolling off the
+;; beginning or end of the buffer, and this gives error messages.
+(defun ediff-operate-on-windows (operation arg)
+
+ ;; make sure windows aren't dead
+ (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B)))
+ (ediff-recenter 'no-rehighlight))
+ (if (not (and (ediff-buffer-live-p ediff-buffer-A)
+ (ediff-buffer-live-p ediff-buffer-B)
+ (or (not ediff-3way-job) ediff-buffer-C)
+ ))
+ (error ediff-KILLED-VITAL-BUFFER))
+
+ (let* ((wind (selected-window))
+ (wind-A ediff-window-A)
+ (wind-B ediff-window-B)
+ (wind-C ediff-window-C)
+ (coefA (ediff-get-region-size-coefficient 'A operation))
+ (coefB (ediff-get-region-size-coefficient 'B operation))
+ (three-way ediff-3way-job)
+ (coefC (if three-way
+ (ediff-get-region-size-coefficient 'C operation))))
+
+ (select-window wind-A)
+ (condition-case nil
+ (funcall operation (round (* coefA arg)))
+ (error))
+ (select-window wind-B)
+ (condition-case nil
+ (funcall operation (round (* coefB arg)))
+ (error))
+ (if three-way
+ (progn
+ (select-window wind-C)
+ (condition-case nil
+ (funcall operation (round (* coefC arg)))
+ (error))))
+ (select-window wind)))
+
+(defun ediff-scroll-vertically (&optional arg)
+ "Vertically scroll buffers A, B \(and C if appropriate\).
+With optional argument ARG, scroll ARG lines; otherwise scroll by nearly
+the one half of the height of window-A."
+ (interactive "P")
+ (ediff-barf-if-not-control-buffer)
+
+ ;; make sure windows aren't dead
+ (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B)))
+ (ediff-recenter 'no-rehighlight))
+ (if (not (and (ediff-buffer-live-p ediff-buffer-A)
+ (ediff-buffer-live-p ediff-buffer-B)
+ (or (not ediff-3way-job)
+ (ediff-buffer-live-p ediff-buffer-C))
+ ))
+ (error ediff-KILLED-VITAL-BUFFER))
+
+ (ediff-operate-on-windows
+ (if (memq (ediff-last-command-char) '(?v ?\C-v))
+ 'scroll-up
+ 'scroll-down)
+ ;; calculate argument to scroll-up/down
+ ;; if there is an explicit argument
+ (if (and arg (not (equal arg '-)))
+ ;; use it
+ (prefix-numeric-value arg)
+ ;; if not, see if we can determine a default amount (the window height)
+ (let (default-amount)
+ (setq default-amount
+ (- (/ (min (window-height ediff-window-A)
+ (window-height ediff-window-B)
+ (if ediff-3way-job
+ (window-height ediff-window-C)
+ 500)) ; some large number
+ 2)
+ 1 next-screen-context-lines))
+ ;; window found
+ (if arg
+ ;; C-u as argument means half of default amount
+ (/ default-amount 2)
+ ;; no argument means default amount
+ default-amount)))))
+
+
+(defun ediff-scroll-horizontally (&optional arg)
+ "Horizontally scroll buffers A, B \(and C if appropriate\).
+If an argument is given, that is how many columns are scrolled, else nearly
+the width of the A/B/C windows."
+ (interactive "P")
+ (ediff-barf-if-not-control-buffer)
+
+ ;; make sure windows aren't dead
+ (if (not (and (window-live-p ediff-window-A) (window-live-p ediff-window-B)))
+ (ediff-recenter 'no-rehighlight))
+ (if (not (and (ediff-buffer-live-p ediff-buffer-A)
+ (ediff-buffer-live-p ediff-buffer-B)
+ (or (not ediff-3way-job)
+ (ediff-buffer-live-p ediff-buffer-C))
+ ))
+ (error ediff-KILLED-VITAL-BUFFER))
+
+ (ediff-operate-on-windows
+ ;; Arrange for scroll-left and scroll-right being called
+ ;; interactively so that they set the window's min_hscroll.
+ ;; Otherwise, automatic hscrolling will undo the effect of
+ ;; hscrolling.
+ (if (= (ediff-last-command-char) ?<)
+ (lambda (arg)
+ (let ((prefix-arg arg))
+ (call-interactively 'scroll-left)))
+ (lambda (arg)
+ (let ((prefix-arg arg))
+ (call-interactively 'scroll-right))))
+ ;; calculate argument to scroll-left/right
+ ;; if there is an explicit argument
+ (if (and arg (not (equal arg '-)))
+ ;; use it
+ (prefix-numeric-value arg)
+ ;; if not, see if we can determine a default amount
+ ;; (half the window width)
+ (if (null ediff-control-window)
+ ;; no control window, use nil
+ nil
+ (let ((default-amount
+ (- (/ (min (window-width ediff-window-A)
+ (window-width ediff-window-B)
+ (if ediff-3way-comparison-job
+ (window-width ediff-window-C)
+ 500) ; some large number
+ )
+ 2)
+ 3)))
+ ;; window found
+ (if arg
+ ;; C-u as argument means half of default amount
+ (/ default-amount 2)
+ ;; no argument means default amount
+ default-amount))))))
+
+
+;;BEG, END show the region to be positioned.
+;;JOB-NAME holds ediff-job-name. The ediff-windows job positions regions
+;;differently.
+(defun ediff-position-region (beg end pos job-name)
+ (if (> end (point-max))
+ (setq end (point-max)))
+ (if ediff-windows-job
+ (if (pos-visible-in-window-p end)
+ () ; do nothing, wind is already positioned
+ ;; at this point, windows are positioned at the beginning of the
+ ;; file regions (not diff-regions) being compared.
+ (save-excursion
+ (move-to-window-line (- (window-height) 2))
+ (let ((amount (+ 2 (count-lines (point) end))))
+ (scroll-up amount))))
+ (set-window-start (selected-window) beg)
+ (if (pos-visible-in-window-p end)
+ ;; Determine the number of lines that the region occupies
+ (let ((lines 0)
+ (prev-point 0))
+ (while ( and (> end (progn
+ (move-to-window-line lines)
+ (point)))
+ ;; `end' may be beyond the window bottom, so check
+ ;; that we are making progress
+ (< prev-point (point)))
+ (setq prev-point (point))
+ (setq lines (1+ lines)))
+ ;; And position the beginning on the right line
+ (goto-char beg)
+ (recenter (/ (1+ (max (- (1- (window-height (selected-window)))
+ lines)
+ 1)
+ )
+ 2))))
+ (goto-char pos)
+ ))
+
+;; get number of lines from window start to region end
+(defun ediff-get-lines-to-region-end (buf-type &optional n ctl-buf)
+ (or n (setq n ediff-current-difference))
+ (or ctl-buf (setq ctl-buf ediff-control-buffer))
+ (ediff-with-current-buffer ctl-buf
+ (let* ((buf (ediff-get-buffer buf-type))
+ (wind (eval (ediff-get-symbol-from-alist
+ buf-type ediff-window-alist)))
+ (beg (window-start wind))
+ (end (ediff-get-diff-posn buf-type 'end))
+ lines)
+ (ediff-with-current-buffer buf
+ (if (< beg end)
+ (setq lines (count-lines beg end))
+ (setq lines 0))
+ lines
+ ))))
+
+;; Calculate the number of lines from window end to the start of diff region
+(defun ediff-get-lines-to-region-start (buf-type &optional diff-num ctl-buf)
+ (or diff-num (setq diff-num ediff-current-difference))
+ (or ctl-buf (setq ctl-buf ediff-control-buffer))
+ (ediff-with-current-buffer ctl-buf
+ (let* ((buf (ediff-get-buffer buf-type))
+ (wind (eval (ediff-get-symbol-from-alist
+ buf-type ediff-window-alist)))
+ (end (or (window-end wind) (window-end wind t)))
+ (beg (ediff-get-diff-posn buf-type 'beg diff-num)))
+ (ediff-with-current-buffer buf
+ (if (< beg end)
+ (count-lines (max beg (point-min)) (min end (point-max))) 0))
+ )))
+
+
+;; region size coefficient is a coefficient by which to adjust scrolling
+;; up/down of the window displaying buffer of type BUFTYPE.
+;; The purpose of this coefficient is to make the windows scroll in sync, so
+;; that it won't happen that one diff region is scrolled off while the other is
+;; still seen.
+;;
+;; If the difference region is invalid, the coefficient is 1
+(defun ediff-get-region-size-coefficient (buf-type op &optional n ctl-buf)
+ (ediff-with-current-buffer (or ctl-buf ediff-control-buffer)
+ (if (ediff-valid-difference-p n)
+ (let* ((func (cond ((eq op 'scroll-down)
+ 'ediff-get-lines-to-region-start)
+ ((eq op 'scroll-up)
+ 'ediff-get-lines-to-region-end)
+ (t '(lambda (a b c) 0))))
+ (max-lines (max (funcall func 'A n ctl-buf)
+ (funcall func 'B n ctl-buf)
+ (if (ediff-buffer-live-p ediff-buffer-C)
+ (funcall func 'C n ctl-buf)
+ 0))))
+ ;; this covers the horizontal coefficient as well:
+ ;; if max-lines = 0 then coef = 1
+ (if (> max-lines 0)
+ (/ (+ (funcall func buf-type n ctl-buf) 0.0)
+ (+ max-lines 0.0))
+ 1))
+ 1)))
+
+
+(defun ediff-next-difference (&optional arg)
+ "Advance to the next difference.
+With a prefix argument, go forward that many differences."
+ (interactive "p")
+ (ediff-barf-if-not-control-buffer)
+ (if (< ediff-current-difference ediff-number-of-differences)
+ (let ((n (min ediff-number-of-differences
+ (+ ediff-current-difference (or arg 1))))
+ non-clash-skip skip-changed regexp-skip)
+
+ (ediff-visible-region)
+ (or (>= n ediff-number-of-differences)
+ (setq regexp-skip (funcall ediff-skip-diff-region-function n))
+ ;; this won't exec if regexp-skip is t
+ (setq non-clash-skip (ediff-merge-region-is-non-clash-to-skip n)
+ skip-changed
+ (ediff-skip-merge-region-if-changed-from-default-p n))
+ (ediff-install-fine-diff-if-necessary n))
+ ;; Skip loop
+ (while (and (< n ediff-number-of-differences)
+ (or
+ ;; regexp skip
+ regexp-skip
+ ;; skip clashes, if necessary
+ non-clash-skip
+ ;; skip processed regions
+ skip-changed
+ ;; skip difference regions that differ in white space
+ (and ediff-ignore-similar-regions
+ (ediff-merge-region-is-non-clash n)
+ (or (eq (ediff-no-fine-diffs-p n) t)
+ (and (ediff-merge-job)
+ (eq (ediff-no-fine-diffs-p n) 'C)))
+ )))
+ (setq n (1+ n))
+ (if (= 0 (mod n 20))
+ (message "Skipped over region %d and counting ..." n))
+ (or (>= n ediff-number-of-differences)
+ (setq regexp-skip (funcall ediff-skip-diff-region-function n))
+ ;; this won't exec if regexp-skip is t
+ (setq non-clash-skip (ediff-merge-region-is-non-clash-to-skip n)
+ skip-changed
+ (ediff-skip-merge-region-if-changed-from-default-p n))
+ (ediff-install-fine-diff-if-necessary n))
+ )
+ (message "")
+ (ediff-unselect-and-select-difference n)
+ ) ; let
+ (ediff-visible-region)
+ (error "At end of the difference list")))
+
+(defun ediff-previous-difference (&optional arg)
+ "Go to the previous difference.
+With a prefix argument, go back that many differences."
+ (interactive "p")
+ (ediff-barf-if-not-control-buffer)
+ (if (> ediff-current-difference -1)
+ (let ((n (max -1 (- ediff-current-difference (or arg 1))))
+ non-clash-skip skip-changed regexp-skip)
+
+ (ediff-visible-region)
+ (or (< n 0)
+ (setq regexp-skip (funcall ediff-skip-diff-region-function n))
+ ;; this won't exec if regexp-skip is t
+ (setq non-clash-skip (ediff-merge-region-is-non-clash-to-skip n)
+ skip-changed
+ (ediff-skip-merge-region-if-changed-from-default-p n))
+ (ediff-install-fine-diff-if-necessary n))
+ (while (and (> n -1)
+ (or
+ ;; regexp skip
+ regexp-skip
+ ;; skip clashes, if necessary
+ non-clash-skip
+ ;; skipp changed regions
+ skip-changed
+ ;; skip difference regions that differ in white space
+ (and ediff-ignore-similar-regions
+ (ediff-merge-region-is-non-clash n)
+ (or (eq (ediff-no-fine-diffs-p n) t)
+ (and (ediff-merge-job)
+ (eq (ediff-no-fine-diffs-p n) 'C)))
+ )))
+ (if (= 0 (mod (1+ n) 20))
+ (message "Skipped over region %d and counting ..." (1+ n)))
+ (setq n (1- n))
+ (or (< n 0)
+ (setq regexp-skip (funcall ediff-skip-diff-region-function n))
+ ;; this won't exec if regexp-skip is t
+ (setq non-clash-skip (ediff-merge-region-is-non-clash-to-skip n)
+ skip-changed
+ (ediff-skip-merge-region-if-changed-from-default-p n))
+ (ediff-install-fine-diff-if-necessary n))
+ )
+ (message "")
+ (ediff-unselect-and-select-difference n)
+ ) ; let
+ (ediff-visible-region)
+ (error "At beginning of the difference list")))
+
+;; The diff number is as perceived by the user (i.e., 1+ the internal
+;; representation)
+(defun ediff-jump-to-difference (difference-number)
+ "Go to the difference specified as a prefix argument.
+If the prefix is negative, count differences from the end."
+ (interactive "p")
+ (ediff-barf-if-not-control-buffer)
+ (setq difference-number
+ (cond ((< difference-number 0)
+ (+ ediff-number-of-differences difference-number))
+ ((> difference-number 0) (1- difference-number))
+ (t -1)))
+ ;; -1 is allowed by ediff-unselect-and-select-difference --- it is the
+ ;; position before the first one.
+ (if (and (>= difference-number -1)
+ (<= difference-number ediff-number-of-differences))
+ (ediff-unselect-and-select-difference difference-number)
+ (error ediff-BAD-DIFF-NUMBER
+ this-command (1+ difference-number) ediff-number-of-differences)))
+
+(defun ediff-jump-to-difference-at-point (arg)
+ "Go to difference closest to the point in buffer A, B, or C.
+The buffer depends on last command character \(a, b, or c\) that invoked this
+command. For instance, if the command was `ga' then the point value in buffer
+A is used.
+With a prefix argument, synchronize all files around the current point position
+in the specified buffer."
+ (interactive "P")
+ (ediff-barf-if-not-control-buffer)
+ (let* ((buf-type (ediff-char-to-buftype (ediff-last-command-char)))
+ (buffer (ediff-get-buffer buf-type))
+ (pt (ediff-with-current-buffer buffer (point)))
+ (diff-no (ediff-diff-at-point buf-type nil (if arg 'after)))
+ (past-last-diff (< ediff-number-of-differences diff-no))
+ (beg (if past-last-diff
+ (ediff-with-current-buffer buffer (point-max))
+ (ediff-get-diff-posn buf-type 'beg (1- diff-no))))
+ ctl-wind wind-A wind-B wind-C
+ shift)
+ (if past-last-diff
+ (ediff-jump-to-difference -1)
+ (ediff-jump-to-difference diff-no))
+ (setq ctl-wind (selected-window)
+ wind-A ediff-window-A
+ wind-B ediff-window-B
+ wind-C ediff-window-C)
+ (if arg
+ (progn
+ (ediff-with-current-buffer buffer
+ (setq shift (- beg pt)))
+ (select-window wind-A)
+ (if past-last-diff (goto-char (point-max)))
+ (condition-case nil
+ (backward-char shift) ; noerror, if beginning of buffer
+ (error))
+ (recenter)
+ (select-window wind-B)
+ (if past-last-diff (goto-char (point-max)))
+ (condition-case nil
+ (backward-char shift) ; noerror, if beginning of buffer
+ (error))
+ (recenter)
+ (if (window-live-p wind-C)
+ (progn
+ (select-window wind-C)
+ (if past-last-diff (goto-char (point-max)))
+ (condition-case nil
+ (backward-char shift) ; noerror, if beginning of buffer
+ (error))
+ (recenter)
+ ))
+ (select-window ctl-wind)
+ ))
+ ))
+
+
+;; find region most related to the current point position (or POS, if given)
+;; returns diff number as seen by the user (i.e., 1+ the internal
+;; representation)
+;; The optional argument WHICH-DIFF can be `after' or `before'. If `after',
+;; find the diff after the point. If `before', find the diff before the
+;; point. If the point is inside a diff, return that diff.
+(defun ediff-diff-at-point (buf-type &optional pos which-diff)
+ (let ((buffer (ediff-get-buffer buf-type))
+ (ctl-buffer ediff-control-buffer)
+ (max-dif-num (1- ediff-number-of-differences))
+ (diff-no -1)
+ (prev-beg 0)
+ (prev-end 0)
+ (beg 0)
+ (end 0))
+
+ (ediff-with-current-buffer buffer
+ (setq pos (or pos (point)))
+ (while (and (or (< pos prev-beg) (> pos beg))
+ (< diff-no max-dif-num))
+ (setq diff-no (1+ diff-no))
+ (setq prev-beg beg
+ prev-end end)
+ (setq beg (ediff-get-diff-posn buf-type 'beg diff-no ctl-buffer)
+ end (ediff-get-diff-posn buf-type 'end diff-no ctl-buffer))
+ )
+
+ ;; boost diff-no by 1, if past the last diff region
+ (if (and (memq which-diff '(after before))
+ (> pos beg) (= diff-no max-dif-num))
+ (setq diff-no (1+ diff-no)))
+
+ (cond ((eq which-diff 'after) (1+ diff-no))
+ ((eq which-diff 'before) diff-no)
+ ((< (abs (count-lines pos (max 1 prev-end)))
+ (abs (count-lines pos (max 1 beg))))
+ diff-no) ; choose prev difference
+ (t
+ (1+ diff-no))) ; choose next difference
+ )))
+
+\f
+;;; Copying diffs.
+
+(defun ediff-diff-to-diff (arg &optional keys)
+ "Copy buffer-X'th difference region to buffer Y \(X,Y are A, B, or C\).
+If numerical prefix argument, copy the difference specified in the arg.
+Otherwise, copy the difference given by `ediff-current-difference'.
+This command assumes it is bound to a 2-character key sequence, `ab', `ba',
+`ac', etc., which is used to determine the types of buffers to be used for
+copying difference regions. The first character in the sequence specifies
+the source buffer and the second specifies the target.
+
+If the second optional argument, a 2-character string, is given, use it to
+determine the source and the target buffers instead of the command keys."
+ (interactive "P")
+ (ediff-barf-if-not-control-buffer)
+ (or keys (setq keys (this-command-keys)))
+ (if (eq arg '-) (setq arg -1)) ; translate neg arg to -1
+ (if (numberp arg) (ediff-jump-to-difference arg))
+
+ (let* ((key1 (aref keys 0))
+ (key2 (aref keys 1))
+ (char1 (ediff-event-key key1))
+ (char2 (ediff-event-key key2))
+ ediff-verbose-p)
+ (ediff-copy-diff ediff-current-difference
+ (ediff-char-to-buftype char1)
+ (ediff-char-to-buftype char2))
+ ;; recenter with rehighlighting, but no messages
+ (ediff-recenter)))
+
+(defun ediff-copy-A-to-B (arg)
+ "Copy ARGth difference region from buffer A to B.
+ARG is a prefix argument. If nil, copy the current difference region."
+ (interactive "P")
+ (ediff-diff-to-diff arg "ab"))
+
+(defun ediff-copy-B-to-A (arg)
+ "Copy ARGth difference region from buffer B to A.
+ARG is a prefix argument. If nil, copy the current difference region."
+ (interactive "P")
+ (ediff-diff-to-diff arg "ba"))
+
+(defun ediff-copy-A-to-C (arg)
+ "Copy ARGth difference region from buffer A to buffer C.
+ARG is a prefix argument. If nil, copy the current difference region."
+ (interactive "P")
+ (ediff-diff-to-diff arg "ac"))
+
+(defun ediff-copy-B-to-C (arg)
+ "Copy ARGth difference region from buffer B to buffer C.
+ARG is a prefix argument. If nil, copy the current difference region."
+ (interactive "P")
+ (ediff-diff-to-diff arg "bc"))
+
+(defun ediff-copy-C-to-B (arg)
+ "Copy ARGth difference region from buffer C to B.
+ARG is a prefix argument. If nil, copy the current difference region."
+ (interactive "P")
+ (ediff-diff-to-diff arg "cb"))
+
+(defun ediff-copy-C-to-A (arg)
+ "Copy ARGth difference region from buffer C to A.
+ARG is a prefix argument. If nil, copy the current difference region."
+ (interactive "P")
+ (ediff-diff-to-diff arg "ca"))
+
+
+
+;; Copy diff N from FROM-BUF-TYPE \(given as A, B or C\) to TO-BUF-TYPE.
+;; If optional DO-NOT-SAVE is non-nil, do not save the old value of the
+;; target diff. This is used in merging, when constructing the merged
+;; version.
+(defun ediff-copy-diff (n from-buf-type to-buf-type
+ &optional batch-invocation reg-to-copy)
+ (let* ((to-buf (ediff-get-buffer to-buf-type))
+ ;;(from-buf (if (not reg-to-copy) (ediff-get-buffer from-buf-type)))
+ (ctrl-buf ediff-control-buffer)
+ (saved-p t)
+ (three-way ediff-3way-job)
+ messg
+ ediff-verbose-p
+ reg-to-delete reg-to-delete-beg reg-to-delete-end)
+
+ (setq reg-to-delete-beg
+ (ediff-get-diff-posn to-buf-type 'beg n ctrl-buf))
+ (setq reg-to-delete-end
+ (ediff-get-diff-posn to-buf-type 'end n ctrl-buf))
+
+ (if reg-to-copy
+ (setq from-buf-type nil)
+ (setq reg-to-copy (ediff-get-region-contents n from-buf-type ctrl-buf)))
+
+ (setq reg-to-delete (ediff-get-region-contents
+ n to-buf-type ctrl-buf
+ reg-to-delete-beg reg-to-delete-end))
+
+ (if (string= reg-to-delete reg-to-copy)
+ (setq saved-p nil) ; don't copy identical buffers
+ ;; seems ok to copy
+ (if (or batch-invocation (ediff-test-save-region n to-buf-type))
+ (condition-case conds
+ (progn
+ (ediff-with-current-buffer to-buf
+ ;; to prevent flags from interfering if buffer is writable
+ (let ((inhibit-read-only (null buffer-read-only)))
+
+ (goto-char reg-to-delete-end)
+ (insert reg-to-copy)
+
+ (if (> reg-to-delete-end reg-to-delete-beg)
+ (kill-region reg-to-delete-beg reg-to-delete-end))
+ ))
+ (or batch-invocation
+ (setq
+ messg
+ (ediff-save-diff-region n to-buf-type reg-to-delete))))
+ (error (message "ediff-copy-diff: %s %s"
+ (car conds)
+ (mapconcat 'prin1-to-string (cdr conds) " "))
+ (beep 1)
+ (sit-for 2) ; let the user see the error msg
+ (setq saved-p nil)
+ )))
+ )
+
+ ;; adjust state of difference in case 3-way and diff was copied ok
+ (if (and saved-p three-way)
+ (ediff-set-state-of-diff-in-all-buffers n ctrl-buf))
+
+ (if batch-invocation
+ (ediff-clear-fine-differences n)
+ ;; If diff3 job, we should recompute fine diffs so we clear them
+ ;; before reinserting flags (and thus before ediff-recenter).
+ (if (and saved-p three-way)
+ (ediff-clear-fine-differences n))
+
+ (ediff-refresh-mode-lines)
+
+ ;; For diff2 jobs, don't recompute fine diffs, since we know there
+ ;; aren't any. So we clear diffs after ediff-recenter.
+ (if (and saved-p (not three-way))
+ (ediff-clear-fine-differences n))
+ ;; Make sure that the message about saving and how to restore is seen
+ ;; by the user
+ (message "%s" messg))
+ ))
+
+;; Save Nth diff of buffer BUF-TYPE \(A, B, or C\).
+;; That is to say, the Nth diff on the `ediff-killed-diffs-alist'. REG
+;; is the region to save. It is redundant here, but is passed anyway, for
+;; convenience.
+(defun ediff-save-diff-region (n buf-type reg)
+ (let* ((n-th-diff-saved (assoc n ediff-killed-diffs-alist))
+ (buf (ediff-get-buffer buf-type))
+ (this-buf-n-th-diff-saved (assoc buf (cdr n-th-diff-saved))))
+
+ (if this-buf-n-th-diff-saved
+ ;; either nothing saved for n-th diff and buffer or we OK'ed
+ ;; overriding
+ (setcdr this-buf-n-th-diff-saved reg)
+ (if n-th-diff-saved ;; n-th diff saved, but for another buffer
+ (nconc n-th-diff-saved (list (cons buf reg)))
+ (setq ediff-killed-diffs-alist ;; create record for n-th diff
+ (cons (list n (cons buf reg))
+ ediff-killed-diffs-alist))))
+ (message "Saving old diff region #%d of buffer %S. To recover, type `r%s'"
+ (1+ n) buf-type
+ (if ediff-merge-job
+ "" (downcase (symbol-name buf-type))))
+ ))
+
+;; Test if saving Nth difference region of buffer BUF-TYPE is possible.
+(defun ediff-test-save-region (n buf-type)
+ (let* ((n-th-diff-saved (assoc n ediff-killed-diffs-alist))
+ (buf (ediff-get-buffer buf-type))
+ (this-buf-n-th-diff-saved (assoc buf (cdr n-th-diff-saved))))
+
+ (if this-buf-n-th-diff-saved
+ (if (yes-or-no-p
+ (format
+ "You've previously copied diff region %d to buffer %S. Confirm? "
+ (1+ n) buf-type))
+ t
+ (error "Quit"))
+ t)))
+
+(defun ediff-pop-diff (n buf-type)
+ "Pop last killed Nth diff region from buffer BUF-TYPE."
+ (let* ((n-th-record (assoc n ediff-killed-diffs-alist))
+ (buf (ediff-get-buffer buf-type))
+ (saved-rec (assoc buf (cdr n-th-record)))
+ (three-way ediff-3way-job)
+ (ctl-buf ediff-control-buffer)
+ ediff-verbose-p
+ saved-diff reg-beg reg-end recovered)
+
+ (if (cdr saved-rec)
+ (setq saved-diff (cdr saved-rec))
+ (if (> ediff-number-of-differences 0)
+ (error "Nothing saved for diff %d in buffer %S" (1+ n) buf-type)
+ (error ediff-NO-DIFFERENCES)))
+
+ (setq reg-beg (ediff-get-diff-posn buf-type 'beg n ediff-control-buffer))
+ (setq reg-end (ediff-get-diff-posn buf-type 'end n ediff-control-buffer))
+
+ (condition-case conds
+ (ediff-with-current-buffer buf
+ (let ((inhibit-read-only (null buffer-read-only)))
+
+ (goto-char reg-end)
+ (insert saved-diff)
+
+ (if (> reg-end reg-beg)
+ (kill-region reg-beg reg-end))
+
+ (setq recovered t)
+ ))
+ (error (message "ediff-pop-diff: %s %s"
+ (car conds)
+ (mapconcat 'prin1-to-string (cdr conds) " "))
+ (beep 1)))
+
+ ;; Clearing fine diffs is necessary for
+ ;; ediff-unselect-and-select-difference to properly recompute them. We
+ ;; can't rely on ediff-copy-diff to clear this vector, as the user might
+ ;; have modified diff regions after copying and, thus, may have recomputed
+ ;; fine diffs.
+ (if recovered
+ (ediff-clear-fine-differences n))
+
+ ;; adjust state of difference
+ (if (and three-way recovered)
+ (ediff-set-state-of-diff-in-all-buffers n ctl-buf))
+
+ (ediff-refresh-mode-lines)
+
+ (if recovered
+ (progn
+ (setq n-th-record (delq saved-rec n-th-record))
+ (message "Diff region %d in buffer %S restored" (1+ n) buf-type)
+ ))
+ ))
+
+(defun ediff-restore-diff (arg &optional key)
+ "Restore ARGth diff from `ediff-killed-diffs-alist'.
+ARG is a prefix argument. If ARG is nil, restore the current-difference.
+If the second optional argument, a character, is given, use it to
+determine the target buffer instead of (ediff-last-command-char)"
+ (interactive "P")
+ (ediff-barf-if-not-control-buffer)
+ (if (numberp arg)
+ (ediff-jump-to-difference arg))
+ (ediff-pop-diff ediff-current-difference
+ (ediff-char-to-buftype (or key (ediff-last-command-char))))
+ ;; recenter with rehighlighting, but no messages
+ (let (ediff-verbose-p)
+ (ediff-recenter)))
+
+(defun ediff-restore-diff-in-merge-buffer (arg)
+ "Restore ARGth diff in the merge buffer.
+ARG is a prefix argument. If nil, restore the current diff."
+ (interactive "P")
+ (ediff-restore-diff arg ?c))
+
+
+(defun ediff-toggle-regexp-match ()
+ "Toggle between focusing and hiding of difference regions that match
+a regular expression typed in by the user."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (let ((regexp-A "")
+ (regexp-B "")
+ (regexp-C "")
+ msg-connective alt-msg-connective alt-connective)
+ (cond
+ ((or (and (eq ediff-skip-diff-region-function
+ ediff-focus-on-regexp-matches-function)
+ (eq (ediff-last-command-char) ?f))
+ (and (eq ediff-skip-diff-region-function
+ ediff-hide-regexp-matches-function)
+ (eq (ediff-last-command-char) ?h)))
+ (message "Selective browsing by regexp turned off")
+ (setq ediff-skip-diff-region-function 'ediff-show-all-diffs))
+ ((eq (ediff-last-command-char) ?h)
+ (setq ediff-skip-diff-region-function ediff-hide-regexp-matches-function
+ regexp-A
+ (read-string
+ (format
+ "Ignore A-regions matching this regexp (default %s): "
+ ediff-regexp-hide-A))
+ regexp-B
+ (read-string
+ (format
+ "Ignore B-regions matching this regexp (default %s): "
+ ediff-regexp-hide-B)))
+ (if ediff-3way-comparison-job
+ (setq regexp-C
+ (read-string
+ (format
+ "Ignore C-regions matching this regexp (default %s): "
+ ediff-regexp-hide-C))))
+ (if (eq ediff-hide-regexp-connective 'and)
+ (setq msg-connective "BOTH"
+ alt-msg-connective "ONE OF"
+ alt-connective 'or)
+ (setq msg-connective "ONE OF"
+ alt-msg-connective "BOTH"
+ alt-connective 'and))
+ (if (y-or-n-p
+ (format
+ "Ignore regions that match %s regexps, OK? "
+ msg-connective))
+ (message "Will ignore regions that match %s regexps" msg-connective)
+ (setq ediff-hide-regexp-connective alt-connective)
+ (message "Will ignore regions that match %s regexps"
+ alt-msg-connective))
+
+ (or (string= regexp-A "") (setq ediff-regexp-hide-A regexp-A))
+ (or (string= regexp-B "") (setq ediff-regexp-hide-B regexp-B))
+ (or (string= regexp-C "") (setq ediff-regexp-hide-C regexp-C)))
+
+ ((eq (ediff-last-command-char) ?f)
+ (setq ediff-skip-diff-region-function
+ ediff-focus-on-regexp-matches-function
+ regexp-A
+ (read-string
+ (format
+ "Focus on A-regions matching this regexp (default %s): "
+ ediff-regexp-focus-A))
+ regexp-B
+ (read-string
+ (format
+ "Focus on B-regions matching this regexp (default %s): "
+ ediff-regexp-focus-B)))
+ (if ediff-3way-comparison-job
+ (setq regexp-C
+ (read-string
+ (format
+ "Focus on C-regions matching this regexp (default %s): "
+ ediff-regexp-focus-C))))
+ (if (eq ediff-focus-regexp-connective 'and)
+ (setq msg-connective "BOTH"
+ alt-msg-connective "ONE OF"
+ alt-connective 'or)
+ (setq msg-connective "ONE OF"
+ alt-msg-connective "BOTH"
+ alt-connective 'and))
+ (if (y-or-n-p
+ (format
+ "Focus on regions that match %s regexps, OK? "
+ msg-connective))
+ (message "Will focus on regions that match %s regexps"
+ msg-connective)
+ (setq ediff-focus-regexp-connective alt-connective)
+ (message "Will focus on regions that match %s regexps"
+ alt-msg-connective))
+
+ (or (string= regexp-A "") (setq ediff-regexp-focus-A regexp-A))
+ (or (string= regexp-B "") (setq ediff-regexp-focus-B regexp-B))
+ (or (string= regexp-C "") (setq ediff-regexp-focus-C regexp-C))))))
+
+(defun ediff-toggle-skip-similar ()
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (if (not (eq ediff-auto-refine 'on))
+ (error
+ "Can't skip over whitespace regions: first turn auto-refining on"))
+ (setq ediff-ignore-similar-regions (not ediff-ignore-similar-regions))
+ (if ediff-ignore-similar-regions
+ (message
+ "Skipping regions that differ only in white space & line breaks")
+ (message "Skipping over white-space differences turned off")))
+
+(defun ediff-focus-on-regexp-matches (n)
+ "Focus on diffs that match regexp `ediff-regexp-focus-A/B'.
+Regions to be ignored according to this function are those where
+buf A region doesn't match `ediff-regexp-focus-A' and buf B region
+doesn't match `ediff-regexp-focus-B'.
+This function returns nil if the region number N (specified as
+an argument) is not to be ignored and t if region N is to be ignored.
+
+N is a region number used by Ediff internally. It is 1 less
+the number seen by the user."
+ (if (ediff-valid-difference-p n)
+ (let* ((ctl-buf ediff-control-buffer)
+ (regex-A ediff-regexp-focus-A)
+ (regex-B ediff-regexp-focus-B)
+ (regex-C ediff-regexp-focus-C)
+ (reg-A-match (ediff-with-current-buffer ediff-buffer-A
+ (save-restriction
+ (narrow-to-region
+ (ediff-get-diff-posn 'A 'beg n ctl-buf)
+ (ediff-get-diff-posn 'A 'end n ctl-buf))
+ (goto-char (point-min))
+ (re-search-forward regex-A nil t))))
+ (reg-B-match (ediff-with-current-buffer ediff-buffer-B
+ (save-restriction
+ (narrow-to-region
+ (ediff-get-diff-posn 'B 'beg n ctl-buf)
+ (ediff-get-diff-posn 'B 'end n ctl-buf))
+ (re-search-forward regex-B nil t))))
+ (reg-C-match (if ediff-3way-comparison-job
+ (ediff-with-current-buffer ediff-buffer-C
+ (save-restriction
+ (narrow-to-region
+ (ediff-get-diff-posn 'C 'beg n ctl-buf)
+ (ediff-get-diff-posn 'C 'end n ctl-buf))
+ (re-search-forward regex-C nil t))))))
+ (not (eval (if ediff-3way-comparison-job
+ (list ediff-focus-regexp-connective
+ reg-A-match reg-B-match reg-C-match)
+ (list ediff-focus-regexp-connective
+ reg-A-match reg-B-match))))
+ )))
+
+(defun ediff-hide-regexp-matches (n)
+ "Hide diffs that match regexp `ediff-regexp-hide-A/B/C'.
+Regions to be ignored are those where buf A region matches
+`ediff-regexp-hide-A' and buf B region matches `ediff-regexp-hide-B'.
+This function returns nil if the region number N (specified as
+an argument) is not to be ignored and t if region N is to be ignored.
+
+N is a region number used by Ediff internally. It is 1 less
+the number seen by the user."
+ (if (ediff-valid-difference-p n)
+ (let* ((ctl-buf ediff-control-buffer)
+ (regex-A ediff-regexp-hide-A)
+ (regex-B ediff-regexp-hide-B)
+ (regex-C ediff-regexp-hide-C)
+ (reg-A-match (ediff-with-current-buffer ediff-buffer-A
+ (save-restriction
+ (narrow-to-region
+ (ediff-get-diff-posn 'A 'beg n ctl-buf)
+ (ediff-get-diff-posn 'A 'end n ctl-buf))
+ (goto-char (point-min))
+ (re-search-forward regex-A nil t))))
+ (reg-B-match (ediff-with-current-buffer ediff-buffer-B
+ (save-restriction
+ (narrow-to-region
+ (ediff-get-diff-posn 'B 'beg n ctl-buf)
+ (ediff-get-diff-posn 'B 'end n ctl-buf))
+ (goto-char (point-min))
+ (re-search-forward regex-B nil t))))
+ (reg-C-match (if ediff-3way-comparison-job
+ (ediff-with-current-buffer ediff-buffer-C
+ (save-restriction
+ (narrow-to-region
+ (ediff-get-diff-posn 'C 'beg n ctl-buf)
+ (ediff-get-diff-posn 'C 'end n ctl-buf))
+ (goto-char (point-min))
+ (re-search-forward regex-C nil t))))))
+ (eval (if ediff-3way-comparison-job
+ (list ediff-hide-regexp-connective
+ reg-A-match reg-B-match reg-C-match)
+ (list ediff-hide-regexp-connective reg-A-match reg-B-match)))
+ )))
+
+
+\f
+;;; Quitting, suspending, etc.
+
+(defun ediff-quit (reverse-default-keep-variants)
+ "Finish an Ediff session and exit Ediff.
+Unselects the selected difference, if any, restores the read-only and modified
+flags of the compared file buffers, kills Ediff buffers for this session
+\(but not buffers A, B, C\).
+
+If `ediff-keep-variants' is nil, the user will be asked whether the buffers
+containing the variants should be removed \(if they haven't been modified\).
+If it is t, they will be preserved unconditionally. A prefix argument,
+temporarily reverses the meaning of this variable."
+ (interactive "P")
+ (ediff-barf-if-not-control-buffer)
+ (let ((ctl-buf (current-buffer))
+ (ctl-frm (selected-frame))
+ (minibuffer-auto-raise t))
+ (if (y-or-n-p (format "Quit this Ediff session%s? "
+ (if (ediff-buffer-live-p ediff-meta-buffer)
+ " & show containing session group" "")))
+ (progn
+ (message "")
+ (set-buffer ctl-buf)
+ (ediff-really-quit reverse-default-keep-variants))
+ (select-frame ctl-frm)
+ (raise-frame ctl-frm)
+ (message ""))))
+
+
+;; Perform the quit operations.
+(defun ediff-really-quit (reverse-default-keep-variants)
+ (ediff-unhighlight-diffs-totally)
+ (ediff-clear-diff-vector 'ediff-difference-vector-A 'fine-diffs-also)
+ (ediff-clear-diff-vector 'ediff-difference-vector-B 'fine-diffs-also)
+ (ediff-clear-diff-vector 'ediff-difference-vector-C 'fine-diffs-also)
+ (ediff-clear-diff-vector 'ediff-difference-vector-Ancestor 'fine-diffs-also)
+
+ (ediff-delete-temp-files)
+
+ ;; Restore the visibility range. This affects only ediff-*-regions/windows.
+ ;; Since for other job names ediff-visible-region sets
+ ;; ediff-visible-bounds to ediff-wide-bounds, the settings below are
+ ;; ignored for such jobs.
+ (if ediff-quit-widened
+ (setq ediff-visible-bounds ediff-wide-bounds)
+ (setq ediff-visible-bounds ediff-narrow-bounds))
+
+ ;; Apply selective display to narrow or widen
+ (ediff-visible-region)
+ (mapc (lambda (overl)
+ (if (ediff-overlayp overl)
+ (ediff-delete-overlay overl)))
+ ediff-wide-bounds)
+ (mapc (lambda (overl)
+ (if (ediff-overlayp overl)
+ (ediff-delete-overlay overl)))
+ ediff-narrow-bounds)
+
+ ;; restore buffer mode line id's in buffer-A/B/C
+ (let ((control-buffer ediff-control-buffer)
+ (meta-buffer ediff-meta-buffer)
+ (after-quit-hook-internal ediff-after-quit-hook-internal)
+ (session-number ediff-meta-session-number)
+ ;; suitable working frame
+ (warp-frame (if (and (ediff-window-display-p) (eq ediff-grab-mouse t))
+ (cond ((window-live-p ediff-window-A)
+ (window-frame ediff-window-A))
+ ((window-live-p ediff-window-B)
+ (window-frame ediff-window-B))
+ (t (next-frame))))))
+ (condition-case nil
+ (ediff-with-current-buffer ediff-buffer-A
+ (setq ediff-this-buffer-ediff-sessions
+ (delq control-buffer ediff-this-buffer-ediff-sessions))
+ (kill-local-variable 'mode-line-buffer-identification)
+ (kill-local-variable 'mode-line-format)
+ )
+ (error))
+
+ (condition-case nil
+ (ediff-with-current-buffer ediff-buffer-B
+ (setq ediff-this-buffer-ediff-sessions
+ (delq control-buffer ediff-this-buffer-ediff-sessions))
+ (kill-local-variable 'mode-line-buffer-identification)
+ (kill-local-variable 'mode-line-format)
+ )
+ (error))
+
+ (condition-case nil
+ (ediff-with-current-buffer ediff-buffer-C
+ (setq ediff-this-buffer-ediff-sessions
+ (delq control-buffer ediff-this-buffer-ediff-sessions))
+ (kill-local-variable 'mode-line-buffer-identification)
+ (kill-local-variable 'mode-line-format)
+ )
+ (error))
+
+ (condition-case nil
+ (ediff-with-current-buffer ediff-ancestor-buffer
+ (setq ediff-this-buffer-ediff-sessions
+ (delq control-buffer ediff-this-buffer-ediff-sessions))
+ (kill-local-variable 'mode-line-buffer-identification)
+ (kill-local-variable 'mode-line-format)
+ )
+ (error))
+
+ (setq ediff-session-registry
+ (delq ediff-control-buffer ediff-session-registry))
+ (ediff-update-registry)
+ ;; restore state of buffers to what it was before ediff
+ (ediff-restore-protected-variables)
+
+ ;; If the user interrupts (canceling saving the merge buffer), continue
+ ;; normally.
+ (condition-case nil
+ (if (ediff-merge-job)
+ (run-hooks 'ediff-quit-merge-hook))
+ (quit))
+
+ (run-hooks 'ediff-cleanup-hook)
+
+ (ediff-janitor
+ 'ask
+ ;; reverse-default-keep-variants is t if the user quits with a prefix arg
+ (if reverse-default-keep-variants
+ (not ediff-keep-variants)
+ ediff-keep-variants))
+
+ ;; one hook here is ediff-cleanup-mess, which kills the control buffer and
+ ;; other auxiliary buffers. we made it into a hook to let the users do their
+ ;; own cleanup, if needed.
+ (run-hooks 'ediff-quit-hook)
+ (ediff-update-meta-buffer meta-buffer nil session-number)
+
+ ;; warp mouse into a working window
+ (setq warp-frame ; if mouse is over a reasonable frame, use it
+ (cond ((ediff-good-frame-under-mouse))
+ (t warp-frame)))
+ (if (and (ediff-window-display-p) (frame-live-p warp-frame) ediff-grab-mouse)
+ (set-mouse-position (if (featurep 'emacs)
+ warp-frame
+ (frame-selected-window warp-frame))
+ 2 1))
+
+ (run-hooks 'after-quit-hook-internal)
+ ))
+
+;; Returns frame under mouse, if this frame is not a minibuffer
+;; frame. Otherwise: nil
+(defun ediff-good-frame-under-mouse ()
+ (let ((frame-or-win (car (mouse-position)))
+ (buf-name "")
+ frame obj-ok)
+ (setq obj-ok
+ (if (featurep 'emacs)
+ (frame-live-p frame-or-win)
+ (window-live-p frame-or-win)))
+ (if obj-ok
+ (setq frame (if (featurep 'emacs) frame-or-win (window-frame frame-or-win))
+ buf-name
+ (buffer-name (window-buffer (frame-selected-window frame)))))
+ (if (string-match "Minibuf" buf-name)
+ nil
+ frame)))
+
+
+(defun ediff-delete-temp-files ()
+ (if (and (stringp ediff-temp-file-A) (file-exists-p ediff-temp-file-A))
+ (delete-file ediff-temp-file-A))
+ (if (and (stringp ediff-temp-file-B) (file-exists-p ediff-temp-file-B))
+ (delete-file ediff-temp-file-B))
+ (if (and (stringp ediff-temp-file-C) (file-exists-p ediff-temp-file-C))
+ (delete-file ediff-temp-file-C)))
+
+
+;; Kill control buffer, other auxiliary Ediff buffers.
+;; Leave one of the frames split between buffers A/B/C
+(defun ediff-cleanup-mess ()
+ (let* ((buff-A ediff-buffer-A)
+ (buff-B ediff-buffer-B)
+ (buff-C ediff-buffer-C)
+ (ctl-buf ediff-control-buffer)
+ (ctl-wind (ediff-get-visible-buffer-window ctl-buf))
+ (ctl-frame ediff-control-frame)
+ (three-way-job ediff-3way-job)
+ (main-frame (cond ((window-live-p ediff-window-A)
+ (window-frame ediff-window-A))
+ ((window-live-p ediff-window-B)
+ (window-frame ediff-window-B)))))
+
+ (ediff-kill-buffer-carefully ediff-diff-buffer)
+ (ediff-kill-buffer-carefully ediff-custom-diff-buffer)
+ (ediff-kill-buffer-carefully ediff-fine-diff-buffer)
+ (ediff-kill-buffer-carefully ediff-tmp-buffer)
+ (ediff-kill-buffer-carefully ediff-error-buffer)
+ (ediff-kill-buffer-carefully ediff-msg-buffer)
+ (ediff-kill-buffer-carefully ediff-debug-buffer)
+ (if (boundp 'ediff-patch-diagnostics)
+ (ediff-kill-buffer-carefully ediff-patch-diagnostics))
+
+ ;; delete control frame or window
+ (cond ((and (ediff-window-display-p) (frame-live-p ctl-frame))
+ (delete-frame ctl-frame))
+ ((window-live-p ctl-wind)
+ (delete-window ctl-wind)))
+
+ ;; Hide bottom toolbar. --marcpa
+ (if (not (ediff-multiframe-setup-p))
+ (ediff-kill-bottom-toolbar))
+
+ (ediff-kill-buffer-carefully ctl-buf)
+
+ (if (frame-live-p main-frame)
+ (select-frame main-frame))
+
+ ;; display only if not visible
+ (condition-case nil
+ (or (ediff-get-visible-buffer-window buff-B)
+ (switch-to-buffer buff-B))
+ (error))
+ (condition-case nil
+ (or (ediff-get-visible-buffer-window buff-A)
+ (progn
+ (if (and (ediff-get-visible-buffer-window buff-B)
+ (ediff-buffer-live-p buff-A))
+ (funcall ediff-split-window-function))
+ (switch-to-buffer buff-A)))
+ (error))
+ (if three-way-job
+ (condition-case nil
+ (or (ediff-get-visible-buffer-window buff-C)
+ (progn
+ (if (and (or (ediff-get-visible-buffer-window buff-A)
+ (ediff-get-visible-buffer-window buff-B))
+ (ediff-buffer-live-p buff-C))
+ (funcall ediff-split-window-function))
+ (switch-to-buffer buff-C)))
+ (error)))
+ (balance-windows)
+ (message "")
+ ))
+
+(defun ediff-janitor (ask keep-variants)
+ "Kill buffers A, B, and, possibly, C, if these buffers aren't modified.
+In merge jobs, buffer C is not deleted here, but rather according to
+ediff-quit-merge-hook.
+A side effect of cleaning up may be that you should be careful when comparing
+the same buffer in two separate Ediff sessions: quitting one of them might
+delete this buffer in another session as well."
+ (ediff-dispose-of-variant-according-to-user
+ ediff-buffer-A 'A ask keep-variants)
+ (ediff-dispose-of-variant-according-to-user
+ ediff-buffer-B 'B ask keep-variants)
+ (if ediff-merge-job ; don't del buf C if merging--del ancestor buf instead
+ (ediff-dispose-of-variant-according-to-user
+ ediff-ancestor-buffer 'Ancestor ask keep-variants)
+ (ediff-dispose-of-variant-according-to-user
+ ediff-buffer-C 'C ask keep-variants)
+ ))
+
+;; Kill the variant buffer, according to user directives (ask, kill
+;; unconditionaly, keep)
+;; BUFF is the buffer, BUFF-TYPE is either 'A, or 'B, 'C, 'Ancestor
+(defun ediff-dispose-of-variant-according-to-user (buff bufftype ask keep-variants)
+ ;; if this is indirect buffer, kill it and substitute with direct buf
+ (if (and (ediff-buffer-live-p buff)
+ (ediff-with-current-buffer buff ediff-temp-indirect-buffer))
+ (let ((wind (ediff-get-visible-buffer-window buff))
+ (base (buffer-base-buffer buff))
+ (modified-p (buffer-modified-p buff)))
+ (if (and (window-live-p wind) (ediff-buffer-live-p base))
+ (set-window-buffer wind base))
+ ;; Kill indirect buffer even if it is modified, because the base buffer
+ ;; is still there. Note that if the base buffer is dead then so will be
+ ;; the indirect buffer
+ (ediff-with-current-buffer buff
+ (set-buffer-modified-p nil))
+ (ediff-kill-buffer-carefully buff)
+ (ediff-with-current-buffer base
+ (set-buffer-modified-p modified-p)))
+ ;; otherwise, ask or use the value of keep-variants
+ (or (not (ediff-buffer-live-p buff))
+ keep-variants
+ (buffer-modified-p buff)
+ (and ask
+ (not (y-or-n-p (format "Kill buffer %S [%s]? "
+ bufftype (buffer-name buff)))))
+ (ediff-kill-buffer-carefully buff))
+ ))
+
+(defun ediff-maybe-save-and-delete-merge (&optional save-and-continue)
+ "Default hook to run on quitting a merge job.
+This can also be used to save merge buffer in the middle of an Ediff session.
+
+If the optional SAVE-AND-CONTINUE argument is non-nil, save merge buffer and
+continue. Otherwise:
+If `ediff-autostore-merges' is nil, this does nothing.
+If it is t, it saves the merge buffer in the file `ediff-merge-store-file'
+or asks the user, if the latter is nil. It then asks the user whether to
+delete the merge buffer.
+If `ediff-autostore-merges' is neither nil nor t, the merge buffer is saved
+only if this merge job is part of a group, i.e., was invoked from within
+`ediff-merge-directories', `ediff-merge-directory-revisions', and such."
+ (let ((merge-store-file ediff-merge-store-file)
+ (ediff-autostore-merges ; fake ediff-autostore-merges, if necessary
+ (if save-and-continue t ediff-autostore-merges)))
+ (if ediff-autostore-merges
+ (cond ((stringp merge-store-file)
+ ;; store, ask to delete
+ (ediff-write-merge-buffer-and-maybe-kill
+ ediff-buffer-C merge-store-file 'show-file save-and-continue))
+ ((eq ediff-autostore-merges t)
+ ;; ask for file name
+ (setq merge-store-file
+ (read-file-name "Save the result of the merge in file: "))
+ (ediff-write-merge-buffer-and-maybe-kill
+ ediff-buffer-C merge-store-file nil save-and-continue))
+ ((and (ediff-buffer-live-p ediff-meta-buffer)
+ (ediff-with-current-buffer ediff-meta-buffer
+ (ediff-merge-metajob)))
+ ;; The parent metajob passed nil as the autostore file.
+ nil)))
+ ))
+
+;; write merge buffer. If the optional argument save-and-continue is non-nil,
+;; then don't kill the merge buffer
+(defun ediff-write-merge-buffer-and-maybe-kill (buf file
+ &optional
+ show-file save-and-continue)
+ (if (not (eq (find-buffer-visiting file) buf))
+ (let ((warn-message
+ (format "Another buffer is visiting file %s. Too dangerous to save the merge buffer"
+ file)))
+ (beep)
+ (message "%s" warn-message)
+ (with-output-to-temp-buffer ediff-msg-buffer
+ (princ "\n\n")
+ (princ warn-message)
+ (princ "\n\n")
+ )
+ (sit-for 2))
+ (ediff-with-current-buffer buf
+ (if (or (not (file-exists-p file))
+ (y-or-n-p (format "File %s exists, overwrite? " file)))
+ (progn
+ ;;(write-region nil nil file)
+ (ediff-with-current-buffer buf
+ (set-visited-file-name file)
+ (save-buffer))
+ (if show-file
+ (progn
+ (message "Merge buffer saved in: %s" file)
+ (set-buffer-modified-p nil)
+ (sit-for 3)))
+ (if (and
+ (not save-and-continue)
+ (y-or-n-p "Merge buffer saved. Now kill the buffer? "))
+ (ediff-kill-buffer-carefully buf)))))
+ ))
+
+;; The default way of suspending Ediff.
+;; Buries Ediff buffers, kills all windows.
+(defun ediff-default-suspend-function ()
+ (let* ((buf-A ediff-buffer-A)
+ (buf-B ediff-buffer-B)
+ (buf-C ediff-buffer-C)
+ (buf-A-wind (ediff-get-visible-buffer-window buf-A))
+ (buf-B-wind (ediff-get-visible-buffer-window buf-B))
+ (buf-C-wind (ediff-get-visible-buffer-window buf-C))
+ (buf-patch (if (boundp 'ediff-patchbufer) ediff-patchbufer nil))
+ (buf-patch-diag (if (boundp 'ediff-patch-diagnostics)
+ ediff-patch-diagnostics nil))
+ (buf-err ediff-error-buffer)
+ (buf-diff ediff-diff-buffer)
+ (buf-custom-diff ediff-custom-diff-buffer)
+ (buf-fine-diff ediff-fine-diff-buffer))
+
+ ;; hide the control panel
+ (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame))
+ (iconify-frame ediff-control-frame)
+ (bury-buffer))
+ (if buf-err (bury-buffer buf-err))
+ (if buf-diff (bury-buffer buf-diff))
+ (if buf-custom-diff (bury-buffer buf-custom-diff))
+ (if buf-fine-diff (bury-buffer buf-fine-diff))
+ (if buf-patch (bury-buffer buf-patch))
+ (if buf-patch-diag (bury-buffer buf-patch-diag))
+ (if (window-live-p buf-A-wind)
+ (progn
+ (select-window buf-A-wind)
+ (delete-other-windows)
+ (bury-buffer))
+ (if (ediff-buffer-live-p buf-A)
+ (progn
+ (set-buffer buf-A)
+ (bury-buffer))))
+ (if (window-live-p buf-B-wind)
+ (progn
+ (select-window buf-B-wind)
+ (delete-other-windows)
+ (bury-buffer))
+ (if (ediff-buffer-live-p buf-B)
+ (progn
+ (set-buffer buf-B)
+ (bury-buffer))))
+ (if (window-live-p buf-C-wind)
+ (progn
+ (select-window buf-C-wind)
+ (delete-other-windows)
+ (bury-buffer))
+ (if (ediff-buffer-live-p buf-C)
+ (progn
+ (set-buffer buf-C)
+ (bury-buffer))))
+ ))
+
+
+(defun ediff-suspend ()
+ "Suspend Ediff.
+To resume, switch to the appropriate `Ediff Control Panel'
+buffer and then type \\[ediff-recenter]. Ediff will automatically set
+up an appropriate window config."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (run-hooks 'ediff-suspend-hook)
+ (message
+ "To resume, type M-x eregistry and select the desired Ediff session"))
+
+;; ediff-barf-if-not-control-buffer ensures only called from ediff.
+(declare-function ediff-version "ediff" ())
+
+(defun ediff-status-info ()
+ "Show the names of the buffers or files being operated on by Ediff.
+Hit \\[ediff-recenter] to reset the windows afterward."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (save-excursion
+ (ediff-skip-unsuitable-frames))
+ (with-output-to-temp-buffer ediff-msg-buffer
+ (ediff-with-current-buffer standard-output
+ (fundamental-mode))
+ (raise-frame (selected-frame))
+ (princ (ediff-version))
+ (princ "\n\n")
+ (ediff-with-current-buffer ediff-buffer-A
+ (if buffer-file-name
+ (princ
+ (format "File A = %S\n" buffer-file-name))
+ (princ
+ (format "Buffer A = %S\n" (buffer-name)))))
+ (ediff-with-current-buffer ediff-buffer-B
+ (if buffer-file-name
+ (princ
+ (format "File B = %S\n" buffer-file-name))
+ (princ
+ (format "Buffer B = %S\n" (buffer-name)))))
+ (if ediff-3way-job
+ (ediff-with-current-buffer ediff-buffer-C
+ (if buffer-file-name
+ (princ
+ (format "File C = %S\n" buffer-file-name))
+ (princ
+ (format "Buffer C = %S\n" (buffer-name))))))
+ (princ (format "Customized diff output %s\n"
+ (if (ediff-buffer-live-p ediff-custom-diff-buffer)
+ (concat "\tin buffer "
+ (buffer-name ediff-custom-diff-buffer))
+ " is not available")))
+ (princ (format "Plain diff output %s\n"
+ (if (ediff-buffer-live-p ediff-diff-buffer)
+ (concat "\tin buffer "
+ (buffer-name ediff-diff-buffer))
+ " is not available")))
+
+ (let* ((A-line (ediff-with-current-buffer ediff-buffer-A
+ (1+ (count-lines (point-min) (point)))))
+ (B-line (ediff-with-current-buffer ediff-buffer-B
+ (1+ (count-lines (point-min) (point)))))
+ C-line)
+ (princ (format "\Buffer A's point is on line %d\n" A-line))
+ (princ (format "Buffer B's point is on line %d\n" B-line))
+ (if ediff-3way-job
+ (progn
+ (setq C-line (ediff-with-current-buffer ediff-buffer-C
+ (1+ (count-lines (point-min) (point)))))
+ (princ (format "Buffer C's point is on line %d\n" C-line)))))
+
+ (princ (format "\nCurrent difference number = %S\n"
+ (cond ((< ediff-current-difference 0) 'start)
+ ((>= ediff-current-difference
+ ediff-number-of-differences) 'end)
+ (t (1+ ediff-current-difference)))))
+
+ (princ
+ (format "\n%s regions that differ in white space & line breaks only"
+ (if ediff-ignore-similar-regions
+ "Ignoring" "Showing")))
+ (if (and ediff-merge-job ediff-show-clashes-only)
+ (princ
+ "\nFocusing on regions where both buffers differ from the ancestor"))
+ (if (and ediff-skip-merge-regions-that-differ-from-default ediff-merge-job)
+ (princ
+ "\nSkipping merge regions that differ from default setting"))
+
+ (cond ((eq ediff-skip-diff-region-function 'ediff-show-all-diffs)
+ (princ "\nSelective browsing by regexp is off\n"))
+ ((eq ediff-skip-diff-region-function
+ ediff-hide-regexp-matches-function)
+ (princ
+ "\nIgnoring regions that match")
+ (princ
+ (format
+ "\n\t regexp `%s' in buffer A %S\n\t regexp `%s' in buffer B\n"
+ ediff-regexp-hide-A ediff-hide-regexp-connective
+ ediff-regexp-hide-B)))
+ ((eq ediff-skip-diff-region-function
+ ediff-focus-on-regexp-matches-function)
+ (princ
+ "\nFocusing on regions that match")
+ (princ
+ (format
+ "\n\t regexp `%s' in buffer A %S\n\t regexp `%s' in buffer B\n"
+ ediff-regexp-focus-A ediff-focus-regexp-connective
+ ediff-regexp-focus-B)))
+ (t (princ "\nSelective browsing via a user-defined method.\n")))
+
+ (princ
+ (format "\nBugs/suggestions: type `%s' while in Ediff Control Panel."
+ (substitute-command-keys "\\[ediff-submit-report]")))
+ ) ; with output
+ (if (frame-live-p ediff-control-frame)
+ (ediff-reset-mouse ediff-control-frame))
+ (if (window-live-p ediff-control-window)
+ (select-window ediff-control-window)))
+
+
+
+\f
+;;; Support routines
+
+;; Select a difference by placing the ASCII flags around the appropriate
+;; group of lines in the A, B buffers
+;; This may have to be modified for buffer C, when it will be supported.
+(defun ediff-select-difference (n)
+ (if (and (ediff-buffer-live-p ediff-buffer-A)
+ (ediff-buffer-live-p ediff-buffer-B)
+ (ediff-valid-difference-p n))
+ (progn
+ (cond
+ ((and (ediff-has-face-support-p) ediff-use-faces)
+ (ediff-highlight-diff n))
+ ((eq ediff-highlighting-style 'ascii)
+ (ediff-place-flags-in-buffer
+ 'A ediff-buffer-A ediff-control-buffer n)
+ (ediff-place-flags-in-buffer
+ 'B ediff-buffer-B ediff-control-buffer n)
+ (if ediff-3way-job
+ (ediff-place-flags-in-buffer
+ 'C ediff-buffer-C ediff-control-buffer n))
+ (if (ediff-buffer-live-p ediff-ancestor-buffer)
+ (ediff-place-flags-in-buffer
+ 'Ancestor ediff-ancestor-buffer
+ ediff-control-buffer n))
+ ))
+
+ (ediff-install-fine-diff-if-necessary n)
+ ;; set current difference here so the hook will be able to refer to it
+ (setq ediff-current-difference n)
+ (run-hooks 'ediff-select-hook))))
+
+
+;; Unselect a difference by removing the ASCII flags in the buffers.
+;; This may have to be modified for buffer C, when it will be supported.
+(defun ediff-unselect-difference (n)
+ (if (ediff-valid-difference-p n)
+ (progn
+ (cond ((and (ediff-has-face-support-p) ediff-use-faces)
+ (ediff-unhighlight-diff))
+ ((eq ediff-highlighting-style 'ascii)
+ (ediff-remove-flags-from-buffer
+ ediff-buffer-A
+ (ediff-get-diff-overlay n 'A))
+ (ediff-remove-flags-from-buffer
+ ediff-buffer-B
+ (ediff-get-diff-overlay n 'B))
+ (if ediff-3way-job
+ (ediff-remove-flags-from-buffer
+ ediff-buffer-C
+ (ediff-get-diff-overlay n 'C)))
+ (if (ediff-buffer-live-p ediff-ancestor-buffer)
+ (ediff-remove-flags-from-buffer
+ ediff-ancestor-buffer
+ (ediff-get-diff-overlay n 'Ancestor)))
+ ))
+
+ ;; unhighlight fine diffs
+ (ediff-set-fine-diff-properties ediff-current-difference 'default)
+ (run-hooks 'ediff-unselect-hook))))
+
+
+;; Unselects prev diff and selects a new one, if FLAG has value other than
+;; 'select-only or 'unselect-only. If FLAG is 'select-only, the
+;; next difference is selected, but the current selection is not
+;; unselected. If FLAG is 'unselect-only then the current selection is
+;; unselected, but the next one is not selected. If NO-RECENTER is non-nil,
+;; don't recenter buffers after selecting/unselecting.
+(defun ediff-unselect-and-select-difference (n &optional flag no-recenter)
+ (let ((ediff-current-difference n))
+ (or no-recenter
+ (ediff-recenter 'no-rehighlight)))
+
+ (let ((control-buf ediff-control-buffer))
+ (unwind-protect
+ (progn
+ (or (eq flag 'select-only)
+ (ediff-unselect-difference ediff-current-difference))
+
+ (or (eq flag 'unselect-only)
+ (ediff-select-difference n))
+ ;; need to set current diff here even though it is also set in
+ ;; ediff-select-difference because ediff-select-difference might not
+ ;; be called if unselect-only is specified
+ (setq ediff-current-difference n)
+ ) ; end protected section
+
+ (ediff-with-current-buffer control-buf (ediff-refresh-mode-lines)))
+ ))
+
+
+
+(defun ediff-highlight-diff-in-one-buffer (n buf-type)
+ (if (ediff-buffer-live-p (ediff-get-buffer buf-type))
+ (let* ((buff (ediff-get-buffer buf-type))
+ (last (ediff-with-current-buffer buff (point-max)))
+ (begin (ediff-get-diff-posn buf-type 'beg n))
+ (end (ediff-get-diff-posn buf-type 'end n))
+ (xtra (if (equal begin end) 1 0))
+ (end-hilit (min last (+ end xtra)))
+ (current-diff-overlay
+ (symbol-value
+ (ediff-get-symbol-from-alist
+ buf-type ediff-current-diff-overlay-alist))))
+
+ (if (featurep 'xemacs)
+ (ediff-move-overlay current-diff-overlay begin end-hilit)
+ (ediff-move-overlay current-diff-overlay begin end-hilit buff))
+ (ediff-overlay-put current-diff-overlay 'priority
+ (ediff-highest-priority begin end-hilit buff))
+ (ediff-overlay-put current-diff-overlay 'ediff-diff-num n)
+
+ ;; unhighlight the background overlay for diff n so it won't
+ ;; interfere with the current diff overlay
+ (ediff-set-overlay-face (ediff-get-diff-overlay n buf-type) nil)
+ )))
+
+
+(defun ediff-unhighlight-diff-in-one-buffer (buf-type)
+ (if (ediff-buffer-live-p (ediff-get-buffer buf-type))
+ (let ((current-diff-overlay
+ (symbol-value
+ (ediff-get-symbol-from-alist
+ buf-type ediff-current-diff-overlay-alist)))
+ (overlay
+ (ediff-get-diff-overlay ediff-current-difference buf-type))
+ )
+
+ (ediff-move-overlay current-diff-overlay 1 1)
+
+ ;; rehighlight the overlay in the background of the
+ ;; current difference region
+ (ediff-set-overlay-face
+ overlay
+ (if (and (ediff-has-face-support-p)
+ ediff-use-faces ediff-highlight-all-diffs)
+ (ediff-background-face buf-type ediff-current-difference)))
+ )))
+
+(defun ediff-unhighlight-diffs-totally-in-one-buffer (buf-type)
+ (ediff-unselect-and-select-difference -1)
+ (if (and (ediff-has-face-support-p) ediff-use-faces)
+ (let* ((inhibit-quit t)
+ (current-diff-overlay-var
+ (ediff-get-symbol-from-alist
+ buf-type ediff-current-diff-overlay-alist))
+ (current-diff-overlay (symbol-value current-diff-overlay-var)))
+ (ediff-paint-background-regions 'unhighlight)
+ (if (ediff-overlayp current-diff-overlay)
+ (ediff-delete-overlay current-diff-overlay))
+ (set current-diff-overlay-var nil)
+ )))
+
+
+(defun ediff-highlight-diff (n)
+ "Put face on diff N. Invoked for X displays only."
+ (ediff-highlight-diff-in-one-buffer n 'A)
+ (ediff-highlight-diff-in-one-buffer n 'B)
+ (ediff-highlight-diff-in-one-buffer n 'C)
+ (ediff-highlight-diff-in-one-buffer n 'Ancestor)
+ )
+
+
+(defun ediff-unhighlight-diff ()
+ "Remove overlays from buffers A, B, and C."
+ (ediff-unhighlight-diff-in-one-buffer 'A)
+ (ediff-unhighlight-diff-in-one-buffer 'B)
+ (ediff-unhighlight-diff-in-one-buffer 'C)
+ (ediff-unhighlight-diff-in-one-buffer 'Ancestor)
+ )
+
+;; delete highlighting overlays, restore faces to their original form
+(defun ediff-unhighlight-diffs-totally ()
+ (ediff-unhighlight-diffs-totally-in-one-buffer 'A)
+ (ediff-unhighlight-diffs-totally-in-one-buffer 'B)
+ (ediff-unhighlight-diffs-totally-in-one-buffer 'C)
+ (ediff-unhighlight-diffs-totally-in-one-buffer 'Ancestor)
+ )
+
+
+;; for compatibility
+(defmacro ediff-minibuffer-with-setup-hook (fun &rest body)
+ `(if (fboundp 'minibuffer-with-setup-hook)
+ (minibuffer-with-setup-hook ,fun ,@body)
+ ,@body))
+
+;; This is adapted from a similar function in `emerge.el'.
+;; PROMPT should not have a trailing ': ', so that it can be modified
+;; according to context.
+;; If DEFAULT-FILE is set, it should be used as the default value.
+;; If DEFAULT-DIR is non-nil, use it as the default directory.
+;; Otherwise, use the value of Emacs' variable `default-directory.'
+(defun ediff-read-file-name (prompt default-dir default-file &optional no-dirs)
+ ;; hack default-dir if it is not set
+ (setq default-dir
+ (file-name-as-directory
+ (ediff-abbreviate-file-name
+ (expand-file-name (or default-dir
+ (and default-file
+ (file-name-directory default-file))
+ default-directory)))))
+
+ ;; strip the directory from default-file
+ (if default-file
+ (setq default-file (file-name-nondirectory default-file)))
+ (if (string= default-file "")
+ (setq default-file nil))
+
+ (let ((defaults (and (fboundp 'dired-dwim-target-defaults)
+ (dired-dwim-target-defaults
+ (and default-file (list default-file))
+ default-dir)))
+ f)
+ (setq f (ediff-minibuffer-with-setup-hook
+ (lambda () (when defaults
+ (setq minibuffer-default defaults)))
+ (read-file-name
+ (format "%s%s "
+ prompt
+ (cond (default-file
+ (concat " (default " default-file "):"))
+ (t (concat " (default " default-dir "):"))))
+ default-dir
+ (or default-file default-dir)
+ t ; must match, no-confirm
+ (if default-file (file-name-directory default-file)))))
+ (setq f (expand-file-name f default-dir))
+ ;; If user entered a directory name, expand the default file in that
+ ;; directory. This allows the user to enter a directory name for the
+ ;; B-file and diff against the default-file in that directory instead
+ ;; of a DIRED listing!
+ (if (and (file-directory-p f) default-file)
+ (setq f (expand-file-name
+ (file-name-nondirectory default-file) f)))
+ (if (and no-dirs (file-directory-p f))
+ (error "File %s is a directory" f))
+ f))
+
+;; If PREFIX is given, then it is used as a prefix for the temp file
+;; name. Otherwise, `ediff' is used. If FILE is given, use this
+;; file and don't create a new one.
+;; In MS-DOS, make sure the prefix isn't too long, or else
+;; `make-temp-name' isn't guaranteed to return a unique filename.
+;; Also, save buffer from START to END in the file.
+;; START defaults to (point-min), END to (point-max)
+(defun ediff-make-temp-file (buff &optional prefix given-file start end)
+ (let* ((p (ediff-convert-standard-filename (or prefix "ediff")))
+ (short-p p)
+ (coding-system-for-write ediff-coding-system-for-write)
+ f short-f)
+ (if (and (fboundp 'msdos-long-file-names)
+ (not (msdos-long-file-names))
+ (> (length p) 2))
+ (setq short-p (substring p 0 2)))
+
+ (setq f (concat ediff-temp-file-prefix p)
+ short-f (concat ediff-temp-file-prefix short-p)
+ f (cond (given-file)
+ ((find-file-name-handler f 'insert-file-contents)
+ ;; to thwart file handlers in write-region, e.g., if file
+ ;; name ends with .Z or .gz
+ ;; This is needed so that patches produced by ediff will
+ ;; have more meaningful names
+ (ediff-make-empty-tmp-file short-f))
+ (prefix
+ ;; Prefix is most often the same as the file name for the
+ ;; variant. Here we are trying to use the original file
+ ;; name but in the temp directory.
+ (ediff-make-empty-tmp-file f 'keep-name))
+ (t
+ ;; If don't care about name, add some random stuff
+ ;; to proposed file name.
+ (ediff-make-empty-tmp-file short-f))))
+
+ ;; create the file
+ (ediff-with-current-buffer buff
+ (write-region (if start start (point-min))
+ (if end end (point-max))
+ f
+ nil ; don't append---erase
+ 'no-message)
+ (set-file-modes f ediff-temp-file-mode)
+ (expand-file-name f))))
+
+;; Create a temporary file.
+;; The returned file name (created by appending some random characters at the
+;; end of PROPOSED-NAME is guaranteed to point to a newly created empty file.
+;; This is a replacement for make-temp-name, which eliminates a security hole.
+;; If KEEP-PROPOSED-NAME isn't nil, try to keep PROPOSED-NAME, unless such file
+;; already exists.
+;; It is a modified version of make-temp-file in emacs 20.5
+(defun ediff-make-empty-tmp-file (proposed-name &optional keep-proposed-name)
+ (let ((file proposed-name))
+ (while (condition-case ()
+ (progn
+ (if (or (file-exists-p file) (not keep-proposed-name))
+ (setq file (make-temp-name proposed-name)))
+ ;; the with-temp-buffer thing is a workaround for an XEmacs
+ ;; bug: write-region complains that we are trying to visit a
+ ;; file in an indirect buffer, failing to notice that the
+ ;; VISIT flag is unset and that we are actually writing from a
+ ;; string and not from any buffer.
+ (with-temp-buffer
+ (write-region "" nil file nil 'silent nil 'excl))
+ nil)
+ (file-already-exists t))
+ ;; the file was somehow created by someone else between
+ ;; `make-temp-name' and `write-region', let's try again.
+ nil)
+ file))
+
+
+;; Quote metacharacters (using \) when executing diff in Unix, but not in
+;; EMX OS/2
+;;(defun ediff-protect-metachars (str)
+;; (or (memq system-type '(emx))
+;; (let ((limit 0))
+;; (while (string-match ediff-metachars str limit)
+;; (setq str (concat (substring str 0 (match-beginning 0))
+;; "\\"
+;; (substring str (match-beginning 0))))
+;; (setq limit (1+ (match-end 0))))))
+;; str)
+
+;; Make sure the current buffer (for a file) has the same contents as the
+;; file on disk, and attempt to remedy the situation if not.
+;; Signal an error if we can't make them the same, or the user doesn't want
+;; to do what is necessary to make them the same.
+;; Also, Ediff always offers to revert obsolete buffers, whether they
+;; are modified or not.
+(defun ediff-verify-file-buffer (&optional file-magic)
+ ;; First check if the file has been modified since the buffer visited it.
+ (if (verify-visited-file-modtime (current-buffer))
+ (if (buffer-modified-p)
+ ;; If buffer is not obsolete and is modified, offer to save
+ (if (yes-or-no-p
+ (format "Buffer %s has been modified. Save it in file %s? "
+ (buffer-name)
+ buffer-file-name))
+ (condition-case nil
+ (save-buffer)
+ (error
+ (beep)
+ (message "Couldn't save %s" buffer-file-name)))
+ (error "Buffer is out of sync for file %s" buffer-file-name))
+ ;; If buffer is not obsolete and is not modified, do nothing
+ nil)
+ ;; If buffer is obsolete, offer to revert
+ (if (yes-or-no-p
+ (format "File %s was modified since visited by buffer %s. REVERT file %s? "
+ buffer-file-name
+ (buffer-name)
+ buffer-file-name))
+ (progn
+ (if file-magic
+ (erase-buffer))
+ (revert-buffer t t))
+ (error "Buffer out of sync for file %s" buffer-file-name))))
+
+;; if there is another buffer visiting the file of the merge buffer, offer to
+;; save and delete the buffer; else bark
+(defun ediff-verify-file-merge-buffer (file)
+ (let ((buff (if (stringp file) (find-buffer-visiting file)))
+ warn-message)
+ (or (null buff)
+ (progn
+ (setq warn-message
+ (format "Buffer %s is visiting %s. Save and kill the buffer? "
+ (buffer-name buff) file))
+ (with-output-to-temp-buffer ediff-msg-buffer
+ (princ "\n\n")
+ (princ warn-message)
+ (princ "\n\n"))
+ (if (y-or-n-p
+ (message "%s" warn-message))
+ (with-current-buffer buff
+ (save-buffer)
+ (kill-buffer (current-buffer)))
+ (error "Too dangerous to merge versions of a file visited by another buffer"))))
+ ))
+
+
+
+(defun ediff-filename-magic-p (file)
+ (or (ediff-file-compressed-p file)
+ (ediff-file-remote-p file)))
+
+
+(defun ediff-save-buffer (arg)
+ "Safe way of saving buffers A, B, C, and the diff output.
+`wa' saves buffer A, `wb' saves buffer B, `wc' saves buffer C,
+and `wd' saves the diff output.
+
+With prefix argument, `wd' saves plain diff output.
+Without an argument, it saves customized diff argument, if available
+\(and plain output, if customized output was not generated\)."
+ (interactive "P")
+ (ediff-barf-if-not-control-buffer)
+ (ediff-compute-custom-diffs-maybe)
+ (ediff-with-current-buffer
+ (cond ((memq (ediff-last-command-char) '(?a ?b ?c))
+ (ediff-get-buffer
+ (ediff-char-to-buftype (ediff-last-command-char))))
+ ((eq (ediff-last-command-char) ?d)
+ (message "Saving diff output ...")
+ (sit-for 1) ; let the user see the message
+ (cond ((and arg (ediff-buffer-live-p ediff-diff-buffer))
+ ediff-diff-buffer)
+ ((ediff-buffer-live-p ediff-custom-diff-buffer)
+ ediff-custom-diff-buffer)
+ ((ediff-buffer-live-p ediff-diff-buffer)
+ ediff-diff-buffer)
+ (t (error "Output from `diff' not found"))))
+ )
+ (let ((window-min-height 2))
+ (save-buffer))))
+
+
+;; idea suggested by Hannu Koivisto <azure@iki.fi>
+(defun ediff-clone-buffer-for-region-comparison (buff region-name)
+ (let ((cloned-buff (ediff-make-cloned-buffer buff region-name))
+ (pop-up-windows t)
+ wind
+ other-wind
+ msg-buf)
+ (ediff-with-current-buffer cloned-buff
+ (setq ediff-temp-indirect-buffer t))
+ (pop-to-buffer cloned-buff)
+ (setq wind (ediff-get-visible-buffer-window cloned-buff))
+ (select-window wind)
+ (delete-other-windows)
+ (ediff-activate-mark)
+ (split-window-vertically)
+ (ediff-select-lowest-window)
+ (setq other-wind (selected-window))
+ (with-temp-buffer
+ (erase-buffer)
+ (insert
+ (format "\n ******* Mark a region in buffer %s (or confirm the existing one) *******\n"
+ (buffer-name cloned-buff)))
+ (insert
+ (ediff-with-current-buffer buff
+ (format "\n\t When done, type %s Use %s to abort\n "
+ (ediff-format-bindings-of 'exit-recursive-edit)
+ (ediff-format-bindings-of 'abort-recursive-edit))))
+ (goto-char (point-min))
+ (setq msg-buf (current-buffer))
+ (set-window-buffer other-wind msg-buf)
+ (shrink-window-if-larger-than-buffer)
+ (if (window-live-p wind)
+ (select-window wind))
+ (condition-case nil
+ (recursive-edit)
+ (quit
+ (ediff-kill-buffer-carefully cloned-buff)))
+ )
+ cloned-buff))
+
+
+(defun ediff-clone-buffer-for-window-comparison (buff wind region-name)
+ (let ((cloned-buff (ediff-make-cloned-buffer buff region-name)))
+ (ediff-with-current-buffer cloned-buff
+ (setq ediff-temp-indirect-buffer t))
+ (set-window-buffer wind cloned-buff)
+ cloned-buff))
+
+(defun ediff-clone-buffer-for-current-diff-comparison (buff buf-type reg-name)
+ (let ((cloned-buff (ediff-make-cloned-buffer buff reg-name))
+ (reg-start (ediff-get-diff-posn buf-type 'beg))
+ (reg-end (ediff-get-diff-posn buf-type 'end)))
+ (ediff-with-current-buffer cloned-buff
+ ;; set region to be the current diff region
+ (goto-char reg-start)
+ (set-mark reg-end)
+ (setq ediff-temp-indirect-buffer t))
+ cloned-buff))
+
+
+
+(defun ediff-make-cloned-buffer (buff region-name)
+ (ediff-make-indirect-buffer
+ buff (generate-new-buffer-name
+ (concat (if (stringp buff) buff (buffer-name buff)) region-name))))
+
+
+(defun ediff-make-indirect-buffer (base-buf indirect-buf-name)
+ (if (featurep 'xemacs)
+ (make-indirect-buffer base-buf indirect-buf-name)
+ (make-indirect-buffer base-buf indirect-buf-name 'clone)))
+
+
+;; This function operates only from an ediff control buffer
+(defun ediff-compute-custom-diffs-maybe ()
+ (let ((buf-A-file-name (buffer-file-name ediff-buffer-A))
+ (buf-B-file-name (buffer-file-name ediff-buffer-B))
+ file-A file-B)
+ (unless (and buf-A-file-name
+ (file-exists-p buf-A-file-name)
+ (not (ediff-file-remote-p buf-A-file-name)))
+ (setq file-A (ediff-make-temp-file ediff-buffer-A)))
+ (unless (and buf-B-file-name
+ (file-exists-p buf-B-file-name)
+ (not (ediff-file-remote-p buf-B-file-name)))
+ (setq file-B (ediff-make-temp-file ediff-buffer-B)))
+ (or (ediff-buffer-live-p ediff-custom-diff-buffer)
+ (setq ediff-custom-diff-buffer
+ (get-buffer-create
+ (ediff-unique-buffer-name "*ediff-custom-diff" "*"))))
+ (ediff-with-current-buffer ediff-custom-diff-buffer
+ (setq buffer-read-only nil)
+ (erase-buffer))
+ (ediff-exec-process
+ ediff-custom-diff-program ediff-custom-diff-buffer 'synchronize
+ ediff-custom-diff-options
+ (or file-A buf-A-file-name)
+ (or file-B buf-B-file-name))
+ ;; put the diff file in diff-mode, if it is available
+ (if (fboundp 'diff-mode)
+ (with-current-buffer ediff-custom-diff-buffer
+ (diff-mode)))
+ (and file-A (file-exists-p file-A) (delete-file file-A))
+ (and file-B (file-exists-p file-B) (delete-file file-B))
+ ))
+
+(defun ediff-show-diff-output (arg)
+ (interactive "P")
+ (ediff-barf-if-not-control-buffer)
+ (ediff-compute-custom-diffs-maybe)
+ (save-excursion
+ (ediff-skip-unsuitable-frames ' ok-unsplittable))
+ (let ((buf (cond ((and arg (ediff-buffer-live-p ediff-diff-buffer))
+ ediff-diff-buffer)
+ ((ediff-buffer-live-p ediff-custom-diff-buffer)
+ ediff-custom-diff-buffer)
+ ((ediff-buffer-live-p ediff-diff-buffer)
+ ediff-diff-buffer)
+ (t
+ (beep)
+ (message "Output from `diff' not found")
+ nil))))
+ (if buf
+ (progn
+ (ediff-with-current-buffer buf
+ (goto-char (point-min)))
+ (switch-to-buffer buf)
+ (raise-frame (selected-frame)))))
+ (if (frame-live-p ediff-control-frame)
+ (ediff-reset-mouse ediff-control-frame))
+ (if (window-live-p ediff-control-window)
+ (select-window ediff-control-window)))
+
+
+(defun ediff-inferior-compare-regions ()
+ "Compare regions in an active Ediff session.
+Like ediff-regions-linewise but is called from under an active Ediff session on
+the files that belong to that session.
+
+After quitting the session invoked via this function, type C-l to the parent
+Ediff Control Panel to restore highlighting."
+ (interactive)
+ (let ((answer "")
+ (possibilities (list ?A ?B ?C))
+ (zmacs-regions t)
+ use-current-diff-p
+ begA begB endA endB bufA bufB)
+
+ (if (ediff-valid-difference-p ediff-current-difference)
+ (progn
+ (ediff-set-fine-diff-properties ediff-current-difference 'default)
+ (ediff-unhighlight-diff)))
+ (ediff-paint-background-regions 'unhighlight)
+
+ (cond ((ediff-merge-job)
+ (setq bufB ediff-buffer-C)
+ ;; ask which buffer to compare to the merge buffer
+ (while (cond ((eq answer ?A)
+ (setq bufA ediff-buffer-A
+ possibilities '(?B))
+ nil)
+ ((eq answer ?B)
+ (setq bufA ediff-buffer-B
+ possibilities '(?A))
+ nil)
+ ((equal answer ""))
+ (t (beep 1)
+ (message "Valid values are A or B")
+ (sit-for 2)
+ t))
+ (let ((cursor-in-echo-area t))
+ (message
+ "Which buffer to compare to the merge buffer (A or B)? ")
+ (setq answer (capitalize (read-char-exclusive))))))
+
+ ((ediff-3way-comparison-job)
+ ;; ask which two buffers to compare
+ (while (cond ((memq answer possibilities)
+ (setq possibilities (delq answer possibilities))
+ (setq bufA
+ (eval
+ (ediff-get-symbol-from-alist
+ answer ediff-buffer-alist)))
+ nil)
+ ((equal answer ""))
+ (t (beep 1)
+ (message
+ "Valid values are %s"
+ (mapconcat 'char-to-string possibilities " or "))
+ (sit-for 2)
+ t))
+ (let ((cursor-in-echo-area t))
+ (message "Enter the 1st buffer you want to compare (%s): "
+ (mapconcat 'char-to-string possibilities " or "))
+ (setq answer (capitalize (read-char-exclusive)))))
+ (setq answer "") ; silence error msg
+ (while (cond ((memq answer possibilities)
+ (setq possibilities (delq answer possibilities))
+ (setq bufB
+ (eval
+ (ediff-get-symbol-from-alist
+ answer ediff-buffer-alist)))
+ nil)
+ ((equal answer ""))
+ (t (beep 1)
+ (message
+ "Valid values are %s"
+ (mapconcat 'char-to-string possibilities " or "))
+ (sit-for 2)
+ t))
+ (let ((cursor-in-echo-area t))
+ (message "Enter the 2nd buffer you want to compare (%s): "
+ (mapconcat 'char-to-string possibilities "/"))
+ (setq answer (capitalize (read-char-exclusive))))))
+ (t ; 2way comparison
+ (setq bufA ediff-buffer-A
+ bufB ediff-buffer-B
+ possibilities nil)))
+
+ (if (and (ediff-valid-difference-p ediff-current-difference)
+ (y-or-n-p "Compare currently highlighted difference regions? "))
+ (setq use-current-diff-p t))
+
+ (setq bufA (if use-current-diff-p
+ (ediff-clone-buffer-for-current-diff-comparison
+ bufA 'A "-Region.A-")
+ (ediff-clone-buffer-for-region-comparison bufA "-Region.A-")))
+ (ediff-with-current-buffer bufA
+ (setq begA (region-beginning)
+ endA (region-end))
+ (goto-char begA)
+ (beginning-of-line)
+ (setq begA (point))
+ (goto-char endA)
+ (end-of-line)
+ (or (eobp) (forward-char)) ; include the newline char
+ (setq endA (point)))
+
+ (setq bufB (if use-current-diff-p
+ (ediff-clone-buffer-for-current-diff-comparison
+ bufB 'B "-Region.B-")
+ (ediff-clone-buffer-for-region-comparison bufB "-Region.B-")))
+ (ediff-with-current-buffer bufB
+ (setq begB (region-beginning)
+ endB (region-end))
+ (goto-char begB)
+ (beginning-of-line)
+ (setq begB (point))
+ (goto-char endB)
+ (end-of-line)
+ (or (eobp) (forward-char)) ; include the newline char
+ (setq endB (point)))
+
+
+ (ediff-regions-internal
+ bufA begA endA bufB begB endB
+ nil ; setup-hook
+ (if use-current-diff-p ; job name
+ 'ediff-regions-wordwise
+ 'ediff-regions-linewise)
+ (if use-current-diff-p ; word mode, if diffing current diff
+ t nil)
+ ;; setup param to pass to ediff-setup
+ (list (cons 'ediff-split-window-function ediff-split-window-function)))
+ ))
+
+
+
+(defun ediff-remove-flags-from-buffer (buffer overlay)
+ (ediff-with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (if (featurep 'xemacs)
+ (ediff-overlay-put overlay 'begin-glyph nil)
+ (ediff-overlay-put overlay 'before-string nil))
+
+ (if (featurep 'xemacs)
+ (ediff-overlay-put overlay 'end-glyph nil)
+ (ediff-overlay-put overlay 'after-string nil))
+ )))
+
+
+
+(defun ediff-place-flags-in-buffer (buf-type buffer ctl-buffer diff)
+ (ediff-with-current-buffer buffer
+ (ediff-place-flags-in-buffer1 buf-type ctl-buffer diff)))
+
+
+(defun ediff-place-flags-in-buffer1 (buf-type ctl-buffer diff-no)
+ (let* ((curr-overl (ediff-with-current-buffer ctl-buffer
+ (ediff-get-diff-overlay diff-no buf-type)))
+ (before (ediff-get-diff-posn buf-type 'beg diff-no ctl-buffer))
+ after beg-of-line flag)
+
+ ;; insert flag before the difference
+ (goto-char before)
+ (setq beg-of-line (bolp))
+
+ (setq flag (ediff-with-current-buffer ctl-buffer
+ (if (eq ediff-highlighting-style 'ascii)
+ (if beg-of-line
+ ediff-before-flag-bol ediff-before-flag-mol))))
+
+ ;; insert the flag itself
+ (if (featurep 'xemacs)
+ (ediff-overlay-put curr-overl 'begin-glyph flag)
+ (ediff-overlay-put curr-overl 'before-string flag))
+
+ ;; insert the flag after the difference
+ ;; `after' must be set here, after the before-flag was inserted
+ (setq after (ediff-get-diff-posn buf-type 'end diff-no ctl-buffer))
+ (goto-char after)
+ (setq beg-of-line (bolp))
+
+ (setq flag (ediff-with-current-buffer ctl-buffer
+ (if (eq ediff-highlighting-style 'ascii)
+ (if beg-of-line
+ ediff-after-flag-eol ediff-after-flag-mol))))
+
+ ;; insert the flag itself
+ (if (featurep 'xemacs)
+ (ediff-overlay-put curr-overl 'end-glyph flag)
+ (ediff-overlay-put curr-overl 'after-string flag))
+ ))
+
+
+;;; Some diff region tests
+
+;; t if diff region is empty.
+;; In case of buffer C, t also if it is not a 3way
+;; comparison job (merging jobs return t as well).
+(defun ediff-empty-diff-region-p (n buf-type)
+ (if (eq buf-type 'C)
+ (or (not ediff-3way-comparison-job)
+ (= (ediff-get-diff-posn 'C 'beg n)
+ (ediff-get-diff-posn 'C 'end n)))
+ (= (ediff-get-diff-posn buf-type 'beg n)
+ (ediff-get-diff-posn buf-type 'end n))))
+
+;; Test if diff region is white space only.
+;; If 2-way job and buf-type = C, then returns t.
+(defun ediff-whitespace-diff-region-p (n buf-type)
+ (or (and (eq buf-type 'C) (not ediff-3way-job))
+ (ediff-empty-diff-region-p n buf-type)
+ (let ((beg (ediff-get-diff-posn buf-type 'beg n))
+ (end (ediff-get-diff-posn buf-type 'end n)))
+ (ediff-with-current-buffer (ediff-get-buffer buf-type)
+ (save-excursion
+ (goto-char beg)
+ (skip-chars-forward ediff-whitespace)
+ (>= (point) end))))))
+
+
+(defun ediff-get-region-contents (n buf-type ctrl-buf &optional start end)
+ (ediff-with-current-buffer
+ (ediff-with-current-buffer ctrl-buf (ediff-get-buffer buf-type))
+ (buffer-substring
+ (or start (ediff-get-diff-posn buf-type 'beg n ctrl-buf))
+ (or end (ediff-get-diff-posn buf-type 'end n ctrl-buf)))))
+
+;; Returns positions of difference sectors in the BUF-TYPE buffer.
+;; BUF-TYPE should be a symbol -- `A', `B', or `C'.
+;; POS is either `beg' or `end'--it specifies whether you want the position at
+;; the beginning of a difference or at the end.
+;;
+;; The optional argument N says which difference (default:
+;; `ediff-current-difference'). N is the internal difference number (1- what
+;; the user sees). The optional argument CONTROL-BUF says
+;; which control buffer is in effect in case it is not the current
+;; buffer.
+(defun ediff-get-diff-posn (buf-type pos &optional n control-buf)
+ (let (diff-overlay)
+ (or control-buf
+ (setq control-buf (current-buffer)))
+
+ (ediff-with-current-buffer control-buf
+ (or n (setq n ediff-current-difference))
+ (if (or (< n 0) (>= n ediff-number-of-differences))
+ (if (> ediff-number-of-differences 0)
+ (error ediff-BAD-DIFF-NUMBER
+ this-command (1+ n) ediff-number-of-differences)
+ (error ediff-NO-DIFFERENCES)))
+ (setq diff-overlay (ediff-get-diff-overlay n buf-type)))
+ (if (not (ediff-buffer-live-p (ediff-overlay-buffer diff-overlay)))
+ (error ediff-KILLED-VITAL-BUFFER))
+ (if (eq pos 'beg)
+ (ediff-overlay-start diff-overlay)
+ (ediff-overlay-end diff-overlay))
+ ))
+
+
+;; Restore highlighting to what it should be according to ediff-use-faces,
+;; ediff-highlighting-style, and ediff-highlight-all-diffs variables.
+(defun ediff-restore-highlighting (&optional ctl-buf)
+ (ediff-with-current-buffer (or ctl-buf (current-buffer))
+ (if (and (ediff-has-face-support-p)
+ ediff-use-faces
+ ediff-highlight-all-diffs)
+ (ediff-paint-background-regions))
+ (ediff-select-difference ediff-current-difference)))
+
+
+
+;; null out difference overlays so they won't slow down future
+;; editing operations
+;; VEC is either a difference vector or a fine-diff vector
+(defun ediff-clear-diff-vector (vec-var &optional fine-diffs-also)
+ (if (vectorp (symbol-value vec-var))
+ (mapc (lambda (elt)
+ (ediff-delete-overlay
+ (ediff-get-diff-overlay-from-diff-record elt))
+ (if fine-diffs-also
+ (ediff-clear-fine-diff-vector elt))
+ )
+ (symbol-value vec-var)))
+ ;; allow them to be garbage collected
+ (set vec-var nil))
+
+
+\f
+;;; Misc
+
+;; In Emacs, this just makes overlay. In the future, when Emacs will start
+;; supporting sticky overlays, this function will make a sticky overlay.
+;; BEG and END are expressions telling where overlay starts.
+;; If they are numbers or buffers, then all is well. Otherwise, they must
+;; be expressions to be evaluated in buffer BUF in order to get the overlay
+;; bounds.
+;; If BUFF is not a live buffer, then return nil; otherwise, return the
+;; newly created overlay.
+(defun ediff-make-bullet-proof-overlay (beg end buff)
+ (if (ediff-buffer-live-p buff)
+ (let (overl)
+ (ediff-with-current-buffer buff
+ (or (number-or-marker-p beg)
+ (setq beg (eval beg)))
+ (or (number-or-marker-p end)
+ (setq end (eval end)))
+ (setq overl
+ (if (featurep 'xemacs)
+ (make-extent beg end buff)
+ ;; advance front and rear of the overlay
+ (make-overlay beg end buff nil 'rear-advance)))
+
+ ;; never detach
+ (ediff-overlay-put
+ overl (if (featurep 'emacs) 'evaporate 'detachable) nil)
+ ;; make overlay open-ended
+ ;; In emacs, it is made open ended at creation time
+ (when (featurep 'xemacs)
+ (ediff-overlay-put overl 'start-open nil)
+ (ediff-overlay-put overl 'end-open nil))
+ (ediff-overlay-put overl 'ediff-diff-num 0)
+ overl))))
+
+
+(defun ediff-make-current-diff-overlay (type)
+ (if (ediff-has-face-support-p)
+ (let ((overlay (ediff-get-symbol-from-alist
+ type ediff-current-diff-overlay-alist))
+ (buffer (ediff-get-buffer type))
+ (face (ediff-get-symbol-from-alist
+ type ediff-current-diff-face-alist)))
+ (set overlay
+ (ediff-make-bullet-proof-overlay (point-max) (point-max) buffer))
+ (ediff-set-overlay-face (symbol-value overlay) face)
+ (ediff-overlay-put (symbol-value overlay) 'ediff ediff-control-buffer))
+ ))
+
+
+;; Like other-buffer, but prefers visible buffers and ignores temporary or
+;; other insignificant buffers (those beginning with "^[ *]").
+;; Gets one arg--buffer name or a list of buffer names (it won't return
+;; these buffers).
+;; EXCL-BUFF-LIST is an exclusion list.
+(defun ediff-other-buffer (excl-buff-lst)
+ (or (listp excl-buff-lst) (setq excl-buff-lst (list excl-buff-lst)))
+ (let* ((all-buffers (nconc (ediff-get-selected-buffers) (buffer-list)))
+ ;; we compute this the second time because we need to do memq on it
+ ;; later, and nconc above will break it. Either this or use slow
+ ;; append instead of nconc
+ (selected-buffers (ediff-get-selected-buffers))
+ (prefered-buffer (car all-buffers))
+ visible-dired-buffers
+ (excl-buff-name-list
+ (mapcar
+ (lambda (b) (cond ((stringp b) b)
+ ((bufferp b) (buffer-name b))))
+ excl-buff-lst))
+ ;; if at least one buffer on the exclusion list is dired, then force
+ ;; all others to be dired. This is because this means that the user
+ ;; has already chosen a dired buffer before
+ (use-dired-major-mode
+ (cond ((null (ediff-buffer-live-p (car excl-buff-lst))) 'unknown)
+ ((eq (ediff-with-current-buffer (car excl-buff-lst) major-mode)
+ 'dired-mode)
+ 'yes)
+ (t 'no)))
+ ;; significant-buffers must be visible and not belong
+ ;; to the exclusion list `buff-list'
+ ;; We also exclude temporary buffers, but keep mail and gnus buffers
+ ;; Furthermore, we exclude dired buffers, unless they are the only
+ ;; ones visible (and there are at least two of them).
+ ;; Also, any visible window not on the exclusion list that is first in
+ ;; the buffer list is chosen regardless. (This is because the user
+ ;; clicked on it or did something to distinguish it).
+ (significant-buffers
+ (mapcar
+ (lambda (x)
+ (cond ((member (buffer-name x) excl-buff-name-list) nil)
+ ((memq x selected-buffers) x)
+ ((not (ediff-get-visible-buffer-window x)) nil)
+ ((eq x prefered-buffer) x)
+ ;; if prev selected buffer is dired, look only at
+ ;; dired.
+ ((eq use-dired-major-mode 'yes)
+ (if (eq (ediff-with-current-buffer x major-mode)
+ 'dired-mode)
+ x nil))
+ ((eq (ediff-with-current-buffer x major-mode)
+ 'dired-mode)
+ (if (null use-dired-major-mode)
+ ;; don't know if we must enforce dired.
+ ;; Remember this buffer in case
+ ;; dired buffs are the only ones visible.
+ (setq visible-dired-buffers
+ (cons x visible-dired-buffers)))
+ ;; skip, if dired is not forced
+ nil)
+ ((memq (ediff-with-current-buffer x major-mode)
+ '(rmail-mode
+ vm-mode
+ gnus-article-mode
+ mh-show-mode))
+ x)
+ ((string-match "^[ *]" (buffer-name x)) nil)
+ ((string= "*scratch*" (buffer-name x)) nil)
+ (t x)))
+ all-buffers))
+ (clean-significant-buffers (delq nil significant-buffers))
+ less-significant-buffers)
+
+ (if (and (null clean-significant-buffers)
+ (> (length visible-dired-buffers) 0))
+ (setq clean-significant-buffers visible-dired-buffers))
+
+ (cond (clean-significant-buffers (car clean-significant-buffers))
+ ;; try also buffers that are not displayed in windows
+ ((setq less-significant-buffers
+ (delq nil
+ (mapcar
+ (lambda (x)
+ (cond ((member (buffer-name x) excl-buff-name-list)
+ nil)
+ ((eq use-dired-major-mode 'yes)
+ (if (eq (ediff-with-current-buffer
+ x major-mode)
+ 'dired-mode)
+ x nil))
+ ((eq (ediff-with-current-buffer x major-mode)
+ 'dired-mode)
+ nil)
+ ((string-match "^[ *]" (buffer-name x)) nil)
+ ((string= "*scratch*" (buffer-name x)) nil)
+ (t x)))
+ all-buffers)))
+ (car less-significant-buffers))
+ (t "*scratch*"))
+ ))
+
+
+;; If current buffer is a Buffer-menu buffer, then take the selected buffers
+;; and append the buffer at the cursor to the end.
+;; This list would be the preferred list.
+(defun ediff-get-selected-buffers ()
+ (if (eq major-mode 'Buffer-menu-mode)
+ (let ((lis (condition-case nil
+ (list (Buffer-menu-buffer t))
+ (error))
+ ))
+ (save-excursion
+ (goto-char (point-max))
+ (while (search-backward "\n>" nil t)
+ (forward-char 1)
+ (setq lis (cons (Buffer-menu-buffer t) lis)))
+ lis))
+ ))
+
+;; Construct a unique buffer name.
+;; The first one tried is prefixsuffix, then prefix<2>suffix,
+;; prefix<3>suffix, etc.
+(defun ediff-unique-buffer-name (prefix suffix)
+ (if (null (get-buffer (concat prefix suffix)))
+ (concat prefix suffix)
+ (let ((n 2))
+ (while (get-buffer (format "%s<%d>%s" prefix n suffix))
+ (setq n (1+ n)))
+ (format "%s<%d>%s" prefix n suffix))))
+
+
+(defun ediff-submit-report ()
+ "Submit bug report on Ediff."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (let ((reporter-prompt-for-summary-p t)
+ (ctl-buf ediff-control-buffer)
+ (ediff-device-type (ediff-device-type))
+ varlist salutation buffer-name)
+ (setq varlist '(ediff-diff-program ediff-diff-options
+ ediff-diff3-program ediff-diff3-options
+ ediff-patch-program ediff-patch-options
+ ediff-shell
+ ediff-use-faces
+ ediff-auto-refine ediff-highlighting-style
+ ediff-buffer-A ediff-buffer-B ediff-control-buffer
+ ediff-forward-word-function
+ ediff-control-frame
+ ediff-control-frame-parameters
+ ediff-control-frame-position-function
+ ediff-prefer-iconified-control-frame
+ ediff-window-setup-function
+ ediff-split-window-function
+ ediff-job-name
+ ediff-word-mode
+ buffer-name
+ ediff-device-type
+ ))
+ (setq salutation "
+Congratulations! You may have unearthed a bug in Ediff!
+
+Please make a concise and accurate summary of what happened
+and mail it to the address above.
+-----------------------------------------------------------
+")
+
+ (ediff-skip-unsuitable-frames)
+ (ediff-reset-mouse)
+
+ (switch-to-buffer ediff-msg-buffer)
+ (erase-buffer)
+ (delete-other-windows)
+ (insert "
+Please read this first:
+----------------------
+
+Some ``bugs'' may actually be no bugs at all. For instance, if you are
+reporting that certain difference regions are not matched as you think they
+should, this is most likely due to the way Unix diff program decides what
+constitutes a difference region. Ediff is an Emacs interface to diff, and
+it has nothing to do with those decisions---it only takes the output from
+diff and presents it in a way that is better suited for human browsing and
+manipulation.
+
+If Emacs happens to dump core, this is NOT an Ediff problem---it is
+an Emacs bug. Report this to Emacs maintainers.
+
+Another popular topic for reports is compilation messages. Because Ediff
+interfaces to several other packages and runs under Emacs and XEmacs,
+byte-compilation may produce output like this:
+
+ While compiling toplevel forms in file ediff.el:
+ ** reference to free variable pm-color-alist
+ ........................
+ While compiling the end of the data:
+ ** The following functions are not known to be defined:
+ ediff-valid-color-p, ediff-set-face,
+ ........................
+
+These are NOT errors, but inevitable warnings, which ought to be ignored.
+
+Please do not report those and similar things. However, comments and
+suggestions are always welcome.
+
+Mail anyway? (y or n) ")
+
+ (if (y-or-n-p "Mail anyway? ")
+ (progn
+ (if (ediff-buffer-live-p ctl-buf)
+ (set-buffer ctl-buf))
+ (setq buffer-name (buffer-name))
+ (require 'reporter)
+ (reporter-submit-bug-report "kifer@cs.stonybrook.edu"
+ (ediff-version)
+ varlist
+ nil
+ 'delete-other-windows
+ salutation))
+ (bury-buffer)
+ (beep 1)(message "Bug report aborted")
+ (if (ediff-buffer-live-p ctl-buf)
+ (ediff-with-current-buffer ctl-buf
+ (ediff-recenter 'no-rehighlight))))
+ ))
+
+
+;; Find an appropriate syntax table for everyone to use
+;; If buffer B is not fundamental or text mode, use its syntax table
+;; Otherwise, use buffer B's.
+;; The syntax mode is used in ediff-forward-word-function
+;; The important thing is that every buffer should use the same syntax table
+;; during the refinement operation
+(defun ediff-choose-syntax-table ()
+ (setq ediff-syntax-table
+ (ediff-with-current-buffer ediff-buffer-A
+ (if (not (memq major-mode
+ '(fundamental-mode text-mode indented-text-mode)))
+ (syntax-table))))
+ (if (not ediff-syntax-table)
+ (setq ediff-syntax-table
+ (ediff-with-current-buffer ediff-buffer-B
+ (syntax-table))))
+ )
+
+
+(defun ediff-deactivate-mark ()
+ (if (featurep 'xemacs)
+ (zmacs-deactivate-region)
+ (deactivate-mark)))
+
+(defun ediff-activate-mark ()
+ (if (featurep 'xemacs)
+ (zmacs-activate-region)
+ (make-local-variable 'transient-mark-mode)
+ (setq mark-active t transient-mark-mode t)))
+
+(defun ediff-nuke-selective-display ()
+ (if (featurep 'xemacs)
+ (nuke-selective-display)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (let ((mod-p (buffer-modified-p))
+ buffer-read-only end)
+ (and (eq t selective-display)
+ (while (search-forward "\^M" nil t)
+ (end-of-line)
+ (setq end (point))
+ (beginning-of-line)
+ (while (search-forward "\^M" end t)
+ (delete-char -1)
+ (insert "\^J"))))
+ (set-buffer-modified-p mod-p)
+ (setq selective-display nil))))))
+
+
+;; The next two are modified versions from emerge.el.
+;; VARS must be a list of symbols
+;; ediff-save-variables returns an association list: ((var . val) ...)
+(defsubst ediff-save-variables (vars)
+ (mapcar (lambda (v) (cons v (symbol-value v)))
+ vars))
+;; VARS is a list of variable symbols.
+(defun ediff-restore-variables (vars assoc-list)
+ (while vars
+ (set (car vars) (cdr (assoc (car vars) assoc-list)))
+ (setq vars (cdr vars))))
+
+(defun ediff-change-saved-variable (var value buf-type)
+ (let* ((assoc-list
+ (symbol-value (ediff-get-symbol-from-alist
+ buf-type
+ ediff-buffer-values-orig-alist)))
+ (assoc-elt (assoc var assoc-list)))
+ (if assoc-elt
+ (setcdr assoc-elt value))))
+
+
+;; must execute in control buf
+(defun ediff-save-protected-variables ()
+ (setq ediff-buffer-values-orig-A
+ (ediff-with-current-buffer ediff-buffer-A
+ (ediff-save-variables ediff-protected-variables)))
+ (setq ediff-buffer-values-orig-B
+ (ediff-with-current-buffer ediff-buffer-B
+ (ediff-save-variables ediff-protected-variables)))
+ (if ediff-3way-comparison-job
+ (setq ediff-buffer-values-orig-C
+ (ediff-with-current-buffer ediff-buffer-C
+ (ediff-save-variables ediff-protected-variables))))
+ (if (ediff-buffer-live-p ediff-ancestor-buffer)
+ (setq ediff-buffer-values-orig-Ancestor
+ (ediff-with-current-buffer ediff-ancestor-buffer
+ (ediff-save-variables ediff-protected-variables)))))
+
+;; must execute in control buf
+(defun ediff-restore-protected-variables ()
+ (let ((values-A ediff-buffer-values-orig-A)
+ (values-B ediff-buffer-values-orig-B)
+ (values-C ediff-buffer-values-orig-C)
+ (values-Ancestor ediff-buffer-values-orig-Ancestor))
+ (ediff-with-current-buffer ediff-buffer-A
+ (ediff-restore-variables ediff-protected-variables values-A))
+ (ediff-with-current-buffer ediff-buffer-B
+ (ediff-restore-variables ediff-protected-variables values-B))
+ (if ediff-3way-comparison-job
+ (ediff-with-current-buffer ediff-buffer-C
+ (ediff-restore-variables ediff-protected-variables values-C)))
+ (if (ediff-buffer-live-p ediff-ancestor-buffer)
+ (ediff-with-current-buffer ediff-ancestor-buffer
+ (ediff-restore-variables ediff-protected-variables values-Ancestor)))
+ ))
+
+;; save BUFFER in FILE. used in hooks.
+(defun ediff-save-buffer-in-file (buffer file)
+ (ediff-with-current-buffer buffer
+ (write-file file)))
+
+
+;;; Debug
+
+(ediff-defvar-local ediff-command-begin-time '(0 0 0) "")
+
+;; calculate time used by command
+(defun ediff-calc-command-time ()
+ (let ((end (current-time))
+ micro sec)
+ (setq micro
+ (if (>= (nth 2 end) (nth 2 ediff-command-begin-time))
+ (- (nth 2 end) (nth 2 ediff-command-begin-time))
+ (+ (nth 2 end) (- 1000000 (nth 2 ediff-command-begin-time)))))
+ (setq sec (- (nth 1 end) (nth 1 ediff-command-begin-time)))
+ (or (equal ediff-command-begin-time '(0 0 0))
+ (message "Elapsed time: %d second(s) + %d microsecond(s)" sec micro))))
+
+(defsubst ediff-save-time ()
+ (setq ediff-command-begin-time (current-time)))
+
+(defun ediff-profile ()
+ "Toggle profiling Ediff commands."
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+
+ (if (featurep 'xemacs)
+ (make-local-hook 'post-command-hook))
+
+ (let ((pre-hook 'pre-command-hook)
+ (post-hook 'post-command-hook))
+ (if (not (equal ediff-command-begin-time '(0 0 0)))
+ (progn (remove-hook pre-hook 'ediff-save-time)
+ (remove-hook post-hook 'ediff-calc-command-time)
+ (setq ediff-command-begin-time '(0 0 0))
+ (message "Ediff profiling disabled"))
+ (add-hook pre-hook 'ediff-save-time t 'local)
+ (add-hook post-hook 'ediff-calc-command-time nil 'local)
+ (message "Ediff profiling enabled"))))
+
+(defun ediff-print-diff-vector (diff-vector-var)
+ (princ (format "\n*** %S ***\n" diff-vector-var))
+ (mapcar (lambda (overl-vec)
+ (princ
+ (format
+ "Diff %d: \tOverlay: %S
+\t\tFine diffs: %s
+\t\tNo-fine-diff-flag: %S
+\t\tState-of-diff:\t %S
+\t\tState-of-merge:\t %S
+"
+ (1+ (ediff-overlay-get (aref overl-vec 0) 'ediff-diff-num))
+ (aref overl-vec 0)
+ ;; fine-diff-vector
+ (if (= (length (aref overl-vec 1)) 0)
+ "none\n"
+ (mapconcat 'prin1-to-string
+ (aref overl-vec 1) "\n\t\t\t "))
+ (aref overl-vec 2) ; no fine diff flag
+ (aref overl-vec 3) ; state-of-diff
+ (aref overl-vec 4) ; state-of-merge
+ )))
+ (eval diff-vector-var)))
+
+
+
+(defun ediff-debug-info ()
+ (interactive)
+ (ediff-barf-if-not-control-buffer)
+ (with-output-to-temp-buffer ediff-debug-buffer
+ (ediff-with-current-buffer standard-output
+ (fundamental-mode))
+ (princ (format "\nCtl buffer: %S\n" ediff-control-buffer))
+ (ediff-print-diff-vector (intern "ediff-difference-vector-A"))
+ (ediff-print-diff-vector (intern "ediff-difference-vector-B"))
+ (ediff-print-diff-vector (intern "ediff-difference-vector-C"))
+ (ediff-print-diff-vector (intern "ediff-difference-vector-Ancestor"))
+ ))
+
+
+;;; General utilities
+
+;; this uses comparison-func to decide who is a member
+(defun ediff-member (elt lis comparison-func)
+ (while (and lis (not (funcall comparison-func (car lis) elt)))
+ (setq lis (cdr lis)))
+ lis)
+
+;; Make a readable representation of the invocation sequence for FUNC-DEF.
+;; It would either be a key or M-x something.
+(defun ediff-format-bindings-of (func-def)
+ (let ((desc (car (where-is-internal func-def
+ overriding-local-map
+ nil nil))))
+ (if desc
+ (key-description desc)
+ (format "M-x %s" func-def))))
+
+;; this uses comparison-func to decide who is a member, and this determines how
+;; intersection looks like
+(defun ediff-intersection (lis1 lis2 comparison-func)
+ (let ((result (list 'a)))
+ (while lis1
+ (if (ediff-member (car lis1) lis2 comparison-func)
+ (nconc result (list (car lis1))))
+ (setq lis1 (cdr lis1)))
+ (cdr result)))
+
+
+;; eliminates duplicates using comparison-func
+(defun ediff-union (lis1 lis2 comparison-func)
+ (let ((result (list 'a)))
+ (while lis1
+ (or (ediff-member (car lis1) (cdr result) comparison-func)
+ (nconc result (list (car lis1))))
+ (setq lis1 (cdr lis1)))
+ (while lis2
+ (or (ediff-member (car lis2) (cdr result) comparison-func)
+ (nconc result (list (car lis2))))
+ (setq lis2 (cdr lis2)))
+ (cdr result)))
+
+;; eliminates duplicates using comparison-func
+(defun ediff-set-difference (lis1 lis2 comparison-func)
+ (let ((result (list 'a)))
+ (while lis1
+ (or (ediff-member (car lis1) (cdr result) comparison-func)
+ (ediff-member (car lis1) lis2 comparison-func)
+ (nconc result (list (car lis1))))
+ (setq lis1 (cdr lis1)))
+ (cdr result)))
+
+(defun ediff-add-to-history (history-var newelt)
+ (if (fboundp 'add-to-history)
+ (add-to-history history-var newelt)
+ (set history-var (cons newelt (symbol-value history-var)))))
+
+(defalias 'ediff-copy-list 'copy-sequence)
+
+
+;; don't report error if version control package wasn't found
+;;(ediff-load-version-control 'silent)
+
+(run-hooks 'ediff-load-hook)
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: f51099b6-ef4b-470f-88a1-3a0e0b03a879
+;;; ediff-util.el ends here
--- /dev/null
+;;; ediff-vers.el --- version control interface to Ediff
+
+;; Copyright (C) 1995, 1996, 1997, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+;; Compiler pacifier
+(defvar rcs-default-co-switches)
+
+(and noninteractive
+ (eval-when-compile
+ (condition-case nil
+ ;; for compatibility with current stable version of xemacs
+ (progn
+ ;;(require 'pcvs nil 'noerror)
+ ;;(require 'rcs nil 'noerror)
+ (require 'pcvs)
+ (require 'rcs))
+ (error nil))
+ (require 'vc)
+ (require 'ediff-init)
+ ))
+;; end pacifier
+
+(defcustom ediff-keep-tmp-versions nil
+ "If t, do not delete temporary previous versions for the files on which
+comparison or merge operations are being performed."
+ :type 'boolean
+ :group 'ediff-vers
+ )
+
+(defalias 'ediff-vc-revision-other-window
+ (if (fboundp 'vc-revision-other-window)
+ 'vc-revision-other-window
+ 'vc-version-other-window))
+
+(defalias 'ediff-vc-working-revision
+ (if (fboundp 'vc-working-revision)
+ 'vc-working-revision
+ 'vc-workfile-version))
+
+;; VC.el support
+
+(eval-when-compile
+ (require 'vc-hooks)) ;; for vc-call macro
+
+
+(defun ediff-vc-latest-version (file)
+ "Return the version level of the latest version of FILE in repository."
+ (if (fboundp 'vc-latest-version)
+ (vc-latest-version file)
+ (or (vc-file-getprop file 'vc-latest-revision)
+ (cond ((vc-backend file)
+ (vc-call state file)
+ (vc-file-getprop file 'vc-latest-revision))
+ (t (error "File %s is not under version control" file))))
+ ))
+
+
+(defun ediff-vc-internal (rev1 rev2 &optional startup-hooks)
+ ;; Run Ediff on versions of the current buffer.
+ ;; If REV1 is "", use the latest version of the current buffer's file.
+ ;; If REV2 is "" then compare current buffer with REV1.
+ ;; If the current buffer is named `F', the version is named `F.~REV~'.
+ ;; If `F.~REV~' already exists, it is used instead of being re-created.
+ (let (file1 file2 rev1buf rev2buf)
+ (if (string= rev1 "")
+ (setq rev1 (ediff-vc-latest-version (buffer-file-name))))
+ (save-window-excursion
+ (save-excursion
+ (ediff-vc-revision-other-window rev1)
+ (setq rev1buf (current-buffer)
+ file1 (buffer-file-name)))
+ (save-excursion
+ (or (string= rev2 "") ; use current buffer
+ (ediff-vc-revision-other-window rev2))
+ (setq rev2buf (current-buffer)
+ file2 (buffer-file-name)))
+ (setq startup-hooks
+ (cons `(lambda ()
+ (ediff-delete-version-file ,file1)
+ (or ,(string= rev2 "") (ediff-delete-version-file ,file2)))
+ startup-hooks)))
+ (ediff-buffers
+ rev1buf rev2buf
+ startup-hooks
+ 'ediff-revision)))
+
+;; RCS.el support
+(defun rcs-ediff-view-revision (&optional rev)
+;; View previous RCS revision of current file.
+;; With prefix argument, prompts for a revision name.
+ (interactive (list (if current-prefix-arg
+ (read-string "Revision: "))))
+ (let* ((filename (buffer-file-name (current-buffer)))
+ (switches (append '("-p")
+ (if rev (list (concat "-r" rev)) nil)))
+ (buff (concat (file-name-nondirectory filename) ".~" rev "~")))
+ (message "Working ...")
+ (setq filename (expand-file-name filename))
+ (with-output-to-temp-buffer buff
+ (ediff-with-current-buffer standard-output
+ (fundamental-mode))
+ (let ((output-buffer (ediff-rcs-get-output-buffer filename buff)))
+ (delete-windows-on output-buffer)
+ (with-current-buffer output-buffer
+ (apply 'call-process "co" nil t nil
+ ;; -q: quiet (no diagnostics)
+ (append switches rcs-default-co-switches
+ (list "-q" filename)))))
+ (message "")
+ buff)))
+
+(defun ediff-rcs-get-output-buffer (file name)
+ ;; Get a buffer for RCS output for FILE, make it writable and clean it up.
+ ;; Optional NAME is name to use instead of `*RCS-output*'.
+ ;; This is a modified version from rcs.el v1.1. I use it here to make
+ ;; Ediff immune to changes in rcs.el
+ (let ((buf (get-buffer-create name)))
+ (with-current-buffer buf
+ (setq buffer-read-only nil
+ default-directory (file-name-directory (expand-file-name file)))
+ (erase-buffer))
+ buf))
+
+(defun ediff-rcs-internal (rev1 rev2 &optional startup-hooks)
+;; Run Ediff on versions of the current buffer.
+;; If REV2 is "" then use current buffer.
+ (let (rev2buf rev1buf)
+ (save-window-excursion
+ (setq rev2buf (if (string= rev2 "")
+ (current-buffer)
+ (rcs-ediff-view-revision rev2))
+ rev1buf (rcs-ediff-view-revision rev1)))
+
+ ;; rcs.el doesn't create temp version files, so we don't have to delete
+ ;; anything in startup hooks to ediff-buffers
+ (ediff-buffers rev1buf rev2buf startup-hooks 'ediff-revision)
+ ))
+
+;;; Merge with Version Control
+
+(defun ediff-vc-merge-internal (rev1 rev2 ancestor-rev
+ &optional startup-hooks merge-buffer-file)
+;; If ANCESTOR-REV non-nil, merge with ancestor
+ (let (buf1 buf2 ancestor-buf)
+ (save-window-excursion
+ (save-excursion
+ (ediff-vc-revision-other-window rev1)
+ (setq buf1 (current-buffer)))
+ (save-excursion
+ (or (string= rev2 "")
+ (ediff-vc-revision-other-window rev2))
+ (setq buf2 (current-buffer)))
+ (if ancestor-rev
+ (save-excursion
+ (if (string= ancestor-rev "")
+ (setq ancestor-rev (ediff-vc-working-revision buffer-file-name)))
+ (ediff-vc-revision-other-window ancestor-rev)
+ (setq ancestor-buf (current-buffer))))
+ (setq startup-hooks
+ (cons
+ `(lambda ()
+ (ediff-delete-version-file ,(buffer-file-name buf1))
+ (or ,(string= rev2 "")
+ (ediff-delete-version-file ,(buffer-file-name buf2)))
+ (or ,(string= ancestor-rev "")
+ ,(not ancestor-rev)
+ (ediff-delete-version-file ,(buffer-file-name ancestor-buf)))
+ )
+ startup-hooks)))
+ (if ancestor-rev
+ (ediff-merge-buffers-with-ancestor
+ buf1 buf2 ancestor-buf
+ startup-hooks 'ediff-merge-revisions-with-ancestor merge-buffer-file)
+ (ediff-merge-buffers
+ buf1 buf2 startup-hooks 'ediff-merge-revisions merge-buffer-file))
+ ))
+
+(defun ediff-rcs-merge-internal (rev1 rev2 ancestor-rev
+ &optional
+ startup-hooks merge-buffer-file)
+ ;; If ANCESTOR-REV non-nil, merge with ancestor
+ (let (buf1 buf2 ancestor-buf)
+ (save-window-excursion
+ (setq buf1 (rcs-ediff-view-revision rev1)
+ buf2 (if (string= rev2 "")
+ (current-buffer)
+ (rcs-ediff-view-revision rev2))
+ ancestor-buf (if ancestor-rev
+ (if (string= ancestor-rev "")
+ (current-buffer)
+ (rcs-ediff-view-revision ancestor-rev)))))
+ ;; rcs.el doesn't create temp version files, so we don't have to delete
+ ;; anything in startup hooks to ediff-buffers
+ (if ancestor-rev
+ (ediff-merge-buffers-with-ancestor
+ buf1 buf2 ancestor-buf
+ startup-hooks 'ediff-merge-revisions-with-ancestor merge-buffer-file)
+ (ediff-merge-buffers
+ buf1 buf2 startup-hooks 'ediff-merge-revisions merge-buffer-file))))
+
+
+;; delete version file on exit unless ediff-keep-tmp-versions is true
+(defun ediff-delete-version-file (file)
+ (or ediff-keep-tmp-versions (delete-file file)))
+
+
+(provide 'ediff-vers)
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: bbb34f0c-2a90-426a-a77a-c75f479ebbbf
+;;; ediff-vers.el ends here
--- /dev/null
+;;; ediff-wind.el --- window manipulation utilities
+
+;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+
+;; Compiler pacifier
+(defvar icon-title-format)
+(defvar top-toolbar-height)
+(defvar bottom-toolbar-height)
+(defvar left-toolbar-height)
+(defvar right-toolbar-height)
+(defvar left-toolbar-width)
+(defvar right-toolbar-width)
+(defvar default-menubar)
+(defvar top-gutter)
+(defvar frame-icon-title-format)
+(defvar ediff-diff-status)
+
+;; declare-function does not exist in XEmacs
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
+(eval-when-compile
+ (require 'ediff-util)
+ (require 'ediff-help))
+;; end pacifier
+
+(require 'ediff-init)
+
+;; be careful with ediff-tbar
+(if (featurep 'xemacs)
+ (require 'ediff-tbar)
+ (defun ediff-compute-toolbar-width () 0))
+
+(defgroup ediff-window nil
+ "Ediff window manipulation."
+ :prefix "ediff-"
+ :group 'ediff
+ :group 'frames)
+
+
+;; Determine which window setup function to use based on current window system.
+(defun ediff-choose-window-setup-function-automatically ()
+ (if (ediff-window-display-p)
+ 'ediff-setup-windows-multiframe
+ 'ediff-setup-windows-plain))
+
+(defcustom ediff-window-setup-function (ediff-choose-window-setup-function-automatically)
+ "Function called to set up windows.
+Ediff provides a choice of two functions: `ediff-setup-windows-plain', for
+doing everything in one frame and `ediff-setup-windows-multiframe', which sets
+the control panel in a separate frame. By default, the appropriate function is
+chosen automatically depending on the current window system.
+However, `ediff-toggle-multiframe' can be used to toggle between the multiframe
+display and the single frame display.
+If the multiframe function detects that one of the buffers A/B is seen in some
+other frame, it will try to keep that buffer in that frame.
+
+If you don't like any of the two provided functions, write your own one.
+The basic guidelines:
+ 1. It should leave the control buffer current and the control window
+ selected.
+ 2. It should set `ediff-window-A', `ediff-window-B', `ediff-window-C',
+ and `ediff-control-window' to contain window objects that display
+ the corresponding buffers.
+ 3. It should accept the following arguments:
+ buffer-A, buffer-B, buffer-C, control-buffer
+ Buffer C may not be used in jobs that compare only two buffers.
+If you plan to do something fancy, take a close look at how the two
+provided functions are written."
+ :type '(choice (const :tag "Multi Frame" ediff-setup-windows-multiframe)
+ (const :tag "Single Frame" ediff-setup-windows-plain)
+ (function :tag "Other function"))
+ :group 'ediff-window)
+
+;; indicates if we are in a multiframe setup
+(ediff-defvar-local ediff-multiframe nil "")
+
+;; Share of the frame occupied by the merge window (buffer C)
+(ediff-defvar-local ediff-merge-window-share 0.45 "")
+
+;; The control window.
+(ediff-defvar-local ediff-control-window nil "")
+;; Official window for buffer A
+(ediff-defvar-local ediff-window-A nil "")
+;; Official window for buffer B
+(ediff-defvar-local ediff-window-B nil "")
+;; Official window for buffer C
+(ediff-defvar-local ediff-window-C nil "")
+;; Ediff's window configuration.
+;; Used to minimize the need to rearrange windows.
+(ediff-defvar-local ediff-window-config-saved "" "")
+
+;; Association between buff-type and ediff-window-*
+(defconst ediff-window-alist
+ '((A . ediff-window-A)
+ (?A . ediff-window-A)
+ (B . ediff-window-B)
+ (?B . ediff-window-B)
+ (C . ediff-window-C)
+ (?C . ediff-window-C)))
+
+
+(defcustom ediff-split-window-function 'split-window-vertically
+ "The function used to split the main window between buffer-A and buffer-B.
+You can set it to a horizontal split instead of the default vertical split
+by setting this variable to `split-window-horizontally'.
+You can also have your own function to do fancy splits.
+This variable has no effect when buffer-A/B are shown in different frames.
+In this case, Ediff will use those frames to display these buffers."
+ :type '(choice
+ (const :tag "Split vertically" split-window-vertically)
+ (const :tag "Split horizontally" split-window-horizontally)
+ function)
+ :group 'ediff-window)
+
+(defcustom ediff-merge-split-window-function 'split-window-horizontally
+ "The function used to split the main window between buffer-A and buffer-B.
+You can set it to a vertical split instead of the default horizontal split
+by setting this variable to `split-window-vertically'.
+You can also have your own function to do fancy splits.
+This variable has no effect when buffer-A/B/C are shown in different frames.
+In this case, Ediff will use those frames to display these buffers."
+ :type '(choice
+ (const :tag "Split vertically" split-window-vertically)
+ (const :tag "Split horizontally" split-window-horizontally)
+ function)
+ :group 'ediff-window)
+
+;; Definitions hidden from the compiler by compat wrappers.
+(declare-function ediff-display-pixel-width "ediff-init")
+(declare-function ediff-display-pixel-height "ediff-init")
+
+(defconst ediff-control-frame-parameters
+ (list
+ '(name . "Ediff")
+ ;;'(unsplittable . t)
+ '(minibuffer . nil)
+ '(user-position . t) ; Emacs only
+ '(vertical-scroll-bars . nil) ; Emacs only
+ '(scrollbar-width . 0) ; XEmacs only
+ '(scrollbar-height . 0) ; XEmacs only
+ '(menu-bar-lines . 0) ; Emacs only
+ '(tool-bar-lines . 0) ; Emacs 21+ only
+ '(left-fringe . 0)
+ '(right-fringe . 0)
+ ;; don't lower but auto-raise
+ '(auto-lower . nil)
+ '(auto-raise . t)
+ '(visibility . nil)
+ ;; make initial frame small to avoid distraction
+ '(width . 1) '(height . 1)
+ ;; this blocks queries from window manager as to where to put
+ ;; ediff's control frame. we put the frame outside the display,
+ ;; so the initial frame won't jump all over the screen
+ (cons 'top (if (fboundp 'ediff-display-pixel-height)
+ (1+ (ediff-display-pixel-height))
+ 3000))
+ (cons 'left (if (fboundp 'ediff-display-pixel-width)
+ (1+ (ediff-display-pixel-width))
+ 3000))
+ )
+ "Frame parameters for displaying Ediff Control Panel.
+Used internally---not a user option.")
+
+;; position of the mouse; used to decide whether to warp the mouse into ctl
+;; frame
+(ediff-defvar-local ediff-mouse-pixel-position nil "")
+
+;; not used for now
+(defvar ediff-mouse-pixel-threshold 30
+ "If the user moves mouse more than this many pixels, Ediff won't warp mouse into control window.")
+
+(defcustom ediff-grab-mouse t
+ "If t, Ediff will always grab the mouse and put it in the control frame.
+If 'maybe, Ediff will do it sometimes, but not after operations that require
+relatively long time. If nil, the mouse will be entirely user's
+responsibility."
+ :type 'boolean
+ :group 'ediff-window)
+
+(defcustom ediff-control-frame-position-function 'ediff-make-frame-position
+ "Function to call to determine the desired location for the control panel.
+Expects three parameters: the control buffer, the desired width and height
+of the control frame. It returns an association list
+of the form \(\(top . <position>\) \(left . <position>\)\)"
+ :type 'function
+ :group 'ediff-window)
+
+(defcustom ediff-control-frame-upward-shift 42
+ "The upward shift of control frame from the top of buffer A's frame.
+Measured in pixels.
+This is used by the default control frame positioning function,
+`ediff-make-frame-position'. This variable is provided for easy
+customization of the default control frame positioning."
+ :type 'integer
+ :group 'ediff-window)
+
+(defcustom ediff-narrow-control-frame-leftward-shift (if (featurep 'xemacs) 7 3)
+ "The leftward shift of control frame from the right edge of buf A's frame.
+Measured in characters.
+This is used by the default control frame positioning function,
+`ediff-make-frame-position' to adjust the position of the control frame
+when it shows the short menu. This variable is provided for easy
+customization of the default."
+ :type 'integer
+ :group 'ediff-window)
+
+(defcustom ediff-wide-control-frame-rightward-shift 7
+ "The rightward shift of control frame from the left edge of buf A's frame.
+Measured in characters.
+This is used by the default control frame positioning function,
+`ediff-make-frame-position' to adjust the position of the control frame
+when it shows the full menu. This variable is provided for easy
+customization of the default."
+ :type 'integer
+ :group 'ediff-window)
+
+
+;; Wide frame display
+
+;; t means Ediff is using wide display
+(ediff-defvar-local ediff-wide-display-p nil "")
+;; keeps frame config for toggling wide display
+(ediff-defvar-local ediff-wide-display-orig-parameters nil
+ "Frame parameters to be restored when the user wants to toggle the wide
+display off.")
+(ediff-defvar-local ediff-wide-display-frame nil
+ "Frame to be used for wide display.")
+(ediff-defvar-local ediff-make-wide-display-function 'ediff-make-wide-display
+ "The value is a function that is called to create a wide display.
+The function is called without arguments. It should resize the frame in
+which buffers A, B, and C are to be displayed, and it should save the old
+frame parameters in `ediff-wide-display-orig-parameters'.
+The variable `ediff-wide-display-frame' should be set to contain
+the frame used for the wide display.")
+
+;; Frame used for the control panel in a windowing system.
+(ediff-defvar-local ediff-control-frame nil "")
+
+(defcustom ediff-prefer-iconified-control-frame nil
+ "If t, keep control panel iconified when help message is off.
+This has effect only on a windowing system.
+If t, hitting `?' to toggle control panel off iconifies it.
+
+This is only useful in Emacs and only for certain kinds of window managers,
+such as TWM and its derivatives, since the window manager must permit
+keyboard input to go into icons. XEmacs completely ignores keyboard input
+into icons, regardless of the window manager."
+ :type 'boolean
+ :group 'ediff-window)
+
+;;; Functions
+
+(defun ediff-get-window-by-clicking (wind prev-wind wind-number)
+ (let (event)
+ (message
+ "Select windows by clicking. Please click on Window %d " wind-number)
+ (while (not (ediff-mouse-event-p (setq event (ediff-read-event))))
+ (if (sit-for 1) ; if sequence of events, wait till the final word
+ (beep 1))
+ (message "Please click on Window %d " wind-number))
+ (ediff-read-event) ; discard event
+ (setq wind (if (featurep 'xemacs)
+ (event-window event)
+ (posn-window (event-start event))))))
+
+
+;; Select the lowest window on the frame.
+(defun ediff-select-lowest-window ()
+ (if (featurep 'xemacs)
+ (select-window (frame-lowest-window))
+ (let* ((lowest-window (selected-window))
+ (bottom-edge (car (cdr (cdr (cdr (window-edges))))))
+ (last-window (save-excursion
+ (other-window -1) (selected-window)))
+ (window-search t))
+ (while window-search
+ (let* ((this-window (next-window))
+ (next-bottom-edge
+ (car (cdr (cdr (cdr (window-edges this-window)))))))
+ (if (< bottom-edge next-bottom-edge)
+ (setq bottom-edge next-bottom-edge
+ lowest-window this-window))
+ (select-window this-window)
+ (when (eq last-window this-window)
+ (select-window lowest-window)
+ (setq window-search nil)))))))
+
+
+;;; Common window setup routines
+
+;; Set up the window configuration. If POS is given, set the points to
+;; the beginnings of the buffers.
+;; When 3way comparison is added, this will have to choose the appropriate
+;; setup function based on ediff-job-name
+(defun ediff-setup-windows (buffer-A buffer-B buffer-C control-buffer)
+ ;; Make sure we are not in the minibuffer window when we try to delete
+ ;; all other windows.
+ (run-hooks 'ediff-before-setup-windows-hook)
+ (if (eq (selected-window) (minibuffer-window))
+ (other-window 1))
+
+ ;; in case user did a no-no on a tty
+ (or (ediff-window-display-p)
+ (setq ediff-window-setup-function 'ediff-setup-windows-plain))
+
+ (or (ediff-keep-window-config control-buffer)
+ (funcall
+ (ediff-with-current-buffer control-buffer ediff-window-setup-function)
+ buffer-A buffer-B buffer-C control-buffer))
+ (run-hooks 'ediff-after-setup-windows-hook))
+
+;; Just set up 3 windows.
+;; Usually used without windowing systems
+;; With windowing, we want to use dedicated frames.
+(defun ediff-setup-windows-plain (buffer-A buffer-B buffer-C control-buffer)
+ (ediff-with-current-buffer control-buffer
+ (setq ediff-multiframe nil))
+ (if ediff-merge-job
+ (ediff-setup-windows-plain-merge
+ buffer-A buffer-B buffer-C control-buffer)
+ (ediff-setup-windows-plain-compare
+ buffer-A buffer-B buffer-C control-buffer)))
+
+(defun ediff-setup-windows-plain-merge (buf-A buf-B buf-C control-buffer)
+ ;; skip dedicated and unsplittable frames
+ (ediff-destroy-control-frame control-buffer)
+ (let ((window-min-height 1)
+ split-window-function
+ merge-window-share merge-window-lines
+ wind-A wind-B wind-C)
+ (ediff-with-current-buffer control-buffer
+ (setq merge-window-share ediff-merge-window-share
+ ;; this lets us have local versions of ediff-split-window-function
+ split-window-function ediff-split-window-function))
+ (delete-other-windows)
+ (set-window-dedicated-p (selected-window) nil)
+ (split-window-vertically)
+ (ediff-select-lowest-window)
+ (ediff-setup-control-buffer control-buffer)
+
+ ;; go to the upper window and split it betw A, B, and possibly C
+ (other-window 1)
+ (setq merge-window-lines
+ (max 2 (round (* (window-height) merge-window-share))))
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+
+ ;; XEmacs used to have a lot of trouble with display
+ ;; It did't set things right unless we tell it to sit still
+ ;; 19.12 seems ok.
+ ;;(if (featurep 'xemacs) (sit-for 0))
+
+ (split-window-vertically (max 2 (- (window-height) merge-window-lines)))
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (setq wind-C (selected-window))
+ (switch-to-buffer buf-C)
+
+ (select-window wind-A)
+ (funcall split-window-function)
+
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+
+ (ediff-with-current-buffer control-buffer
+ (setq ediff-window-A wind-A
+ ediff-window-B wind-B
+ ediff-window-C wind-C))
+
+ (ediff-select-lowest-window)
+ (ediff-setup-control-buffer control-buffer)
+ ))
+
+
+;; This function handles all comparison jobs, including 3way jobs
+(defun ediff-setup-windows-plain-compare (buf-A buf-B buf-C control-buffer)
+ ;; skip dedicated and unsplittable frames
+ (ediff-destroy-control-frame control-buffer)
+ (let ((window-min-height 1)
+ split-window-function wind-width-or-height
+ three-way-comparison
+ wind-A-start wind-B-start wind-A wind-B wind-C)
+ (ediff-with-current-buffer control-buffer
+ (setq wind-A-start (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'A ediff-narrow-bounds))
+ wind-B-start (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'B ediff-narrow-bounds))
+ ;; this lets us have local versions of ediff-split-window-function
+ split-window-function ediff-split-window-function
+ three-way-comparison ediff-3way-comparison-job))
+ ;; if in minibuffer go somewhere else
+ (if (save-match-data
+ (string-match "\*Minibuf-" (buffer-name (window-buffer))))
+ (select-window (next-window nil 'ignore-minibuf)))
+ (delete-other-windows)
+ (set-window-dedicated-p (selected-window) nil)
+ (split-window-vertically)
+ (ediff-select-lowest-window)
+ (ediff-setup-control-buffer control-buffer)
+
+ ;; go to the upper window and split it betw A, B, and possibly C
+ (other-window 1)
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+ (if three-way-comparison
+ (setq wind-width-or-height
+ (/ (if (eq split-window-function 'split-window-vertically)
+ (window-height wind-A)
+ (window-width wind-A))
+ 3)))
+
+ ;; XEmacs used to have a lot of trouble with display
+ ;; It did't set things right unless we told it to sit still
+ ;; 19.12 seems ok.
+ ;;(if (featurep 'xemacs) (sit-for 0))
+
+ (funcall split-window-function wind-width-or-height)
+
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+
+ (if three-way-comparison
+ (progn
+ (funcall split-window-function) ; equally
+ (if (eq (selected-window) wind-B)
+ (other-window 1))
+ (switch-to-buffer buf-C)
+ (setq wind-C (selected-window))))
+
+ (ediff-with-current-buffer control-buffer
+ (setq ediff-window-A wind-A
+ ediff-window-B wind-B
+ ediff-window-C wind-C))
+
+ ;; It is unlikely that we will want to implement 3way window comparison.
+ ;; So, only buffers A and B are used here.
+ (if ediff-windows-job
+ (progn
+ (set-window-start wind-A wind-A-start)
+ (set-window-start wind-B wind-B-start)))
+
+ (ediff-select-lowest-window)
+ (ediff-setup-control-buffer control-buffer)
+ ))
+
+
+;; dispatch an appropriate window setup function
+(defun ediff-setup-windows-multiframe (buf-A buf-B buf-C control-buf)
+ (ediff-with-current-buffer control-buf
+ (setq ediff-multiframe t))
+ (if ediff-merge-job
+ (ediff-setup-windows-multiframe-merge buf-A buf-B buf-C control-buf)
+ (ediff-setup-windows-multiframe-compare buf-A buf-B buf-C control-buf)))
+
+(defun ediff-setup-windows-multiframe-merge (buf-A buf-B buf-C control-buf)
+;;; Algorithm:
+;;; 1. Never use frames that have dedicated windows in them---it is bad to
+;;; destroy dedicated windows.
+;;; 2. If A and B are in the same frame but C's frame is different--- use one
+;;; frame for A and B and use a separate frame for C.
+;;; 3. If C's frame is non-existent, then: if the first suitable
+;;; non-dedicated frame is different from A&B's, then use it for C.
+;;; Otherwise, put A,B, and C in one frame.
+;;; 4. If buffers A, B, C are is separate frames, use them to display these
+;;; buffers.
+
+ ;; Skip dedicated or iconified frames.
+ ;; Unsplittable frames are taken care of later.
+ (ediff-skip-unsuitable-frames 'ok-unsplittable)
+
+ (let* ((window-min-height 1)
+ (wind-A (ediff-get-visible-buffer-window buf-A))
+ (wind-B (ediff-get-visible-buffer-window buf-B))
+ (wind-C (ediff-get-visible-buffer-window buf-C))
+ (frame-A (if wind-A (window-frame wind-A)))
+ (frame-B (if wind-B (window-frame wind-B)))
+ (frame-C (if wind-C (window-frame wind-C)))
+ ;; on wide display, do things in one frame
+ (force-one-frame
+ (ediff-with-current-buffer control-buf ediff-wide-display-p))
+ ;; this lets us have local versions of ediff-split-window-function
+ (split-window-function
+ (ediff-with-current-buffer control-buf ediff-split-window-function))
+ (orig-wind (selected-window))
+ (orig-frame (selected-frame))
+ (use-same-frame (or force-one-frame
+ ;; A and C must be in one frame
+ (eq frame-A (or frame-C orig-frame))
+ ;; B and C must be in one frame
+ (eq frame-B (or frame-C orig-frame))
+ ;; A or B is not visible
+ (not (frame-live-p frame-A))
+ (not (frame-live-p frame-B))
+ ;; A or B is not suitable for display
+ (not (ediff-window-ok-for-display wind-A))
+ (not (ediff-window-ok-for-display wind-B))
+ ;; A and B in the same frame, and no good frame
+ ;; for C
+ (and (eq frame-A frame-B)
+ (not (frame-live-p frame-C)))
+ ))
+ ;; use-same-frame-for-AB implies wind A and B are ok for display
+ (use-same-frame-for-AB (and (not use-same-frame)
+ (eq frame-A frame-B)))
+ (merge-window-share (ediff-with-current-buffer control-buf
+ ediff-merge-window-share))
+ merge-window-lines
+ designated-minibuffer-frame
+ done-A done-B done-C)
+
+ ;; buf-A on its own
+ (if (and (window-live-p wind-A)
+ (null use-same-frame) ; implies wind-A is suitable
+ (null use-same-frame-for-AB))
+ (progn ; bug A on its own
+ ;; buffer buf-A is seen in live wind-A
+ (select-window wind-A)
+ (delete-other-windows)
+ (setq wind-A (selected-window))
+ (setq done-A t)))
+
+ ;; buf-B on its own
+ (if (and (window-live-p wind-B)
+ (null use-same-frame) ; implies wind-B is suitable
+ (null use-same-frame-for-AB))
+ (progn ; buf B on its own
+ ;; buffer buf-B is seen in live wind-B
+ (select-window wind-B)
+ (delete-other-windows)
+ (setq wind-B (selected-window))
+ (setq done-B t)))
+
+ ;; buf-C on its own
+ (if (and (window-live-p wind-C)
+ (ediff-window-ok-for-display wind-C)
+ (null use-same-frame)) ; buf C on its own
+ (progn
+ ;; buffer buf-C is seen in live wind-C
+ (select-window wind-C)
+ (delete-other-windows)
+ (setq wind-C (selected-window))
+ (setq done-C t)))
+
+ (if (and use-same-frame-for-AB ; implies wind A and B are suitable
+ (window-live-p wind-A))
+ (progn
+ ;; wind-A must already be displaying buf-A
+ (select-window wind-A)
+ (delete-other-windows)
+ (setq wind-A (selected-window))
+
+ (funcall split-window-function)
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+
+ (setq done-A t
+ done-B t)))
+
+ (if use-same-frame
+ (let ((window-min-height 1))
+ (if (and (eq frame-A frame-B)
+ (eq frame-B frame-C)
+ (frame-live-p frame-A))
+ (select-frame frame-A)
+ ;; avoid dedicated and non-splittable windows
+ (ediff-skip-unsuitable-frames))
+ (delete-other-windows)
+ (setq merge-window-lines
+ (max 2 (round (* (window-height) merge-window-share))))
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+
+ (split-window-vertically
+ (max 2 (- (window-height) merge-window-lines)))
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (setq wind-C (selected-window))
+ (switch-to-buffer buf-C)
+
+ (select-window wind-A)
+
+ (funcall split-window-function)
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+
+ (setq done-A t
+ done-B t
+ done-C t)
+ ))
+
+ (or done-A ; Buf A to be set in its own frame,
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-A was not set up yet as it wasn't visible,
+ ;; and use-same-frame = nil, use-same-frame-for-AB = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+ ))
+ (or done-B ; Buf B to be set in its own frame,
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-B was not set up yet as it wasn't visible
+ ;; and use-same-frame = nil, use-same-frame-for-AB = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+ ))
+
+ (or done-C ; Buf C to be set in its own frame,
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-C was not set up yet as it wasn't visible
+ ;; and use-same-frame = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-C)
+ (setq wind-C (selected-window))
+ ))
+
+ (ediff-with-current-buffer control-buf
+ (setq ediff-window-A wind-A
+ ediff-window-B wind-B
+ ediff-window-C wind-C)
+ (setq frame-A (window-frame ediff-window-A)
+ designated-minibuffer-frame
+ (window-frame (minibuffer-window frame-A))))
+
+ (ediff-setup-control-frame control-buf designated-minibuffer-frame)
+ ))
+
+
+;; Window setup for all comparison jobs, including 3way comparisons
+(defun ediff-setup-windows-multiframe-compare (buf-A buf-B buf-C control-buf)
+;;; Algorithm:
+;;; If a buffer is seen in a frame, use that frame for that buffer.
+;;; If it is not seen, use the current frame.
+;;; If both buffers are not seen, they share the current frame. If one
+;;; of the buffers is not seen, it is placed in the current frame (where
+;;; ediff started). If that frame is displaying the other buffer, it is
+;;; shared between the two buffers.
+;;; However, if we decide to put both buffers in one frame
+;;; and the selected frame isn't splittable, we create a new frame and
+;;; put both buffers there, event if one of this buffers is visible in
+;;; another frame.
+
+ ;; Skip dedicated or iconified frames.
+ ;; Unsplittable frames are taken care of later.
+ (ediff-skip-unsuitable-frames 'ok-unsplittable)
+
+ (let* ((window-min-height 1)
+ (wind-A (ediff-get-visible-buffer-window buf-A))
+ (wind-B (ediff-get-visible-buffer-window buf-B))
+ (wind-C (ediff-get-visible-buffer-window buf-C))
+ (frame-A (if wind-A (window-frame wind-A)))
+ (frame-B (if wind-B (window-frame wind-B)))
+ (frame-C (if wind-C (window-frame wind-C)))
+ (ctl-frame-exists-p (ediff-with-current-buffer control-buf
+ (frame-live-p ediff-control-frame)))
+ ;; on wide display, do things in one frame
+ (force-one-frame
+ (ediff-with-current-buffer control-buf ediff-wide-display-p))
+ ;; this lets us have local versions of ediff-split-window-function
+ (split-window-function
+ (ediff-with-current-buffer control-buf ediff-split-window-function))
+ (three-way-comparison
+ (ediff-with-current-buffer control-buf ediff-3way-comparison-job))
+ (orig-wind (selected-window))
+ (use-same-frame (or force-one-frame
+ (eq frame-A frame-B)
+ (not (ediff-window-ok-for-display wind-A))
+ (not (ediff-window-ok-for-display wind-B))
+ (if three-way-comparison
+ (or (eq frame-A frame-C)
+ (eq frame-B frame-C)
+ (not (ediff-window-ok-for-display wind-C))
+ (not (frame-live-p frame-A))
+ (not (frame-live-p frame-B))
+ (not (frame-live-p frame-C))))
+ (and (not (frame-live-p frame-B))
+ (or ctl-frame-exists-p
+ (eq frame-A (selected-frame))))
+ (and (not (frame-live-p frame-A))
+ (or ctl-frame-exists-p
+ (eq frame-B (selected-frame))))))
+ wind-A-start wind-B-start
+ designated-minibuffer-frame
+ done-A done-B done-C)
+
+ (ediff-with-current-buffer control-buf
+ (setq wind-A-start (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'A ediff-narrow-bounds))
+ wind-B-start (ediff-overlay-start
+ (ediff-get-value-according-to-buffer-type
+ 'B ediff-narrow-bounds))))
+
+ (if (and (window-live-p wind-A) (null use-same-frame)) ; buf-A on its own
+ (progn
+ ;; buffer buf-A is seen in live wind-A
+ (select-window wind-A) ; must be displaying buf-A
+ (delete-other-windows)
+ (setq wind-A (selected-window))
+ (setq done-A t)))
+
+ (if (and (window-live-p wind-B) (null use-same-frame)) ; buf B on its own
+ (progn
+ ;; buffer buf-B is seen in live wind-B
+ (select-window wind-B) ; must be displaying buf-B
+ (delete-other-windows)
+ (setq wind-B (selected-window))
+ (setq done-B t)))
+
+ (if (and (window-live-p wind-C) (null use-same-frame)) ; buf C on its own
+ (progn
+ ;; buffer buf-C is seen in live wind-C
+ (select-window wind-C) ; must be displaying buf-C
+ (delete-other-windows)
+ (setq wind-C (selected-window))
+ (setq done-C t)))
+
+ (if use-same-frame
+ (let (wind-width-or-height) ; this affects 3way setups only
+ (if (and (eq frame-A frame-B) (frame-live-p frame-A))
+ (select-frame frame-A)
+ ;; avoid dedicated and non-splittable windows
+ (ediff-skip-unsuitable-frames))
+ (delete-other-windows)
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+
+ (if three-way-comparison
+ (setq wind-width-or-height
+ (/
+ (if (eq split-window-function 'split-window-vertically)
+ (window-height wind-A)
+ (window-width wind-A))
+ 3)))
+
+ (funcall split-window-function wind-width-or-height)
+ (if (eq (selected-window) wind-A)
+ (other-window 1))
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+
+ (if three-way-comparison
+ (progn
+ (funcall split-window-function) ; equally
+ (if (memq (selected-window) (list wind-A wind-B))
+ (other-window 1))
+ (switch-to-buffer buf-C)
+ (setq wind-C (selected-window))))
+ (setq done-A t
+ done-B t
+ done-C t)
+ ))
+
+ (or done-A ; Buf A to be set in its own frame
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-A was not set up yet as it wasn't visible,
+ ;; and use-same-frame = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-A)
+ (setq wind-A (selected-window))
+ ))
+ (or done-B ; Buf B to be set in its own frame
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-B was not set up yet as it wasn't visible,
+ ;; and use-same-frame = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-B)
+ (setq wind-B (selected-window))
+ ))
+
+ (if three-way-comparison
+ (or done-C ; Buf C to be set in its own frame
+ ;;; or it was set before because use-same-frame = 1
+ (progn
+ ;; Buf-C was not set up yet as it wasn't visible,
+ ;; and use-same-frame = nil
+ (select-window orig-wind)
+ (delete-other-windows)
+ (switch-to-buffer buf-C)
+ (setq wind-C (selected-window))
+ )))
+
+ (ediff-with-current-buffer control-buf
+ (setq ediff-window-A wind-A
+ ediff-window-B wind-B
+ ediff-window-C wind-C)
+
+ (setq frame-A (window-frame ediff-window-A)
+ designated-minibuffer-frame
+ (window-frame (minibuffer-window frame-A))))
+
+ ;; It is unlikely that we'll implement a version of ediff-windows that
+ ;; would compare 3 windows at once. So, we don't use buffer C here.
+ (if ediff-windows-job
+ (progn
+ (set-window-start wind-A wind-A-start)
+ (set-window-start wind-B wind-B-start)))
+
+ (ediff-setup-control-frame control-buf designated-minibuffer-frame)
+ ))
+
+;; skip unsplittable frames and frames that have dedicated windows.
+;; create a new splittable frame if none is found
+(defun ediff-skip-unsuitable-frames (&optional ok-unsplittable)
+ (if (ediff-window-display-p)
+ (let ((wind-frame (window-frame (selected-window)))
+ seen-windows)
+ (while (and (not (memq (selected-window) seen-windows))
+ (or
+ (ediff-frame-has-dedicated-windows wind-frame)
+ (ediff-frame-iconified-p wind-frame)
+ ;; skip small windows
+ (< (frame-height wind-frame)
+ (* 3 window-min-height))
+ (if ok-unsplittable
+ nil
+ (ediff-frame-unsplittable-p wind-frame))))
+ ;; remember history
+ (setq seen-windows (cons (selected-window) seen-windows))
+ ;; try new window
+ (other-window 1 t)
+ (setq wind-frame (window-frame (selected-window)))
+ )
+ (if (memq (selected-window) seen-windows)
+ ;; fed up, no appropriate frames
+ (setq wind-frame (make-frame '((unsplittable)))))
+
+ (select-frame wind-frame)
+ )))
+
+(defun ediff-frame-has-dedicated-windows (frame)
+ (let (ans)
+ (walk-windows
+ (lambda (wind) (if (window-dedicated-p wind)
+ (setq ans t)))
+ 'ignore-minibuffer
+ frame)
+ ans))
+
+;; window is ok, if it is only one window on the frame, not counting the
+;; minibuffer, or none of the frame's windows is dedicated.
+;; The idea is that it is bad to destroy dedicated windows while creating an
+;; ediff window setup
+(defun ediff-window-ok-for-display (wind)
+ (and
+ (window-live-p wind)
+ (or
+ ;; only one window
+ (eq wind (next-window wind 'ignore-minibuffer (window-frame wind)))
+ ;; none is dedicated (in multiframe setup)
+ (not (ediff-frame-has-dedicated-windows (window-frame wind)))
+ )))
+
+;; Prepare or refresh control frame
+(defun ediff-setup-control-frame (ctl-buffer designated-minibuffer-frame)
+ (let ((window-min-height 1)
+ ctl-frame-iconified-p dont-iconify-ctl-frame deiconify-ctl-frame
+ ctl-frame old-ctl-frame lines
+ ;; user-grabbed-mouse
+ fheight fwidth adjusted-parameters)
+
+ (ediff-with-current-buffer ctl-buffer
+ (if (and (featurep 'xemacs) (featurep 'menubar))
+ (set-buffer-menubar nil))
+ ;;(setq user-grabbed-mouse (ediff-user-grabbed-mouse))
+ (run-hooks 'ediff-before-setup-control-frame-hook))
+
+ (setq old-ctl-frame (ediff-with-current-buffer ctl-buffer ediff-control-frame))
+ (ediff-with-current-buffer ctl-buffer
+ (setq ctl-frame (if (frame-live-p old-ctl-frame)
+ old-ctl-frame
+ (make-frame ediff-control-frame-parameters))
+ ediff-control-frame ctl-frame)
+ ;; protect against undefined face-attribute
+ (condition-case nil
+ (if (and (featurep 'emacs) (face-attribute 'mode-line :box))
+ (set-face-attribute 'mode-line ctl-frame :box nil))
+ (error)))
+
+ (setq ctl-frame-iconified-p (ediff-frame-iconified-p ctl-frame))
+ (select-frame ctl-frame)
+ (if (window-dedicated-p (selected-window))
+ ()
+ (delete-other-windows)
+ (switch-to-buffer ctl-buffer))
+
+ ;; must be before ediff-setup-control-buffer
+ ;; just a precaution--we should be in ctl-buffer already
+ (ediff-with-current-buffer ctl-buffer
+ (make-local-variable 'frame-title-format)
+ (make-local-variable 'frame-icon-title-format) ; XEmacs
+ (make-local-variable 'icon-title-format)) ; Emacs
+
+ (ediff-setup-control-buffer ctl-buffer)
+ (setq dont-iconify-ctl-frame
+ (not (string= ediff-help-message ediff-brief-help-message)))
+ (setq deiconify-ctl-frame
+ (and (eq this-command 'ediff-toggle-help)
+ dont-iconify-ctl-frame))
+
+ ;; 1 more line for the modeline
+ (setq lines (1+ (count-lines (point-min) (point-max)))
+ fheight lines
+ fwidth (max (+ (ediff-help-message-line-length) 2)
+ (ediff-compute-toolbar-width))
+ adjusted-parameters
+ (list
+ ;; possibly change surrogate minibuffer
+ (cons 'minibuffer
+ (minibuffer-window
+ designated-minibuffer-frame))
+ (cons 'width fwidth)
+ (cons 'height fheight)
+ (cons 'user-position t)
+ ))
+
+ ;; adjust autoraise
+ (setq adjusted-parameters
+ (cons (if ediff-use-long-help-message
+ '(auto-raise . nil)
+ '(auto-raise . t))
+ adjusted-parameters))
+
+ ;; In XEmacs, buffer menubar needs to be killed before frame parameters
+ ;; are changed.
+ (if (ediff-has-toolbar-support-p)
+ (when (featurep 'xemacs)
+ (if (ediff-has-gutter-support-p)
+ (set-specifier top-gutter (list ctl-frame nil)))
+ (sit-for 0)
+ (set-specifier top-toolbar-height (list ctl-frame 0))
+ ;;(set-specifier bottom-toolbar-height (list ctl-frame 0))
+ (set-specifier left-toolbar-width (list ctl-frame 0))
+ (set-specifier right-toolbar-width (list ctl-frame 0))))
+
+ ;; Under OS/2 (emx) we have to call modify frame parameters twice, in order
+ ;; to make sure that at least once we do it for non-iconified frame. If
+ ;; appears that in the OS/2 port of Emacs, one can't modify frame
+ ;; parameters of iconified frames. As a precaution, we do likewise for
+ ;; windows-nt.
+ (if (memq system-type '(emx windows-nt windows-95))
+ (modify-frame-parameters ctl-frame adjusted-parameters))
+
+ ;; make or zap toolbar (if not requested)
+ (ediff-make-bottom-toolbar ctl-frame)
+
+ (goto-char (point-min))
+
+ (modify-frame-parameters ctl-frame adjusted-parameters)
+ (make-frame-visible ctl-frame)
+
+ ;; This works around a bug in 19.25 and earlier. There, if frame gets
+ ;; iconified, the current buffer changes to that of the frame that
+ ;; becomes exposed as a result of this iconification.
+ ;; So, we make sure the current buffer doesn't change.
+ (select-frame ctl-frame)
+ (ediff-refresh-control-frame)
+
+ (cond ((and ediff-prefer-iconified-control-frame
+ (not ctl-frame-iconified-p) (not dont-iconify-ctl-frame))
+ (iconify-frame ctl-frame))
+ ((or deiconify-ctl-frame (not ctl-frame-iconified-p))
+ (raise-frame ctl-frame)))
+
+ (set-window-dedicated-p (selected-window) t)
+
+ ;; Now move the frame. We must do it separately due to an obscure bug in
+ ;; XEmacs
+ (modify-frame-parameters
+ ctl-frame
+ (funcall ediff-control-frame-position-function ctl-buffer fwidth fheight))
+
+ ;; synchronize so the cursor will move to control frame
+ ;; per RMS suggestion
+ (if (ediff-window-display-p)
+ (let ((count 7))
+ (sit-for .1)
+ (while (and (not (frame-visible-p ctl-frame)) (> count 0))
+ (setq count (1- count))
+ (sit-for .3))))
+
+ (or (ediff-frame-iconified-p ctl-frame)
+ ;; don't warp the mouse, unless ediff-grab-mouse = t
+ (ediff-reset-mouse ctl-frame
+ (or (eq this-command 'ediff-quit)
+ (not (eq ediff-grab-mouse t)))))
+
+ (when (featurep 'xemacs)
+ (ediff-with-current-buffer ctl-buffer
+ (make-local-hook 'select-frame-hook)
+ (add-hook 'select-frame-hook
+ 'ediff-xemacs-select-frame-hook nil 'local)))
+
+ (ediff-with-current-buffer ctl-buffer
+ (run-hooks 'ediff-after-setup-control-frame-hook))))
+
+
+(defun ediff-destroy-control-frame (ctl-buffer)
+ (ediff-with-current-buffer ctl-buffer
+ (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame))
+ (let ((ctl-frame ediff-control-frame))
+ (if (and (featurep 'xemacs) (featurep 'menubar))
+ (set-buffer-menubar default-menubar))
+ (setq ediff-control-frame nil)
+ (delete-frame ctl-frame))))
+ (if ediff-multiframe
+ (ediff-skip-unsuitable-frames))
+ ;;(ediff-reset-mouse nil)
+ )
+
+
+;; finds a good place to clip control frame
+(defun ediff-make-frame-position (ctl-buffer ctl-frame-width ctl-frame-height)
+ (ediff-with-current-buffer ctl-buffer
+ (let* ((frame-A (window-frame ediff-window-A))
+ (frame-A-parameters (frame-parameters frame-A))
+ (frame-A-top (eval (cdr (assoc 'top frame-A-parameters))))
+ (frame-A-left (eval (cdr (assoc 'left frame-A-parameters))))
+ (frame-A-width (frame-width frame-A))
+ (ctl-frame ediff-control-frame)
+ horizontal-adjustment upward-adjustment
+ ctl-frame-top ctl-frame-left)
+
+ ;; Multiple control frames are clipped based on the value of
+ ;; ediff-control-buffer-number. This is done in order not to obscure
+ ;; other active control panels.
+ (setq horizontal-adjustment (* 2 ediff-control-buffer-number)
+ upward-adjustment (* -14 ediff-control-buffer-number))
+
+ (setq ctl-frame-top
+ (- frame-A-top upward-adjustment ediff-control-frame-upward-shift)
+ ctl-frame-left
+ (+ frame-A-left
+ (if ediff-use-long-help-message
+ (* (ediff-frame-char-width ctl-frame)
+ (+ ediff-wide-control-frame-rightward-shift
+ horizontal-adjustment))
+ (- (* frame-A-width (ediff-frame-char-width frame-A))
+ (* (ediff-frame-char-width ctl-frame)
+ (+ ctl-frame-width
+ ediff-narrow-control-frame-leftward-shift
+ horizontal-adjustment))))))
+ (setq ctl-frame-top
+ (min ctl-frame-top
+ (- (ediff-display-pixel-height)
+ (* 2 ctl-frame-height
+ (ediff-frame-char-height ctl-frame))))
+ ctl-frame-left
+ (min ctl-frame-left
+ (- (ediff-display-pixel-width)
+ (* ctl-frame-width (ediff-frame-char-width ctl-frame)))))
+ ;; keep ctl frame within the visible bounds
+ (setq ctl-frame-top (max ctl-frame-top 1)
+ ctl-frame-left (max ctl-frame-left 1))
+
+ (list (cons 'top ctl-frame-top)
+ (cons 'left ctl-frame-left))
+ )))
+
+(defun ediff-xemacs-select-frame-hook ()
+ (if (and (equal (selected-frame) ediff-control-frame)
+ (not ediff-use-long-help-message))
+ (raise-frame ediff-control-frame)))
+
+(defun ediff-make-wide-display ()
+ "Construct an alist of parameters for the wide display.
+Saves the old frame parameters in `ediff-wide-display-orig-parameters'.
+The frame to be resized is kept in `ediff-wide-display-frame'.
+This function modifies only the left margin and the width of the display.
+It assumes that it is called from within the control buffer."
+ (if (not (fboundp 'ediff-display-pixel-width))
+ (error "Can't determine display width"))
+ (let* ((frame-A (window-frame ediff-window-A))
+ (frame-A-params (frame-parameters frame-A))
+ (cw (ediff-frame-char-width frame-A))
+ (wd (- (/ (ediff-display-pixel-width) cw) 5)))
+ (setq ediff-wide-display-orig-parameters
+ (list (cons 'left (max 0 (eval (cdr (assoc 'left frame-A-params)))))
+ (cons 'width (cdr (assoc 'width frame-A-params))))
+ ediff-wide-display-frame frame-A)
+ (modify-frame-parameters
+ frame-A `((left . ,cw) (width . ,wd) (user-position . t)))))
+
+
+;; Revise the mode line to display which difference we have selected
+;; Also resets modelines of buffers A/B, since they may be clobbered by
+;; anothe invocations of Ediff.
+(defun ediff-refresh-mode-lines ()
+ (let (buf-A-state-diff buf-B-state-diff buf-C-state-diff buf-C-state-merge)
+
+ (if (ediff-valid-difference-p)
+ (setq
+ buf-C-state-diff (ediff-get-state-of-diff ediff-current-difference 'C)
+ buf-C-state-merge (ediff-get-state-of-merge ediff-current-difference)
+ buf-A-state-diff (ediff-get-state-of-diff ediff-current-difference 'A)
+ buf-B-state-diff (ediff-get-state-of-diff ediff-current-difference 'B)
+ buf-A-state-diff (if buf-A-state-diff
+ (format "[%s] " buf-A-state-diff)
+ "")
+ buf-B-state-diff (if buf-B-state-diff
+ (format "[%s] " buf-B-state-diff)
+ "")
+ buf-C-state-diff (if (and (ediff-buffer-live-p ediff-buffer-C)
+ (or buf-C-state-diff buf-C-state-merge))
+ (format "[%s%s%s] "
+ (or buf-C-state-diff "")
+ (if buf-C-state-merge
+ (concat " " buf-C-state-merge)
+ "")
+ (if (ediff-get-state-of-ancestor
+ ediff-current-difference)
+ " AncestorEmpty"
+ "")
+ )
+ ""))
+ (setq buf-A-state-diff ""
+ buf-B-state-diff ""
+ buf-C-state-diff ""))
+
+ ;; control buffer format
+ (setq mode-line-format
+ (if (ediff-narrow-control-frame-p)
+ (list " " mode-line-buffer-identification)
+ (list "-- " mode-line-buffer-identification " Quick Help")))
+ ;; control buffer id
+ (setq mode-line-buffer-identification
+ (if (ediff-narrow-control-frame-p)
+ (ediff-make-narrow-control-buffer-id 'skip-name)
+ (ediff-make-wide-control-buffer-id)))
+ ;; Force mode-line redisplay
+ (force-mode-line-update)
+
+ (if (and (ediff-window-display-p) (frame-live-p ediff-control-frame))
+ (ediff-refresh-control-frame))
+
+ (ediff-with-current-buffer ediff-buffer-A
+ (setq ediff-diff-status buf-A-state-diff)
+ (ediff-strip-mode-line-format)
+ (setq mode-line-format
+ (list " A: " 'ediff-diff-status mode-line-format))
+ (force-mode-line-update))
+ (ediff-with-current-buffer ediff-buffer-B
+ (setq ediff-diff-status buf-B-state-diff)
+ (ediff-strip-mode-line-format)
+ (setq mode-line-format
+ (list " B: " 'ediff-diff-status mode-line-format))
+ (force-mode-line-update))
+ (if ediff-3way-job
+ (ediff-with-current-buffer ediff-buffer-C
+ (setq ediff-diff-status buf-C-state-diff)
+ (ediff-strip-mode-line-format)
+ (setq mode-line-format
+ (list " C: " 'ediff-diff-status mode-line-format))
+ (force-mode-line-update)))
+ (if (ediff-buffer-live-p ediff-ancestor-buffer)
+ (ediff-with-current-buffer ediff-ancestor-buffer
+ (ediff-strip-mode-line-format)
+ ;; we keep the second dummy string in the mode line format of the
+ ;; ancestor, since for other buffers Ediff prepends 2 strings and
+ ;; ediff-strip-mode-line-format expects that.
+ (setq mode-line-format
+ (list " Ancestor: "
+ (cond ((not (stringp buf-C-state-merge))
+ "")
+ ((string-match "prefer-A" buf-C-state-merge)
+ "[=diff(B)] ")
+ ((string-match "prefer-B" buf-C-state-merge)
+ "[=diff(A)] ")
+ (t ""))
+ mode-line-format))))
+ ))
+
+
+(defun ediff-refresh-control-frame ()
+ (if (featurep 'emacs)
+ ;; set frame/icon titles for Emacs
+ (modify-frame-parameters
+ ediff-control-frame
+ (list (cons 'title (ediff-make-base-title))
+ (cons 'icon-name (ediff-make-narrow-control-buffer-id))
+ ))
+ ;; set frame/icon titles for XEmacs
+ (setq frame-title-format (ediff-make-base-title)
+ frame-icon-title-format (ediff-make-narrow-control-buffer-id))
+ ;; force an update of the frame title
+ (modify-frame-parameters ediff-control-frame '(()))))
+
+
+(defun ediff-make-narrow-control-buffer-id (&optional skip-name)
+ (concat
+ (if skip-name
+ " "
+ (ediff-make-base-title))
+ (cond ((< ediff-current-difference 0)
+ (format " _/%d" ediff-number-of-differences))
+ ((>= ediff-current-difference ediff-number-of-differences)
+ (format " $/%d" ediff-number-of-differences))
+ (t
+ (format " %d/%d"
+ (1+ ediff-current-difference)
+ ediff-number-of-differences)))))
+
+(defun ediff-make-base-title ()
+ (concat
+ (cdr (assoc 'name ediff-control-frame-parameters))
+ ediff-control-buffer-suffix))
+
+(defun ediff-make-wide-control-buffer-id ()
+ (cond ((< ediff-current-difference 0)
+ (list (format "%%b At start of %d diffs"
+ ediff-number-of-differences)))
+ ((>= ediff-current-difference ediff-number-of-differences)
+ (list (format "%%b At end of %d diffs"
+ ediff-number-of-differences)))
+ (t
+ (list (format "%%b diff %d of %d"
+ (1+ ediff-current-difference)
+ ediff-number-of-differences)))))
+
+
+
+;; If buff is not live, return nil
+(defun ediff-get-visible-buffer-window (buff)
+ (if (ediff-buffer-live-p buff)
+ (if (featurep 'xemacs)
+ (get-buffer-window buff t)
+ (get-buffer-window buff 'visible))))
+
+
+;;; Functions to decide when to redraw windows
+
+(defun ediff-keep-window-config (control-buf)
+ (and (eq control-buf (current-buffer))
+ (/= (buffer-size) 0)
+ (ediff-with-current-buffer control-buf
+ (let ((ctl-wind ediff-control-window)
+ (A-wind ediff-window-A)
+ (B-wind ediff-window-B)
+ (C-wind ediff-window-C))
+
+ (and
+ (ediff-window-visible-p A-wind)
+ (ediff-window-visible-p B-wind)
+ ;; if buffer C is defined then take it into account
+ (or (not ediff-3way-job)
+ (ediff-window-visible-p C-wind))
+ (eq (window-buffer A-wind) ediff-buffer-A)
+ (eq (window-buffer B-wind) ediff-buffer-B)
+ (or (not ediff-3way-job)
+ (eq (window-buffer C-wind) ediff-buffer-C))
+ (string= ediff-window-config-saved
+ (format "%S%S%S%S%S%S%S"
+ ctl-wind A-wind B-wind C-wind
+ ediff-split-window-function
+ (ediff-multiframe-setup-p)
+ ediff-wide-display-p)))))))
+
+
+(provide 'ediff-wind)
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: 73d9a5d7-eed7-4d9c-8b4b-21d5d78eb597
+;;; ediff-wind.el ends here
--- /dev/null
+;;; ediff.el --- a comprehensive visual interface to diff & patch
+
+;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Created: February 2, 1994
+;; Keywords: comparing, merging, patching, tools, unix
+
+;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
+;; file on 20/3/2008, and the maintainer agreed that when a bug is
+;; filed in the Emacs bug reporting system against this file, a copy
+;; of the bug report be sent to the maintainer's email address.
+
+(defconst ediff-version "2.81.4" "The current version of Ediff")
+(defconst ediff-date "December 7, 2009" "Date of last update")
+
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Never read that diff output again!
+;; Apply patch interactively!
+;; Merge with ease!
+
+;; This package provides a convenient way of simultaneous browsing through
+;; the differences between a pair (or a triple) of files or buffers. The
+;; files being compared, file-A, file-B, and file-C (if applicable) are
+;; shown in separate windows (side by side, one above the another, or in
+;; separate frames), and the differences are highlighted as you step
+;; through them. You can also copy difference regions from one buffer to
+;; another (and recover old differences if you change your mind).
+
+;; Ediff also supports merging operations on files and buffers, including
+;; merging using ancestor versions. Both comparison and merging operations can
+;; be performed on directories, i.e., by pairwise comparison of files in those
+;; directories.
+
+;; In addition, Ediff can apply a patch to a file and then let you step
+;; though both files, the patched and the original one, simultaneously,
+;; difference-by-difference. You can even apply a patch right out of a
+;; mail buffer, i.e., patches received by mail don't even have to be saved.
+;; Since Ediff lets you copy differences between buffers, you can, in
+;; effect, apply patches selectively (i.e., you can copy a difference
+;; region from file_orig to file, thereby undoing any particular patch that
+;; you don't like).
+
+;; Ediff is aware of version control, which lets the user compare
+;; files with their older versions. Ediff can also work with remote and
+;; compressed files. Details are given below.
+
+;; Finally, Ediff supports directory-level comparison, merging and patching.
+;; See the on-line manual for details.
+
+;; This package builds upon the ideas borrowed from emerge.el and several
+;; Ediff's functions are adaptations from emerge.el. Much of the functionality
+;; Ediff provides is also influenced by emerge.el.
+
+;; The present version of Ediff supersedes Emerge. It provides a superior user
+;; interface and has numerous major features not found in Emerge. In
+;; particular, it can do patching, and 2-way and 3-way file comparison,
+;; merging, and directory operations.
+
+
+
+;;; Bugs:
+
+;; 1. The undo command doesn't restore deleted regions well. That is, if
+;; you delete all characters in a difference region and then invoke
+;; `undo', the reinstated text will most likely be inserted outside of
+;; what Ediff thinks is the current difference region. (This problem
+;; doesn't seem to exist with XEmacs.)
+;;
+;; If at any point you feel that difference regions are no longer correct,
+;; you can hit '!' to recompute the differences.
+
+;; 2. On a monochrome display, the repertoire of faces with which to
+;; highlight fine differences is limited. By default, Ediff is using
+;; underlining. However, if the region is already underlined by some other
+;; overlays, there is no simple way to temporarily remove that residual
+;; underlining. This problem occurs when a buffer is highlighted with
+;; hilit19.el or font-lock.el packages. If this residual highlighting gets
+;; in the way, you can do the following. Both font-lock.el and hilit19.el
+;; provide commands for unhighlighting buffers. You can either place these
+;; commands in `ediff-prepare-buffer-hook' (which will unhighlight every
+;; buffer used by Ediff) or you can execute them interactively, at any time
+;; and on any buffer.
+
+
+;;; Acknowledgements:
+
+;; Ediff was inspired by Dale R. Worley's <drw@math.mit.edu> emerge.el.
+;; Ediff would not have been possible without the help and encouragement of
+;; its many users. See Ediff on-line Info for the full list of those who
+;; helped. Improved defaults in Ediff file-name reading commands.
+
+;;; Code:
+
+(provide 'ediff)
+
+;; Compiler pacifier
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
+
+(eval-when-compile
+ (require 'dired)
+ (require 'ediff-util)
+ (require 'ediff-ptch))
+;; end pacifier
+
+(require 'ediff-init)
+(require 'ediff-mult) ; required because of the registry stuff
+
+(defgroup ediff nil
+ "A comprehensive visual interface to diff & patch."
+ :tag "Ediff"
+ :group 'tools)
+
+
+(defcustom ediff-use-last-dir nil
+ "If t, Ediff will use previous directory as default when reading file name."
+ :type 'boolean
+ :group 'ediff)
+
+;; Last directory used by an Ediff command for file-A.
+(defvar ediff-last-dir-A nil)
+;; Last directory used by an Ediff command for file-B.
+(defvar ediff-last-dir-B nil)
+;; Last directory used by an Ediff command for file-C.
+(defvar ediff-last-dir-C nil)
+;; Last directory used by an Ediff command for the ancestor file.
+(defvar ediff-last-dir-ancestor nil)
+;; Last directory used by an Ediff command as the output directory for merge.
+(defvar ediff-last-merge-autostore-dir nil)
+
+
+;; Used as a startup hook to set `_orig' patch file read-only.
+(defun ediff-set-read-only-in-buf-A ()
+ (ediff-with-current-buffer ediff-buffer-A
+ (toggle-read-only 1)))
+
+;; Return a plausible default for ediff's first file:
+;; In dired, return the file number FILENO (or 0) in the list
+;; (all-selected-files, filename under the cursor), where directories are
+;; ignored. Otherwise, return DEFAULT file name, if non-nil. Else,
+;; if the buffer is visiting a file, return that file name.
+(defun ediff-get-default-file-name (&optional default fileno)
+ (cond ((eq major-mode 'dired-mode)
+ (let ((current (dired-get-filename nil 'no-error))
+ (marked (condition-case nil
+ (dired-get-marked-files 'no-dir)
+ (error nil)))
+ aux-list choices result)
+ (or (integerp fileno) (setq fileno 0))
+ (if (stringp default)
+ (setq aux-list (cons default aux-list)))
+ (if (and (stringp current) (not (file-directory-p current)))
+ (setq aux-list (cons current aux-list)))
+ (setq choices (nconc marked aux-list))
+ (setq result (elt choices fileno))
+ (or result
+ default)))
+ ((stringp default) default)
+ ((buffer-file-name (current-buffer))
+ (file-name-nondirectory (buffer-file-name (current-buffer))))
+ ))
+
+;;; Compare files/buffers
+
+;;;###autoload
+(defun ediff-files (file-A file-B &optional startup-hooks)
+ "Run Ediff on a pair of files, FILE-A and FILE-B."
+ (interactive
+ (let ((dir-A (if ediff-use-last-dir
+ ediff-last-dir-A
+ default-directory))
+ dir-B f)
+ (list (setq f (ediff-read-file-name
+ "File A to compare"
+ dir-A
+ (ediff-get-default-file-name)
+ 'no-dirs))
+ (ediff-read-file-name "File B to compare"
+ (setq dir-B
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (file-name-directory f)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory f)
+ dir-B)))
+ (ediff-get-default-file-name f 1)))
+ )))
+ (ediff-files-internal file-A
+ (if (file-directory-p file-B)
+ (expand-file-name
+ (file-name-nondirectory file-A) file-B)
+ file-B)
+ nil ; file-C
+ startup-hooks
+ 'ediff-files))
+
+;;;###autoload
+(defun ediff-files3 (file-A file-B file-C &optional startup-hooks)
+ "Run Ediff on three files, FILE-A, FILE-B, and FILE-C."
+ (interactive
+ (let ((dir-A (if ediff-use-last-dir
+ ediff-last-dir-A
+ default-directory))
+ dir-B dir-C f ff)
+ (list (setq f (ediff-read-file-name
+ "File A to compare"
+ dir-A
+ (ediff-get-default-file-name)
+ 'no-dirs))
+ (setq ff (ediff-read-file-name "File B to compare"
+ (setq dir-B
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (file-name-directory f)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory f)
+ dir-B)))
+ (ediff-get-default-file-name f 1))))
+ (ediff-read-file-name "File C to compare"
+ (setq dir-C (if ediff-use-last-dir
+ ediff-last-dir-C
+ (file-name-directory ff)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory ff)
+ dir-C)))
+ (ediff-get-default-file-name ff 2)))
+ )))
+ (ediff-files-internal file-A
+ (if (file-directory-p file-B)
+ (expand-file-name
+ (file-name-nondirectory file-A) file-B)
+ file-B)
+ (if (file-directory-p file-C)
+ (expand-file-name
+ (file-name-nondirectory file-A) file-C)
+ file-C)
+ startup-hooks
+ 'ediff-files3))
+
+;;;###autoload
+(defalias 'ediff3 'ediff-files3)
+
+
+(defun ediff-find-file (file-var buffer-name &optional last-dir hooks-var)
+ "Visit FILE and arrange its buffer to Ediff's liking.
+FILE-VAR is actually a variable symbol whose value must contain a true
+file name.
+BUFFER-NAME is a variable symbol, which will get the buffer object into
+which FILE is read.
+LAST-DIR is the directory variable symbol where FILE's
+directory name should be returned. HOOKS-VAR is a variable symbol that will
+be assigned the hook to be executed after `ediff-startup' is finished.
+`ediff-find-file' arranges that the temp files it might create will be
+deleted."
+ (let* ((file (symbol-value file-var))
+ (file-magic (ediff-filename-magic-p file))
+ (temp-file-name-prefix (file-name-nondirectory file)))
+ (cond ((not (file-readable-p file))
+ (error "File `%s' does not exist or is not readable" file))
+ ((file-directory-p file)
+ (error "File `%s' is a directory" file)))
+
+ ;; some of the commands, below, require full file name
+ (setq file (expand-file-name file))
+
+ ;; Record the directory of the file
+ (if last-dir
+ (set last-dir (expand-file-name (file-name-directory file))))
+
+ ;; Setup the buffer
+ (set buffer-name (find-file-noselect file))
+
+ (ediff-with-current-buffer (symbol-value buffer-name)
+ (widen) ; Make sure the entire file is seen
+ (cond (file-magic ; file has a handler, such as jka-compr-handler or
+ ;;; ange-ftp-hook-function--arrange for temp file
+ (ediff-verify-file-buffer 'magic)
+ (setq file
+ (ediff-make-temp-file
+ (current-buffer) temp-file-name-prefix))
+ (set hooks-var (cons `(lambda () (delete-file ,file))
+ (symbol-value hooks-var))))
+ ;; file processed via auto-mode-alist, a la uncompress.el
+ ((not (equal (file-truename file)
+ (file-truename (buffer-file-name))))
+ (setq file
+ (ediff-make-temp-file
+ (current-buffer) temp-file-name-prefix))
+ (set hooks-var (cons `(lambda () (delete-file ,file))
+ (symbol-value hooks-var))))
+ (t ;; plain file---just check that the file matches the buffer
+ (ediff-verify-file-buffer))))
+ (set file-var file)))
+
+;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer
+(defun ediff-files-internal (file-A file-B file-C startup-hooks job-name
+ &optional merge-buffer-file)
+ (let (buf-A buf-B buf-C)
+ (if (string= file-A file-B)
+ (error "Files A and B are the same"))
+ (if (stringp file-C)
+ (or (and (string= file-A file-C) (error "Files A and C are the same"))
+ (and (string= file-B file-C) (error "Files B and C are the same"))))
+ (message "Reading file %s ... " file-A)
+ ;;(sit-for 0)
+ (ediff-find-file 'file-A 'buf-A 'ediff-last-dir-A 'startup-hooks)
+ (message "Reading file %s ... " file-B)
+ ;;(sit-for 0)
+ (ediff-find-file 'file-B 'buf-B 'ediff-last-dir-B 'startup-hooks)
+ (if (stringp file-C)
+ (progn
+ (message "Reading file %s ... " file-C)
+ ;;(sit-for 0)
+ (ediff-find-file
+ 'file-C 'buf-C
+ (if (eq job-name 'ediff-merge-files-with-ancestor)
+ 'ediff-last-dir-ancestor 'ediff-last-dir-C)
+ 'startup-hooks)))
+ (ediff-setup buf-A file-A
+ buf-B file-B
+ buf-C file-C
+ startup-hooks
+ (list (cons 'ediff-job-name job-name))
+ merge-buffer-file)))
+
+(declare-function diff-latest-backup-file "diff" (fn))
+
+;;;###autoload
+(defalias 'ediff 'ediff-files)
+
+;;;###autoload
+(defun ediff-current-file ()
+ "Start ediff between current buffer and its file on disk.
+This command can be used instead of `revert-buffer'. If there is
+nothing to revert then this command fails."
+ (interactive)
+ (unless (or revert-buffer-function
+ revert-buffer-insert-file-contents-function
+ (and buffer-file-number
+ (or (buffer-modified-p)
+ (not (verify-visited-file-modtime
+ (current-buffer))))))
+ (error "Nothing to revert"))
+ (let* ((auto-save-p (and (recent-auto-save-p)
+ buffer-auto-save-file-name
+ (file-readable-p buffer-auto-save-file-name)
+ (y-or-n-p
+ "Buffer has been auto-saved recently. Compare with auto-save file? ")))
+ (file-name (if auto-save-p
+ buffer-auto-save-file-name
+ buffer-file-name))
+ (revert-buf-name (concat "FILE=" file-name))
+ (revert-buf (get-buffer revert-buf-name))
+ (current-major major-mode))
+ (unless file-name
+ (error "Buffer does not seem to be associated with any file"))
+ (when revert-buf
+ (kill-buffer revert-buf)
+ (setq revert-buf nil))
+ (setq revert-buf (get-buffer-create revert-buf-name))
+ (with-current-buffer revert-buf
+ (insert-file-contents file-name)
+ ;; Assume same modes:
+ (funcall current-major))
+ (ediff-buffers revert-buf (current-buffer))))
+
+
+;;;###autoload
+(defun ediff-backup (file)
+ "Run Ediff on FILE and its backup file.
+Uses the latest backup, if there are several numerical backups.
+If this file is a backup, `ediff' it with its original."
+ (interactive (list (read-file-name "Ediff (file with backup): ")))
+ ;; The code is taken from `diff-backup'.
+ (require 'diff)
+ (let (bak ori)
+ (if (backup-file-name-p file)
+ (setq bak file
+ ori (file-name-sans-versions file))
+ (setq bak (or (diff-latest-backup-file file)
+ (error "No backup found for %s" file))
+ ori file))
+ (ediff-files bak ori)))
+
+;;;###autoload
+(defun ediff-buffers (buffer-A buffer-B &optional startup-hooks job-name)
+ "Run Ediff on a pair of buffers, BUFFER-A and BUFFER-B."
+ (interactive
+ (let (bf)
+ (list (setq bf (read-buffer "Buffer A to compare: "
+ (ediff-other-buffer "") t))
+ (read-buffer "Buffer B to compare: "
+ (progn
+ ;; realign buffers so that two visible bufs will be
+ ;; at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))))
+ (or job-name (setq job-name 'ediff-buffers))
+ (ediff-buffers-internal buffer-A buffer-B nil startup-hooks job-name))
+
+;;;###autoload
+(defalias 'ebuffers 'ediff-buffers)
+
+
+;;;###autoload
+(defun ediff-buffers3 (buffer-A buffer-B buffer-C
+ &optional startup-hooks job-name)
+ "Run Ediff on three buffers, BUFFER-A, BUFFER-B, and BUFFER-C."
+ (interactive
+ (let (bf bff)
+ (list (setq bf (read-buffer "Buffer A to compare: "
+ (ediff-other-buffer "") t))
+ (setq bff (read-buffer "Buffer B to compare: "
+ (progn
+ ;; realign buffers so that two visible
+ ;; bufs will be at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))
+ (read-buffer "Buffer C to compare: "
+ (progn
+ ;; realign buffers so that three visible
+ ;; bufs will be at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer (list bf bff)))
+ t)
+ )))
+ (or job-name (setq job-name 'ediff-buffers3))
+ (ediff-buffers-internal buffer-A buffer-B buffer-C startup-hooks job-name))
+
+;;;###autoload
+(defalias 'ebuffers3 'ediff-buffers3)
+
+
+
+;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer
+(defun ediff-buffers-internal (buf-A buf-B buf-C startup-hooks job-name
+ &optional merge-buffer-file)
+ (let* ((buf-A-file-name (buffer-file-name (get-buffer buf-A)))
+ (buf-B-file-name (buffer-file-name (get-buffer buf-B)))
+ (buf-C-is-alive (ediff-buffer-live-p buf-C))
+ (buf-C-file-name (if buf-C-is-alive
+ (buffer-file-name (get-buffer buf-B))))
+ file-A file-B file-C)
+ (unwind-protect
+ (progn
+ (if (not (ediff-buffer-live-p buf-A))
+ (error "Buffer %S doesn't exist" buf-A))
+ (if (not (ediff-buffer-live-p buf-B))
+ (error "Buffer %S doesn't exist" buf-B))
+ (let ((ediff-job-name job-name))
+ (if (and ediff-3way-comparison-job
+ (not buf-C-is-alive))
+ (error "Buffer %S doesn't exist" buf-C)))
+ (if (stringp buf-A-file-name)
+ (setq buf-A-file-name (file-name-nondirectory buf-A-file-name)))
+ (if (stringp buf-B-file-name)
+ (setq buf-B-file-name (file-name-nondirectory buf-B-file-name)))
+ (if (stringp buf-C-file-name)
+ (setq buf-C-file-name (file-name-nondirectory buf-C-file-name)))
+
+ (setq file-A (ediff-make-temp-file buf-A buf-A-file-name)
+ file-B (ediff-make-temp-file buf-B buf-B-file-name))
+ (if buf-C-is-alive
+ (setq file-C (ediff-make-temp-file buf-C buf-C-file-name)))
+
+ (ediff-setup (get-buffer buf-A) file-A
+ (get-buffer buf-B) file-B
+ (if buf-C-is-alive (get-buffer buf-C))
+ file-C
+ (cons `(lambda ()
+ (delete-file ,file-A)
+ (delete-file ,file-B)
+ (if (stringp ,file-C) (delete-file ,file-C)))
+ startup-hooks)
+ (list (cons 'ediff-job-name job-name))
+ merge-buffer-file))
+ (if (and (stringp file-A) (file-exists-p file-A))
+ (delete-file file-A))
+ (if (and (stringp file-B) (file-exists-p file-B))
+ (delete-file file-B))
+ (if (and (stringp file-C) (file-exists-p file-C))
+ (delete-file file-C)))))
+
+
+;;; Directory and file group operations
+
+;; Get appropriate default name for directory:
+;; If ediff-use-last-dir, use ediff-last-dir-A.
+;; In dired mode, use the directory that is under the point (if any);
+;; otherwise, use default-directory
+(defun ediff-get-default-directory-name ()
+ (cond (ediff-use-last-dir ediff-last-dir-A)
+ ((eq major-mode 'dired-mode)
+ (let ((f (dired-get-filename nil 'noerror)))
+ (if (and (stringp f) (file-directory-p f))
+ f
+ default-directory)))
+ (t default-directory)))
+
+
+;;;###autoload
+(defun ediff-directories (dir1 dir2 regexp)
+ "Run Ediff on a pair of directories, DIR1 and DIR2, comparing files that have
+the same name in both. The third argument, REGEXP, is nil or a regular
+expression; only file names that match the regexp are considered."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ f)
+ (list (setq f (read-directory-name
+ "Directory A to compare:" dir-A nil 'must-match))
+ (read-directory-name "Directory B to compare:"
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (ediff-strip-last-dir f))
+ nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directories-internal
+ dir1 dir2 nil regexp 'ediff-files 'ediff-directories
+ ))
+
+;;;###autoload
+(defalias 'edirs 'ediff-directories)
+
+
+;;;###autoload
+(defun ediff-directory-revisions (dir1 regexp)
+ "Run Ediff on a directory, DIR1, comparing its files with their revisions.
+The second argument, REGEXP, is a regular expression that filters the file
+names. Only the files that are under revision control are taken into account."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ )
+ (list (read-directory-name
+ "Directory to compare with revision:" dir-A nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directory-revisions-internal
+ dir1 regexp 'ediff-revision 'ediff-directory-revisions
+ ))
+
+;;;###autoload
+(defalias 'edir-revisions 'ediff-directory-revisions)
+
+
+;;;###autoload
+(defun ediff-directories3 (dir1 dir2 dir3 regexp)
+ "Run Ediff on three directories, DIR1, DIR2, and DIR3, comparing files that
+have the same name in all three. The last argument, REGEXP, is nil or a
+regular expression; only file names that match the regexp are considered."
+
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ f)
+ (list (setq f (read-directory-name "Directory A to compare:" dir-A nil))
+ (setq f (read-directory-name "Directory B to compare:"
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (ediff-strip-last-dir f))
+ nil 'must-match))
+ (read-directory-name "Directory C to compare:"
+ (if ediff-use-last-dir
+ ediff-last-dir-C
+ (ediff-strip-last-dir f))
+ nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directories-internal
+ dir1 dir2 dir3 regexp 'ediff-files3 'ediff-directories3
+ ))
+
+;;;###autoload
+(defalias 'edirs3 'ediff-directories3)
+
+;;;###autoload
+(defun ediff-merge-directories (dir1 dir2 regexp &optional merge-autostore-dir)
+ "Run Ediff on a pair of directories, DIR1 and DIR2, merging files that have
+the same name in both. The third argument, REGEXP, is nil or a regular
+expression; only file names that match the regexp are considered."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ f)
+ (list (setq f (read-directory-name "Directory A to merge:"
+ dir-A nil 'must-match))
+ (read-directory-name "Directory B to merge:"
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (ediff-strip-last-dir f))
+ nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directories-internal
+ dir1 dir2 nil regexp 'ediff-merge-files 'ediff-merge-directories
+ nil merge-autostore-dir
+ ))
+
+;;;###autoload
+(defalias 'edirs-merge 'ediff-merge-directories)
+
+;;;###autoload
+(defun ediff-merge-directories-with-ancestor (dir1 dir2 ancestor-dir regexp
+ &optional
+ merge-autostore-dir)
+ "Merge files in directories DIR1 and DIR2 using files in ANCESTOR-DIR as ancestors.
+Ediff merges files that have identical names in DIR1, DIR2. If a pair of files
+in DIR1 and DIR2 doesn't have an ancestor in ANCESTOR-DIR, Ediff will merge
+without ancestor. The fourth argument, REGEXP, is nil or a regular expression;
+only file names that match the regexp are considered."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ f)
+ (list (setq f (read-directory-name "Directory A to merge:" dir-A nil))
+ (setq f (read-directory-name "Directory B to merge:"
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (ediff-strip-last-dir f))
+ nil 'must-match))
+ (read-directory-name "Ancestor directory:"
+ (if ediff-use-last-dir
+ ediff-last-dir-C
+ (ediff-strip-last-dir f))
+ nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directories-internal
+ dir1 dir2 ancestor-dir regexp
+ 'ediff-merge-files-with-ancestor 'ediff-merge-directories-with-ancestor
+ nil merge-autostore-dir
+ ))
+
+;;;###autoload
+(defun ediff-merge-directory-revisions (dir1 regexp
+ &optional merge-autostore-dir)
+ "Run Ediff on a directory, DIR1, merging its files with their revisions.
+The second argument, REGEXP, is a regular expression that filters the file
+names. Only the files that are under revision control are taken into account."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ )
+ (list (read-directory-name
+ "Directory to merge with revisions:" dir-A nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directory-revisions-internal
+ dir1 regexp 'ediff-merge-revisions 'ediff-merge-directory-revisions
+ nil merge-autostore-dir
+ ))
+
+;;;###autoload
+(defalias 'edir-merge-revisions 'ediff-merge-directory-revisions)
+
+;;;###autoload
+(defun ediff-merge-directory-revisions-with-ancestor (dir1 regexp
+ &optional
+ merge-autostore-dir)
+ "Run Ediff on a directory, DIR1, merging its files with their revisions and ancestors.
+The second argument, REGEXP, is a regular expression that filters the file
+names. Only the files that are under revision control are taken into account."
+ (interactive
+ (let ((dir-A (ediff-get-default-directory-name))
+ (default-regexp (eval ediff-default-filtering-regexp))
+ )
+ (list (read-directory-name
+ "Directory to merge with revisions and ancestors:"
+ dir-A nil 'must-match)
+ (read-string
+ (if (stringp default-regexp)
+ (format "Filter through regular expression (default %s): "
+ default-regexp)
+ "Filter through regular expression: ")
+ nil
+ 'ediff-filtering-regexp-history
+ (eval ediff-default-filtering-regexp))
+ )))
+ (ediff-directory-revisions-internal
+ dir1 regexp 'ediff-merge-revisions-with-ancestor
+ 'ediff-merge-directory-revisions-with-ancestor
+ nil merge-autostore-dir
+ ))
+
+;;;###autoload
+(defalias
+ 'edir-merge-revisions-with-ancestor
+ 'ediff-merge-directory-revisions-with-ancestor)
+
+;;;###autoload
+(defalias 'edirs-merge-with-ancestor 'ediff-merge-directories-with-ancestor)
+
+;; Run ediff-action (ediff-files, ediff-merge, ediff-merge-with-ancestors)
+;; on a pair of directories (three directories, in case of ancestor).
+;; The third argument, REGEXP, is nil or a regular expression;
+;; only file names that match the regexp are considered.
+;; JOBNAME is the symbol indicating the meta-job to be performed.
+;; MERGE-AUTOSTORE-DIR is the directory in which to store merged files.
+(defun ediff-directories-internal (dir1 dir2 dir3 regexp action jobname
+ &optional startup-hooks
+ merge-autostore-dir)
+ (if (stringp dir3)
+ (setq dir3 (if (file-directory-p dir3) dir3 (file-name-directory dir3))))
+
+ (cond ((string= dir1 dir2)
+ (error "Directories A and B are the same: %s" dir1))
+ ((and (eq jobname 'ediff-directories3)
+ (string= dir1 dir3))
+ (error "Directories A and C are the same: %s" dir1))
+ ((and (eq jobname 'ediff-directories3)
+ (string= dir2 dir3))
+ (error "Directories B and C are the same: %s" dir1)))
+
+ (if merge-autostore-dir
+ (or (stringp merge-autostore-dir)
+ (error "%s: Directory for storing merged files must be a string"
+ jobname)))
+ (let (;; dir-diff-struct is of the form (common-list diff-list)
+ ;; It is a structure where ediff-intersect-directories returns
+ ;; commonalities and differences among directories
+ dir-diff-struct
+ meta-buf)
+ (if (and ediff-autostore-merges
+ (ediff-merge-metajob jobname)
+ (not merge-autostore-dir))
+ (setq merge-autostore-dir
+ (read-directory-name "Save merged files in directory: "
+ (if ediff-use-last-dir
+ ediff-last-merge-autostore-dir
+ (ediff-strip-last-dir dir1))
+ nil
+ 'must-match)))
+ ;; verify we are not merging into an orig directory
+ (if merge-autostore-dir
+ (cond ((and (stringp dir1) (string= merge-autostore-dir dir1))
+ (or (y-or-n-p
+ "Directory for saving merged files = Directory A. Sure? ")
+ (error "Directory merge aborted")))
+ ((and (stringp dir2) (string= merge-autostore-dir dir2))
+ (or (y-or-n-p
+ "Directory for saving merged files = Directory B. Sure? ")
+ (error "Directory merge aborted")))
+ ((and (stringp dir3) (string= merge-autostore-dir dir3))
+ (or (y-or-n-p
+ "Directory for saving merged files = Ancestor Directory. Sure? ")
+ (error "Directory merge aborted")))))
+
+ (setq dir-diff-struct (ediff-intersect-directories
+ jobname
+ regexp dir1 dir2 dir3 merge-autostore-dir))
+ (setq startup-hooks
+ ;; this sets various vars in the meta buffer inside
+ ;; ediff-prepare-meta-buffer
+ (cons `(lambda ()
+ ;; tell what to do if the user clicks on a session record
+ (setq ediff-session-action-function (quote ,action))
+ ;; set ediff-dir-difference-list
+ (setq ediff-dir-difference-list
+ (cdr (quote ,dir-diff-struct))))
+ startup-hooks))
+ (setq meta-buf (ediff-prepare-meta-buffer
+ 'ediff-filegroup-action
+ (car dir-diff-struct)
+ "*Ediff Session Group Panel"
+ 'ediff-redraw-directory-group-buffer
+ jobname
+ startup-hooks))
+ (ediff-show-meta-buffer meta-buf)
+ ))
+
+;; MERGE-AUTOSTORE-DIR can be given to tell ediff where to store the merged
+;; files
+(defun ediff-directory-revisions-internal (dir1 regexp action jobname
+ &optional startup-hooks
+ merge-autostore-dir)
+ (setq dir1 (if (file-directory-p dir1) dir1 (file-name-directory dir1)))
+
+ (if merge-autostore-dir
+ (or (stringp merge-autostore-dir)
+ (error "%S: Directory for storing merged files must be a string"
+ jobname)))
+ (let (file-list meta-buf)
+ (if (and ediff-autostore-merges
+ (ediff-merge-metajob jobname)
+ (not merge-autostore-dir))
+ (setq merge-autostore-dir
+ (read-directory-name "Save merged files in directory: "
+ (if ediff-use-last-dir
+ ediff-last-merge-autostore-dir
+ (ediff-strip-last-dir dir1))
+ nil
+ 'must-match)))
+ ;; verify merge-autostore-dir != dir1
+ (if (and merge-autostore-dir
+ (stringp dir1)
+ (string= merge-autostore-dir dir1))
+ (or (y-or-n-p
+ "Directory for saving merged file = directory A. Sure? ")
+ (error "Merge of directory revisions aborted")))
+
+ (setq file-list
+ (ediff-get-directory-files-under-revision
+ jobname regexp dir1 merge-autostore-dir))
+ (setq startup-hooks
+ ;; this sets various vars in the meta buffer inside
+ ;; ediff-prepare-meta-buffer
+ (cons `(lambda ()
+ ;; tell what to do if the user clicks on a session record
+ (setq ediff-session-action-function (quote ,action)))
+ startup-hooks))
+ (setq meta-buf (ediff-prepare-meta-buffer
+ 'ediff-filegroup-action
+ file-list
+ "*Ediff Session Group Panel"
+ 'ediff-redraw-directory-group-buffer
+ jobname
+ startup-hooks))
+ (ediff-show-meta-buffer meta-buf)
+ ))
+
+
+;;; Compare regions and windows
+
+;;;###autoload
+(defun ediff-windows-wordwise (dumb-mode &optional wind-A wind-B startup-hooks)
+ "Compare WIND-A and WIND-B, which are selected by clicking, wordwise.
+With prefix argument, DUMB-MODE, or on a non-windowing display, works as
+follows:
+If WIND-A is nil, use selected window.
+If WIND-B is nil, use window next to WIND-A."
+ (interactive "P")
+ (ediff-windows dumb-mode wind-A wind-B
+ startup-hooks 'ediff-windows-wordwise 'word-mode))
+
+;;;###autoload
+(defun ediff-windows-linewise (dumb-mode &optional wind-A wind-B startup-hooks)
+ "Compare WIND-A and WIND-B, which are selected by clicking, linewise.
+With prefix argument, DUMB-MODE, or on a non-windowing display, works as
+follows:
+If WIND-A is nil, use selected window.
+If WIND-B is nil, use window next to WIND-A."
+ (interactive "P")
+ (ediff-windows dumb-mode wind-A wind-B
+ startup-hooks 'ediff-windows-linewise nil))
+
+;; Compare WIND-A and WIND-B, which are selected by clicking.
+;; With prefix argument, DUMB-MODE, or on a non-windowing display,
+;; works as follows:
+;; If WIND-A is nil, use selected window.
+;; If WIND-B is nil, use window next to WIND-A.
+(defun ediff-windows (dumb-mode wind-A wind-B startup-hooks job-name word-mode)
+ (if (or dumb-mode (not (ediff-window-display-p)))
+ (setq wind-A (ediff-get-next-window wind-A nil)
+ wind-B (ediff-get-next-window wind-B wind-A))
+ (setq wind-A (ediff-get-window-by-clicking wind-A nil 1)
+ wind-B (ediff-get-window-by-clicking wind-B wind-A 2)))
+
+ (let ((buffer-A (window-buffer wind-A))
+ (buffer-B (window-buffer wind-B))
+ beg-A end-A beg-B end-B)
+
+ (save-excursion
+ (save-window-excursion
+ (sit-for 0) ; sync before using window-start/end -- a precaution
+ (select-window wind-A)
+ (setq beg-A (window-start)
+ end-A (window-end))
+ (select-window wind-B)
+ (setq beg-B (window-start)
+ end-B (window-end))))
+ (setq buffer-A
+ (ediff-clone-buffer-for-window-comparison
+ buffer-A wind-A "-Window.A-")
+ buffer-B
+ (ediff-clone-buffer-for-window-comparison
+ buffer-B wind-B "-Window.B-"))
+ (ediff-regions-internal
+ buffer-A beg-A end-A buffer-B beg-B end-B
+ startup-hooks job-name word-mode nil)))
+
+
+;;;###autoload
+(defun ediff-regions-wordwise (buffer-A buffer-B &optional startup-hooks)
+ "Run Ediff on a pair of regions in specified buffers.
+Regions \(i.e., point and mark\) can be set in advance or marked interactively.
+This function is effective only for relatively small regions, up to 200
+lines. For large regions, use `ediff-regions-linewise'."
+ (interactive
+ (let (bf)
+ (list (setq bf (read-buffer "Region's A buffer: "
+ (ediff-other-buffer "") t))
+ (read-buffer "Region's B buffer: "
+ (progn
+ ;; realign buffers so that two visible bufs will be
+ ;; at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))))
+ (if (not (ediff-buffer-live-p buffer-A))
+ (error "Buffer %S doesn't exist" buffer-A))
+ (if (not (ediff-buffer-live-p buffer-B))
+ (error "Buffer %S doesn't exist" buffer-B))
+
+
+ (let ((buffer-A
+ (ediff-clone-buffer-for-region-comparison buffer-A "-Region.A-"))
+ (buffer-B
+ (ediff-clone-buffer-for-region-comparison buffer-B "-Region.B-"))
+ reg-A-beg reg-A-end reg-B-beg reg-B-end)
+ (with-current-buffer buffer-A
+ (setq reg-A-beg (region-beginning)
+ reg-A-end (region-end))
+ (set-buffer buffer-B)
+ (setq reg-B-beg (region-beginning)
+ reg-B-end (region-end)))
+
+ (ediff-regions-internal
+ (get-buffer buffer-A) reg-A-beg reg-A-end
+ (get-buffer buffer-B) reg-B-beg reg-B-end
+ startup-hooks 'ediff-regions-wordwise 'word-mode nil)))
+
+;;;###autoload
+(defun ediff-regions-linewise (buffer-A buffer-B &optional startup-hooks)
+ "Run Ediff on a pair of regions in specified buffers.
+Regions \(i.e., point and mark\) can be set in advance or marked interactively.
+Each region is enlarged to contain full lines.
+This function is effective for large regions, over 100-200
+lines. For small regions, use `ediff-regions-wordwise'."
+ (interactive
+ (let (bf)
+ (list (setq bf (read-buffer "Region A's buffer: "
+ (ediff-other-buffer "") t))
+ (read-buffer "Region B's buffer: "
+ (progn
+ ;; realign buffers so that two visible bufs will be
+ ;; at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))))
+ (if (not (ediff-buffer-live-p buffer-A))
+ (error "Buffer %S doesn't exist" buffer-A))
+ (if (not (ediff-buffer-live-p buffer-B))
+ (error "Buffer %S doesn't exist" buffer-B))
+
+ (let ((buffer-A
+ (ediff-clone-buffer-for-region-comparison buffer-A "-Region.A-"))
+ (buffer-B
+ (ediff-clone-buffer-for-region-comparison buffer-B "-Region.B-"))
+ reg-A-beg reg-A-end reg-B-beg reg-B-end)
+ (with-current-buffer buffer-A
+ (setq reg-A-beg (region-beginning)
+ reg-A-end (region-end))
+ ;; enlarge the region to hold full lines
+ (goto-char reg-A-beg)
+ (beginning-of-line)
+ (setq reg-A-beg (point))
+ (goto-char reg-A-end)
+ (end-of-line)
+ (or (eobp) (forward-char)) ; include the newline char
+ (setq reg-A-end (point))
+
+ (set-buffer buffer-B)
+ (setq reg-B-beg (region-beginning)
+ reg-B-end (region-end))
+ ;; enlarge the region to hold full lines
+ (goto-char reg-B-beg)
+ (beginning-of-line)
+ (setq reg-B-beg (point))
+ (goto-char reg-B-end)
+ (end-of-line)
+ (or (eobp) (forward-char)) ; include the newline char
+ (setq reg-B-end (point))
+ ) ; save excursion
+
+ (ediff-regions-internal
+ (get-buffer buffer-A) reg-A-beg reg-A-end
+ (get-buffer buffer-B) reg-B-beg reg-B-end
+ startup-hooks 'ediff-regions-linewise nil nil))) ; no word mode
+
+;; compare region beg-A to end-A of buffer-A
+;; to regions beg-B -- end-B in buffer-B.
+(defun ediff-regions-internal (buffer-A beg-A end-A buffer-B beg-B end-B
+ startup-hooks job-name word-mode
+ setup-parameters)
+ (let ((tmp-buffer (get-buffer-create ediff-tmp-buffer))
+ overl-A overl-B
+ file-A file-B)
+ (unwind-protect
+ (progn
+ ;; in case beg/end-A/B aren't markers--make them into markers
+ (ediff-with-current-buffer buffer-A
+ (setq beg-A (move-marker (make-marker) beg-A)
+ end-A (move-marker (make-marker) end-A)))
+ (ediff-with-current-buffer buffer-B
+ (setq beg-B (move-marker (make-marker) beg-B)
+ end-B (move-marker (make-marker) end-B)))
+
+ ;; make file-A
+ (if word-mode
+ (ediff-wordify beg-A end-A buffer-A tmp-buffer)
+ (ediff-copy-to-buffer beg-A end-A buffer-A tmp-buffer))
+ (setq file-A (ediff-make-temp-file tmp-buffer "regA"))
+
+ ;; make file-B
+ (if word-mode
+ (ediff-wordify beg-B end-B buffer-B tmp-buffer)
+ (ediff-copy-to-buffer beg-B end-B buffer-B tmp-buffer))
+ (setq file-B (ediff-make-temp-file tmp-buffer "regB"))
+
+ (setq overl-A (ediff-make-bullet-proof-overlay beg-A end-A buffer-A))
+ (setq overl-B (ediff-make-bullet-proof-overlay beg-B end-B buffer-B))
+ (ediff-setup buffer-A file-A
+ buffer-B file-B
+ nil nil ; buffer & file C
+ (cons `(lambda ()
+ (delete-file ,file-A)
+ (delete-file ,file-B))
+ startup-hooks)
+ (append
+ (list (cons 'ediff-word-mode word-mode)
+ (cons 'ediff-narrow-bounds (list overl-A overl-B))
+ (cons 'ediff-job-name job-name))
+ setup-parameters)))
+ (if (and (stringp file-A) (file-exists-p file-A))
+ (delete-file file-A))
+ (if (and (stringp file-B) (file-exists-p file-B))
+ (delete-file file-B)))
+ ))
+
+
+;;; Merge files and buffers
+
+;;;###autoload
+(defalias 'ediff-merge 'ediff-merge-files)
+
+(defsubst ediff-merge-on-startup ()
+ (ediff-do-merge 0)
+ ;; Can't remember why this is here, but it may cause the automatically merged
+ ;; buffer to be lost. So, keep the buffer modified.
+ ;;(ediff-with-current-buffer ediff-buffer-C
+ ;; (set-buffer-modified-p nil))
+ )
+
+;;;###autoload
+(defun ediff-merge-files (file-A file-B
+ ;; MERGE-BUFFER-FILE is the file to be
+ ;; associated with the merge buffer
+ &optional startup-hooks merge-buffer-file)
+ "Merge two files without ancestor."
+ (interactive
+ (let ((dir-A (if ediff-use-last-dir
+ ediff-last-dir-A
+ default-directory))
+ dir-B f)
+ (list (setq f (ediff-read-file-name
+ "File A to merge"
+ dir-A
+ (ediff-get-default-file-name)
+ 'no-dirs))
+ (ediff-read-file-name "File B to merge"
+ (setq dir-B
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (file-name-directory f)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory f)
+ dir-B)))
+ (ediff-get-default-file-name f 1)))
+ )))
+ (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
+ (ediff-files-internal file-A
+ (if (file-directory-p file-B)
+ (expand-file-name
+ (file-name-nondirectory file-A) file-B)
+ file-B)
+ nil ; file-C
+ startup-hooks
+ 'ediff-merge-files
+ merge-buffer-file))
+
+;;;###autoload
+(defun ediff-merge-files-with-ancestor (file-A file-B file-ancestor
+ &optional
+ startup-hooks
+ ;; MERGE-BUFFER-FILE is the file
+ ;; to be associated with the
+ ;; merge buffer
+ merge-buffer-file)
+ "Merge two files with ancestor."
+ (interactive
+ (let ((dir-A (if ediff-use-last-dir
+ ediff-last-dir-A
+ default-directory))
+ dir-B dir-ancestor f ff)
+ (list (setq f (ediff-read-file-name
+ "File A to merge"
+ dir-A
+ (ediff-get-default-file-name)
+ 'no-dirs))
+ (setq ff (ediff-read-file-name "File B to merge"
+ (setq dir-B
+ (if ediff-use-last-dir
+ ediff-last-dir-B
+ (file-name-directory f)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory f)
+ dir-B)))
+ (ediff-get-default-file-name f 1))))
+ (ediff-read-file-name "Ancestor file"
+ (setq dir-ancestor
+ (if ediff-use-last-dir
+ ediff-last-dir-ancestor
+ (file-name-directory ff)))
+ (progn
+ (ediff-add-to-history
+ 'file-name-history
+ (ediff-abbreviate-file-name
+ (expand-file-name
+ (file-name-nondirectory ff)
+ dir-ancestor)))
+ (ediff-get-default-file-name ff 2)))
+ )))
+ (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
+ (ediff-files-internal file-A
+ (if (file-directory-p file-B)
+ (expand-file-name
+ (file-name-nondirectory file-A) file-B)
+ file-B)
+ file-ancestor
+ startup-hooks
+ 'ediff-merge-files-with-ancestor
+ merge-buffer-file))
+
+;;;###autoload
+(defalias 'ediff-merge-with-ancestor 'ediff-merge-files-with-ancestor)
+
+;;;###autoload
+(defun ediff-merge-buffers (buffer-A buffer-B
+ &optional
+ ;; MERGE-BUFFER-FILE is the file to be
+ ;; associated with the merge buffer
+ startup-hooks job-name merge-buffer-file)
+ "Merge buffers without ancestor."
+ (interactive
+ (let (bf)
+ (list (setq bf (read-buffer "Buffer A to merge: "
+ (ediff-other-buffer "") t))
+ (read-buffer "Buffer B to merge: "
+ (progn
+ ;; realign buffers so that two visible bufs will be
+ ;; at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))))
+
+ (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
+ (or job-name (setq job-name 'ediff-merge-buffers))
+ (ediff-buffers-internal
+ buffer-A buffer-B nil startup-hooks job-name merge-buffer-file))
+
+;;;###autoload
+(defun ediff-merge-buffers-with-ancestor (buffer-A buffer-B buffer-ancestor
+ &optional
+ startup-hooks
+ job-name
+ ;; MERGE-BUFFER-FILE is the
+ ;; file to be associated
+ ;; with the merge buffer
+ merge-buffer-file)
+ "Merge buffers with ancestor."
+ (interactive
+ (let (bf bff)
+ (list (setq bf (read-buffer "Buffer A to merge: "
+ (ediff-other-buffer "") t))
+ (setq bff (read-buffer "Buffer B to merge: "
+ (progn
+ ;; realign buffers so that two visible
+ ;; bufs will be at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer bf))
+ t))
+ (read-buffer "Ancestor buffer: "
+ (progn
+ ;; realign buffers so that three visible
+ ;; bufs will be at the top
+ (save-window-excursion (other-window 1))
+ (ediff-other-buffer (list bf bff)))
+ t)
+ )))
+
+ (setq startup-hooks (cons 'ediff-merge-on-startup startup-hooks))
+ (or job-name (setq job-name 'ediff-merge-buffers-with-ancestor))
+ (ediff-buffers-internal
+ buffer-A buffer-B buffer-ancestor startup-hooks job-name merge-buffer-file))
+
+
+;;;###autoload
+(defun ediff-merge-revisions (&optional file startup-hooks merge-buffer-file)
+ ;; MERGE-BUFFER-FILE is the file to be associated with the merge buffer
+ "Run Ediff by merging two revisions of a file.
+The file is the optional FILE argument or the file visited by the current
+buffer."
+ (interactive)
+ (if (stringp file) (find-file file))
+ (let (rev1 rev2)
+ (setq rev1
+ (read-string
+ (format
+ "Version 1 to merge (default %s's working version): "
+ (if (stringp file)
+ (file-name-nondirectory file) "current buffer")))
+ rev2
+ (read-string
+ (format
+ "Version 2 to merge (default %s): "
+ (if (stringp file)
+ (file-name-nondirectory file) "current buffer"))))
+ (ediff-load-version-control)
+ ;; ancestor-revision=nil
+ (funcall
+ (intern (format "ediff-%S-merge-internal" ediff-version-control-package))
+ rev1 rev2 nil startup-hooks merge-buffer-file)))
+
+
+;;;###autoload
+(defun ediff-merge-revisions-with-ancestor (&optional
+ file startup-hooks
+ ;; MERGE-BUFFER-FILE is the file to
+ ;; be associated with the merge
+ ;; buffer
+ merge-buffer-file)
+ "Run Ediff by merging two revisions of a file with a common ancestor.
+The file is the optional FILE argument or the file visited by the current
+buffer."
+ (interactive)
+ (if (stringp file) (find-file file))
+ (let (rev1 rev2 ancestor-rev)
+ (setq rev1
+ (read-string
+ (format
+ "Version 1 to merge (default %s's working version): "
+ (if (stringp file)
+ (file-name-nondirectory file) "current buffer")))
+ rev2
+ (read-string
+ (format
+ "Version 2 to merge (default %s): "
+ (if (stringp file)
+ (file-name-nondirectory file) "current buffer")))
+ ancestor-rev
+ (read-string
+ (format
+ "Ancestor version (default %s's base revision): "
+ (if (stringp file)
+ (file-name-nondirectory file) "current buffer"))))
+ (ediff-load-version-control)
+ (funcall
+ (intern (format "ediff-%S-merge-internal" ediff-version-control-package))
+ rev1 rev2 ancestor-rev startup-hooks merge-buffer-file)))
+
+;;; Apply patch
+
+;;;###autoload
+(defun ediff-patch-file (&optional arg patch-buf)
+ "Run Ediff by patching SOURCE-FILENAME.
+If optional PATCH-BUF is given, use the patch in that buffer
+and don't ask the user.
+If prefix argument, then: if even argument, assume that the patch is in a
+buffer. If odd -- assume it is in a file."
+ (interactive "P")
+ (let (source-dir source-file)
+ (require 'ediff-ptch)
+ (setq patch-buf
+ (ediff-get-patch-buffer
+ (if arg (prefix-numeric-value arg)) patch-buf))
+ (setq source-dir (cond (ediff-use-last-dir ediff-last-dir-patch)
+ ((and (not ediff-patch-default-directory)
+ (buffer-file-name patch-buf))
+ (file-name-directory
+ (expand-file-name
+ (buffer-file-name patch-buf))))
+ (t default-directory)))
+ (setq source-file
+ (read-file-name
+ "File to patch (directory, if multifile patch): "
+ ;; use an explicit initial file
+ source-dir nil nil (ediff-get-default-file-name)))
+ (ediff-dispatch-file-patching-job patch-buf source-file)))
+
+;;;###autoload
+(defun ediff-patch-buffer (&optional arg patch-buf)
+ "Run Ediff by patching the buffer specified at prompt.
+Without the optional prefix ARG, asks if the patch is in some buffer and
+prompts for the buffer or a file, depending on the answer.
+With ARG=1, assumes the patch is in a file and prompts for the file.
+With ARG=2, assumes the patch is in a buffer and prompts for the buffer.
+PATCH-BUF is an optional argument, which specifies the buffer that contains the
+patch. If not given, the user is prompted according to the prefix argument."
+ (interactive "P")
+ (require 'ediff-ptch)
+ (setq patch-buf
+ (ediff-get-patch-buffer
+ (if arg (prefix-numeric-value arg)) patch-buf))
+ (ediff-patch-buffer-internal
+ patch-buf
+ (read-buffer
+ "Which buffer to patch? "
+ (ediff-other-buffer patch-buf))))
+
+
+;;;###autoload
+(defalias 'epatch 'ediff-patch-file)
+;;;###autoload
+(defalias 'epatch-buffer 'ediff-patch-buffer)
+
+
+
+\f
+;;; Versions Control functions
+
+;;;###autoload
+(defun ediff-revision (&optional file startup-hooks)
+ "Run Ediff by comparing versions of a file.
+The file is an optional FILE argument or the file entered at the prompt.
+Default: the file visited by the current buffer.
+Uses `vc.el' or `rcs.el' depending on `ediff-version-control-package'."
+ ;; if buffer is non-nil, use that buffer instead of the current buffer
+ (interactive "P")
+ (if (not (stringp file))
+ (setq file
+ (ediff-read-file-name "Compare revisions for file"
+ (if ediff-use-last-dir
+ ediff-last-dir-A
+ default-directory)
+ (ediff-get-default-file-name)
+ 'no-dirs)))
+ (find-file file)
+ (if (and (buffer-modified-p)
+ (y-or-n-p (format "Buffer %s is modified. Save buffer? "
+ (buffer-name))))
+ (save-buffer (current-buffer)))
+ (let (rev1 rev2)
+ (setq rev1
+ (read-string
+ (format "Revision 1 to compare (default %s's latest revision): "
+ (file-name-nondirectory file)))
+ rev2
+ (read-string
+ (format "Revision 2 to compare (default %s's current state): "
+ (file-name-nondirectory file))))
+ (ediff-load-version-control)
+ (funcall
+ (intern (format "ediff-%S-internal" ediff-version-control-package))
+ rev1 rev2 startup-hooks)
+ ))
+
+
+;;;###autoload
+(defalias 'erevision 'ediff-revision)
+
+
+;; Test if version control package is loaded and load if not
+;; Is SILENT is non-nil, don't report error if package is not found.
+(defun ediff-load-version-control (&optional silent)
+ (require 'ediff-vers)
+ (or (featurep ediff-version-control-package)
+ (if (locate-library (symbol-name ediff-version-control-package))
+ (progn
+ (message "") ; kill the message from `locate-library'
+ (require ediff-version-control-package))
+ (or silent
+ (error "Version control package %S.el not found. Use vc.el instead"
+ ediff-version-control-package)))))
+
+
+;;;###autoload
+(defun ediff-version ()
+ "Return string describing the version of Ediff.
+When called interactively, displays the version."
+ (interactive)
+ ;; called-interactively-p - not in XEmacs
+ ;; (if (called-interactively-p 'interactive)
+ (if (interactive-p)
+ (message "%s" (ediff-version))
+ (format "Ediff %s of %s" ediff-version ediff-date)))
+
+;; info is run first, and will autoload info.el.
+(declare-function Info-goto-node "info" (nodename &optional fork))
+
+;;;###autoload
+(defun ediff-documentation (&optional node)
+ "Display Ediff's manual.
+With optional NODE, goes to that node."
+ (interactive)
+ (let ((ctl-window ediff-control-window)
+ (ctl-buf ediff-control-buffer))
+
+ (ediff-skip-unsuitable-frames)
+ (condition-case nil
+ (progn
+ (pop-to-buffer (get-buffer-create "*info*"))
+ (info (if (featurep 'xemacs) "ediff.info" "ediff"))
+ (if node
+ (Info-goto-node node)
+ (message "Type `i' to search for a specific topic"))
+ (raise-frame (selected-frame)))
+ (error (beep 1)
+ (with-output-to-temp-buffer ediff-msg-buffer
+ (ediff-with-current-buffer standard-output
+ (fundamental-mode))
+ (princ ediff-BAD-INFO))
+ (if (window-live-p ctl-window)
+ (progn
+ (select-window ctl-window)
+ (set-window-buffer ctl-window ctl-buf)))))))
+
+
+(dolist (mess '("^Errors in diff output. Diff output is in "
+ "^Hmm... I don't see an Ediff command around here...$"
+ "^Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer$"
+ ": This command runs in Ediff Control Buffer only!$"
+ ": Invalid op in ediff-check-version$"
+ "^ediff-shrink-window-C can be used only for merging jobs$"
+ "^Lost difference info on these directories$"
+ "^This command is inapplicable in the present context$"
+ "^This session group has no parent$"
+ "^Can't hide active session, $"
+ "^Ediff: something wrong--no multiple diffs buffer$"
+ "^Can't make context diff for Session $"
+ "^The patch buffer wasn't found$"
+ "^Aborted$"
+ "^This Ediff session is not part of a session group$"
+ "^No active Ediff sessions or corrupted session registry$"
+ "^No session info in this line$"
+ "^`.*' is not an ordinary file$"
+ "^Patch appears to have failed$"
+ "^Recomputation of differences cancelled$"
+ "^No fine differences in this mode$"
+ "^Lost connection to ancestor buffer...sorry$"
+ "^Not merging with ancestor$"
+ "^Don't know how to toggle read-only in buffer "
+ "Emacs is not running as a window application$"
+ "^This command makes sense only when merging with an ancestor$"
+ "^At end of the difference list$"
+ "^At beginning of the difference list$"
+ "^Nothing saved for diff .* in buffer "
+ "^Buffer is out of sync for file "
+ "^Buffer out of sync for file "
+ "^Output from `diff' not found$"
+ "^You forgot to specify a region in buffer "
+ "^All right. Make up your mind and come back...$"
+ "^Current buffer is not visiting any file$"
+ "^Failed to retrieve revision: $"
+ "^Can't determine display width.$"
+ "^File `.*' does not exist or is not readable$"
+ "^File `.*' is a directory$"
+ "^Buffer .* doesn't exist$"
+ "^Directories . and . are the same: "
+ "^Directory merge aborted$"
+ "^Merge of directory revisions aborted$"
+ "^Buffer .* doesn't exist$"
+ "^There is no file to merge$"
+ "^Version control package .*.el not found. Use vc.el instead$"))
+ (add-to-list 'debug-ignored-errors mess))
+
+
+(require 'ediff-util)
+
+(run-hooks 'ediff-load-hook)
+
+
+;; Local Variables:
+;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun)
+;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1)
+;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
+;; End:
+
+;; arch-tag: 97c71396-db02-4f41-8b48-6a51c3348fcc
+;;; ediff.el ends here
--- /dev/null
+;;; emerge.el --- merge diffs under Emacs control
+
+;;; The author has placed this file in the public domain.
+
+;; This file is part of GNU Emacs.
+
+;; Author: Dale R. Worley <worley@world.std.com>
+;; Keywords: unix, tools
+
+;; This software was created by Dale R. Worley and is
+;; distributed free of charge. It is placed in the public domain and
+;; permission is granted to anyone to use, duplicate, modify and redistribute
+;; it provided that this notice is attached.
+
+;; Dale R. Worley provides absolutely NO WARRANTY OF ANY KIND
+;; with respect to this software. The entire risk as to the quality and
+;; performance of this software is with the user. IN NO EVENT WILL DALE
+;; R. WORLEY BE LIABLE TO ANYONE FOR ANY DAMAGES ARISING OUT THE
+;; USE OF THIS SOFTWARE, INCLUDING, WITHOUT LIMITATION, DAMAGES RESULTING FROM
+;; LOST DATA OR LOST PROFITS, OR FOR ANY SPECIAL, INCIDENTAL OR CONSEQUENTIAL
+;; DAMAGES.
+
+;;; Commentary:
+
+;;; Code:
+
+;; There aren't really global variables, just dynamic bindings
+(defvar A-begin)
+(defvar A-end)
+(defvar B-begin)
+(defvar B-end)
+(defvar diff)
+(defvar diff-vector)
+(defvar merge-begin)
+(defvar merge-end)
+(defvar template)
+(defvar valid-diff)
+
+;;; Macros
+
+(defmacro emerge-eval-in-buffer (buffer &rest forms)
+ "Macro to switch to BUFFER, evaluate FORMS, returns to original buffer.
+Differs from `save-excursion' in that it doesn't save the point and mark."
+ `(let ((StartBuffer (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-buffer ,buffer)
+ ,@forms)
+ (set-buffer StartBuffer))))
+
+(defmacro emerge-defvar-local (var value doc)
+ "Defines SYMBOL as an advertised variable.
+Performs a defvar, then executes `make-variable-buffer-local' on
+the variable. Also sets the `preserved' property, so that
+`kill-all-local-variables' (called by major-mode setting commands)
+won't destroy Emerge control variables."
+ `(progn
+ (defvar ,var ,value ,doc)
+ (make-variable-buffer-local ',var)
+ (put ',var 'preserved t)))
+
+;; Add entries to minor-mode-alist so that emerge modes show correctly
+(defvar emerge-minor-modes-list
+ '((emerge-mode " Emerge")
+ (emerge-fast-mode " F")
+ (emerge-edit-mode " E")
+ (emerge-auto-advance " A")
+ (emerge-skip-prefers " S")))
+(if (not (assq 'emerge-mode minor-mode-alist))
+ (setq minor-mode-alist (append emerge-minor-modes-list
+ minor-mode-alist)))
+
+;; We need to define this function so describe-mode can describe Emerge mode.
+(defun emerge-mode ()
+ "Emerge mode is used by the Emerge file-merging package.
+It is entered only through one of the functions:
+ `emerge-files'
+ `emerge-files-with-ancestor'
+ `emerge-buffers'
+ `emerge-buffers-with-ancestor'
+ `emerge-files-command'
+ `emerge-files-with-ancestor-command'
+ `emerge-files-remote'
+ `emerge-files-with-ancestor-remote'
+
+Commands:
+\\{emerge-basic-keymap}
+Commands must be prefixed by \\<emerge-fast-keymap>\\[emerge-basic-keymap] in `edit' mode,
+but can be invoked directly in `fast' mode.")
+
+(define-obsolete-variable-alias 'emerge-version 'emacs-version "23.2")
+
+(defun emerge-version ()
+ "Return string describing the version of Emerge.
+When called interactively, displays the version."
+ (interactive)
+ (if (called-interactively-p 'interactive)
+ (message "Emerge version %s" emacs-version)
+ emacs-version))
+
+(make-obsolete 'emerge-version 'emacs-version "23.2")
+
+;;; Emerge configuration variables
+
+(defgroup emerge nil
+ "Merge diffs under Emacs control."
+ :group 'tools)
+
+;; Commands that produce difference files
+;; All that can be configured is the name of the programs to execute
+;; (emerge-diff-program and emerge-diff3-program) and the options
+;; to be provided (emerge-diff-options). The order in which the file names
+;; are given is fixed.
+;; The file names are always expanded (see expand-file-name) before being
+;; passed to diff, thus they need not be invoked under a shell that
+;; understands `~'.
+;; The code which processes the diff/diff3 output depends on all the
+;; finicky details of their output, including the somewhat strange
+;; way they number lines of a file.
+(defcustom emerge-diff-program "diff"
+ "Name of the program which compares two files."
+ :type 'string
+ :group 'emerge)
+(defcustom emerge-diff3-program "diff3"
+ "Name of the program which compares three files.
+Its arguments are the ancestor file and the two variant files."
+ :type 'string
+ :group 'emerge)
+(defcustom emerge-diff-options ""
+ "Options to pass to `emerge-diff-program' and `emerge-diff3-program'."
+ :type 'string
+ :group 'emerge)
+(defcustom emerge-match-diff-line
+ (let ((x "\\([0-9]+\\)\\(\\|,\\([0-9]+\\)\\)"))
+ (concat "^" x "\\([acd]\\)" x "$"))
+ "Pattern to match lines produced by diff that describe differences.
+This is as opposed to lines from the source files."
+ :type 'regexp
+ :group 'emerge)
+(defcustom emerge-diff-ok-lines-regexp
+ "^\\([0-9,]+[acd][0-9,]+$\\|[<>] \\|---\\)"
+ "Regexp that matches normal output lines from `emerge-diff-program'.
+Lines that do not match are assumed to be error messages."
+ :type 'regexp
+ :group 'emerge)
+(defcustom emerge-diff3-ok-lines-regexp
+ "^\\([1-3]:\\|====\\| \\)"
+ "Regexp that matches normal output lines from `emerge-diff3-program'.
+Lines that do not match are assumed to be error messages."
+ :type 'regexp
+ :group 'emerge)
+
+(defcustom emerge-rcs-ci-program "ci"
+ "Name of the program that checks in RCS revisions."
+ :type 'string
+ :group 'emerge)
+(defcustom emerge-rcs-co-program "co"
+ "Name of the program that checks out RCS revisions."
+ :type 'string
+ :group 'emerge)
+
+(defcustom emerge-process-local-variables nil
+ "Non-nil if Emerge should process local-variables lists in merge buffers.
+\(You can explicitly request processing the local-variables
+by executing `(hack-local-variables)'.)"
+ :type 'boolean
+ :group 'emerge)
+(defcustom emerge-execute-line-deletions nil
+ "If non-nil: `emerge-execute-line' makes no output if an input was deleted.
+It concludes that an input version has been deleted when an ancestor entry
+is present, only one A or B entry is present, and an output entry is present.
+If nil: In such circumstances, the A or B file that is present will be
+copied to the designated output file."
+ :type 'boolean
+ :group 'emerge)
+
+(defcustom emerge-before-flag "vvvvvvvvvvvvvvvvvvvv\n"
+ "Flag placed above the highlighted block of code. Must end with newline.
+Must be set before Emerge is loaded, or emerge-new-flags must be run
+after setting."
+ :type 'string
+ :group 'emerge)
+(defcustom emerge-after-flag "^^^^^^^^^^^^^^^^^^^^\n"
+ "Flag placed below the highlighted block of code. Must end with newline.
+Must be set before Emerge is loaded, or emerge-new-flags must be run
+after setting."
+ :type 'string
+ :group 'emerge)
+
+;; Hook variables
+
+(defcustom emerge-startup-hook nil
+ "Hook to run in the merge buffer after the merge has been set up."
+ :type 'hook
+ :group 'emerge)
+(defcustom emerge-select-hook nil
+ "Hook to run after a difference has been selected.
+The variable `n' holds the (internal) number of the difference."
+ :type 'hook
+ :group 'emerge)
+(defcustom emerge-unselect-hook nil
+ "Hook to run after a difference has been unselected.
+The variable `n' holds the (internal) number of the difference."
+ :type 'hook
+ :group 'emerge)
+
+;; Variables to control the default directories of the arguments to
+;; Emerge commands.
+
+(defcustom emerge-default-last-directories nil
+ "If nil, default dir for filenames in emerge is `default-directory'.
+If non-nil, filenames complete in the directory of the last argument of the
+same type to an `emerge-files...' command."
+ :type 'boolean
+ :group 'emerge)
+
+(defvar emerge-last-dir-A nil
+ "Last directory for the first file of an `emerge-files...' command.")
+(defvar emerge-last-dir-B nil
+ "Last directory for the second file of an `emerge-files...' command.")
+(defvar emerge-last-dir-ancestor nil
+ "Last directory for the ancestor file of an `emerge-files...' command.")
+(defvar emerge-last-dir-output nil
+ "Last directory for the output file of an `emerge-files...' command.")
+(defvar emerge-last-revision-A nil
+ "Last RCS revision used for first file of an `emerge-revisions...' command.")
+(defvar emerge-last-revision-B nil
+ "Last RCS revision used for second file of an `emerge-revisions...' command.")
+(defvar emerge-last-revision-ancestor nil
+ "Last RCS revision used for ancestor file of an `emerge-revisions...' command.")
+
+(defvar emerge-before-flag-length)
+(defvar emerge-before-flag-lines)
+(defvar emerge-before-flag-match)
+(defvar emerge-after-flag-length)
+(defvar emerge-after-flag-lines)
+(defvar emerge-after-flag-match)
+(defvar emerge-diff-buffer)
+(defvar emerge-diff-error-buffer)
+(defvar emerge-prefix-argument)
+(defvar emerge-file-out)
+(defvar emerge-exit-func)
+(defvar emerge-globalized-difference-list)
+(defvar emerge-globalized-number-of-differences)
+
+;; The flags used to mark differences in the buffers.
+
+;; These function definitions need to be up here, because they are used
+;; during loading.
+(defun emerge-new-flags ()
+ "Function to be called after `emerge-{before,after}-flag'.
+This is called after these functions are changed to compute values that
+depend on the flags."
+ (setq emerge-before-flag-length (length emerge-before-flag))
+ (setq emerge-before-flag-lines
+ (emerge-count-matches-string emerge-before-flag "\n"))
+ (setq emerge-before-flag-match (regexp-quote emerge-before-flag))
+ (setq emerge-after-flag-length (length emerge-after-flag))
+ (setq emerge-after-flag-lines
+ (emerge-count-matches-string emerge-after-flag "\n"))
+ (setq emerge-after-flag-match (regexp-quote emerge-after-flag)))
+
+(defun emerge-count-matches-string (string regexp)
+ "Return the number of matches in STRING for REGEXP."
+ (let ((i 0)
+ (count 0))
+ (while (string-match regexp string i)
+ (setq count (1+ count))
+ (setq i (match-end 0)))
+ count))
+
+;; Calculate dependent variables
+(emerge-new-flags)
+
+(defcustom emerge-min-visible-lines 3
+ "Number of lines that we want to show above and below the flags when we are
+displaying a difference."
+ :type 'integer
+ :group 'emerge)
+
+(defcustom emerge-temp-file-prefix
+ (expand-file-name "emerge" temporary-file-directory)
+ "Prefix to put on Emerge temporary file names.
+Do not start with `~/' or `~USERNAME/'."
+ :type 'string
+ :group 'emerge)
+
+(defcustom emerge-temp-file-mode 384 ; u=rw only
+ "Mode for Emerge temporary files."
+ :type 'integer
+ :group 'emerge)
+
+(defcustom emerge-combine-versions-template
+ "#ifdef NEW\n%b#else /* not NEW */\n%a#endif /* not NEW */\n"
+ "Template for `emerge-combine-versions' to combine the two versions.
+The template is inserted as a string, with the following interpolations:
+ %a the A version of the difference
+ %b the B version of the difference
+ %% the character `%'
+Don't forget to end the template with a newline.
+Note that this variable can be made local to a particular merge buffer by
+giving a prefix argument to `emerge-set-combine-versions-template'."
+ :type 'string
+ :group 'emerge)
+
+;; Build keymaps
+
+(defvar emerge-basic-keymap nil
+ "Keymap of Emerge commands.
+Directly available in `fast' mode;
+must be prefixed by \\<emerge-fast-keymap>\\[emerge-basic-keymap] in `edit' mode.")
+
+(defvar emerge-fast-keymap nil
+ "Local keymap used in Emerge `fast' mode.
+Makes Emerge commands directly available.")
+
+(defvar emerge-options-menu
+ (make-sparse-keymap "Options"))
+
+(defvar emerge-merge-menu
+ (make-sparse-keymap "Merge"))
+
+(defvar emerge-move-menu
+ (make-sparse-keymap "Move"))
+
+(defcustom emerge-command-prefix "\C-c\C-c"
+ "Command prefix for Emerge commands in `edit' mode.
+Must be set before Emerge is loaded."
+ :type 'string
+ :group 'emerge)
+
+;; This function sets up the fixed keymaps. It is executed when the first
+;; Emerge is done to allow the user maximum time to set up the global keymap.
+(defun emerge-setup-fixed-keymaps ()
+ ;; Set up the basic keymap
+ (setq emerge-basic-keymap (make-keymap))
+ (suppress-keymap emerge-basic-keymap) ; this sets 0..9 to digit-argument and
+ ; - to negative-argument
+ (define-key emerge-basic-keymap "p" 'emerge-previous-difference)
+ (define-key emerge-basic-keymap "n" 'emerge-next-difference)
+ (define-key emerge-basic-keymap "a" 'emerge-select-A)
+ (define-key emerge-basic-keymap "b" 'emerge-select-B)
+ (define-key emerge-basic-keymap "j" 'emerge-jump-to-difference)
+ (define-key emerge-basic-keymap "." 'emerge-find-difference)
+ (define-key emerge-basic-keymap "q" 'emerge-quit)
+ (define-key emerge-basic-keymap "\C-]" 'emerge-abort)
+ (define-key emerge-basic-keymap "f" 'emerge-fast-mode)
+ (define-key emerge-basic-keymap "e" 'emerge-edit-mode)
+ (define-key emerge-basic-keymap "s" nil)
+ (define-key emerge-basic-keymap "sa" 'emerge-auto-advance)
+ (define-key emerge-basic-keymap "ss" 'emerge-skip-prefers)
+ (define-key emerge-basic-keymap "l" 'emerge-recenter)
+ (define-key emerge-basic-keymap "d" nil)
+ (define-key emerge-basic-keymap "da" 'emerge-default-A)
+ (define-key emerge-basic-keymap "db" 'emerge-default-B)
+ (define-key emerge-basic-keymap "c" nil)
+ (define-key emerge-basic-keymap "ca" 'emerge-copy-as-kill-A)
+ (define-key emerge-basic-keymap "cb" 'emerge-copy-as-kill-B)
+ (define-key emerge-basic-keymap "i" nil)
+ (define-key emerge-basic-keymap "ia" 'emerge-insert-A)
+ (define-key emerge-basic-keymap "ib" 'emerge-insert-B)
+ (define-key emerge-basic-keymap "m" 'emerge-mark-difference)
+ (define-key emerge-basic-keymap "v" 'emerge-scroll-up)
+ (define-key emerge-basic-keymap "^" 'emerge-scroll-down)
+ (define-key emerge-basic-keymap "<" 'emerge-scroll-left)
+ (define-key emerge-basic-keymap ">" 'emerge-scroll-right)
+ (define-key emerge-basic-keymap "|" 'emerge-scroll-reset)
+ (define-key emerge-basic-keymap "x" nil)
+ (define-key emerge-basic-keymap "x1" 'emerge-one-line-window)
+ (define-key emerge-basic-keymap "xc" 'emerge-combine-versions)
+ (define-key emerge-basic-keymap "xC" 'emerge-combine-versions-register)
+ (define-key emerge-basic-keymap "xf" 'emerge-file-names)
+ (define-key emerge-basic-keymap "xj" 'emerge-join-differences)
+ (define-key emerge-basic-keymap "xl" 'emerge-line-numbers)
+ (define-key emerge-basic-keymap "xm" 'emerge-set-merge-mode)
+ (define-key emerge-basic-keymap "xs" 'emerge-split-difference)
+ (define-key emerge-basic-keymap "xt" 'emerge-trim-difference)
+ (define-key emerge-basic-keymap "xx" 'emerge-set-combine-versions-template)
+ ;; Allow emerge-basic-keymap to be referenced indirectly
+ (fset 'emerge-basic-keymap emerge-basic-keymap)
+ ;; Set up the fast mode keymap
+ (setq emerge-fast-keymap (copy-keymap emerge-basic-keymap))
+ ;; Allow prefixed commands to work in fast mode
+ (define-key emerge-fast-keymap emerge-command-prefix 'emerge-basic-keymap)
+ ;; Allow emerge-fast-keymap to be referenced indirectly
+ (fset 'emerge-fast-keymap emerge-fast-keymap)
+ ;; Suppress write-file and save-buffer
+ (define-key emerge-fast-keymap [remap write-file] 'emerge-query-write-file)
+ (define-key emerge-fast-keymap [remap save-buffer] 'emerge-query-save-buffer)
+
+ (define-key emerge-basic-keymap [menu-bar] (make-sparse-keymap))
+
+ (define-key emerge-fast-keymap [menu-bar emerge-options]
+ (cons "Merge-Options" emerge-options-menu))
+ (define-key emerge-fast-keymap [menu-bar merge]
+ (cons "Merge" emerge-merge-menu))
+ (define-key emerge-fast-keymap [menu-bar move]
+ (cons "Move" emerge-move-menu))
+
+ (define-key emerge-move-menu [emerge-scroll-reset]
+ '("Scroll Reset" . emerge-scroll-reset))
+ (define-key emerge-move-menu [emerge-scroll-right]
+ '("Scroll Right" . emerge-scroll-right))
+ (define-key emerge-move-menu [emerge-scroll-left]
+ '("Scroll Left" . emerge-scroll-left))
+ (define-key emerge-move-menu [emerge-scroll-down]
+ '("Scroll Down" . emerge-scroll-down))
+ (define-key emerge-move-menu [emerge-scroll-up]
+ '("Scroll Up" . emerge-scroll-up))
+ (define-key emerge-move-menu [emerge-recenter]
+ '("Recenter" . emerge-recenter))
+ (define-key emerge-move-menu [emerge-mark-difference]
+ '("Mark Difference" . emerge-mark-difference))
+ (define-key emerge-move-menu [emerge-jump-to-difference]
+ '("Jump To Difference" . emerge-jump-to-difference))
+ (define-key emerge-move-menu [emerge-find-difference]
+ '("Find Difference" . emerge-find-difference))
+ (define-key emerge-move-menu [emerge-previous-difference]
+ '("Previous Difference" . emerge-previous-difference))
+ (define-key emerge-move-menu [emerge-next-difference]
+ '("Next Difference" . emerge-next-difference))
+
+
+ (define-key emerge-options-menu [emerge-one-line-window]
+ '("One Line Window" . emerge-one-line-window))
+ (define-key emerge-options-menu [emerge-set-merge-mode]
+ '("Set Merge Mode..." . emerge-set-merge-mode))
+ (define-key emerge-options-menu [emerge-set-combine-template]
+ '("Set Combine Template..." . emerge-set-combine-template))
+ (define-key emerge-options-menu [emerge-default-B]
+ '("Default B" . emerge-default-B))
+ (define-key emerge-options-menu [emerge-default-A]
+ '("Default A" . emerge-default-A))
+ (define-key emerge-options-menu [emerge-skip-prefers]
+ '(menu-item "Skip Prefers" emerge-skip-prefers
+ :button (:toggle . emerge-skip-prefers)))
+ (define-key emerge-options-menu [emerge-auto-advance]
+ '(menu-item "Auto Advance" emerge-auto-advance
+ :button (:toggle . emerge-auto-advance)))
+ (define-key emerge-options-menu [emerge-edit-mode]
+ '(menu-item "Edit Mode" emerge-edit-mode :enable (not emerge-edit-mode)))
+ (define-key emerge-options-menu [emerge-fast-mode]
+ '(menu-item "Fast Mode" emerge-fast-mode :enable (not emerge-fast-mode)))
+
+ (define-key emerge-merge-menu [emerge-abort] '("Abort" . emerge-abort))
+ (define-key emerge-merge-menu [emerge-quit] '("Quit" . emerge-quit))
+ (define-key emerge-merge-menu [emerge-split-difference]
+ '("Split Difference" . emerge-split-difference))
+ (define-key emerge-merge-menu [emerge-join-differences]
+ '("Join Differences" . emerge-join-differences))
+ (define-key emerge-merge-menu [emerge-trim-difference]
+ '("Trim Difference" . emerge-trim-difference))
+ (define-key emerge-merge-menu [emerge-combine-versions]
+ '("Combine Versions" . emerge-combine-versions))
+ (define-key emerge-merge-menu [emerge-copy-as-kill-B]
+ '("Copy B as Kill" . emerge-copy-as-kill-B))
+ (define-key emerge-merge-menu [emerge-copy-as-kill-A]
+ '("Copy A as Kill" . emerge-copy-as-kill-A))
+ (define-key emerge-merge-menu [emerge-insert-B]
+ '("Insert B" . emerge-insert-B))
+ (define-key emerge-merge-menu [emerge-insert-A]
+ '("Insert A" . emerge-insert-A))
+ (define-key emerge-merge-menu [emerge-select-B]
+ '("Select B" . emerge-select-B))
+ (define-key emerge-merge-menu [emerge-select-A]
+ '("Select A" . emerge-select-A)))
+
+
+;; Variables which control each merge. They are local to the merge buffer.
+
+;; Mode variables
+(emerge-defvar-local emerge-mode nil
+ "Indicator for emerge-mode.")
+(emerge-defvar-local emerge-fast-mode nil
+ "Indicator for emerge-mode fast submode.")
+(emerge-defvar-local emerge-edit-mode nil
+ "Indicator for emerge-mode edit submode.")
+(emerge-defvar-local emerge-A-buffer nil
+ "The buffer in which the A variant is stored.")
+(emerge-defvar-local emerge-B-buffer nil
+ "The buffer in which the B variant is stored.")
+(emerge-defvar-local emerge-merge-buffer nil
+ "The buffer in which the merged file is manipulated.")
+(emerge-defvar-local emerge-ancestor-buffer nil
+ "The buffer in which the ancestor variant is stored,
+or nil if there is none.")
+
+(defconst emerge-saved-variables
+ '((buffer-modified-p set-buffer-modified-p)
+ buffer-read-only
+ buffer-auto-save-file-name)
+ "Variables and properties of a buffer which are saved, modified and restored
+during a merge.")
+(defconst emerge-merging-values '(nil t nil)
+ "Values to be assigned to emerge-saved-variables during a merge.")
+
+(emerge-defvar-local emerge-A-buffer-values nil
+ "Remembers emerge-saved-variables for emerge-A-buffer.")
+(emerge-defvar-local emerge-B-buffer-values nil
+ "Remembers emerge-saved-variables for emerge-B-buffer.")
+
+(emerge-defvar-local emerge-difference-list nil
+ "Vector of differences between the variants, and markers in the buffers to
+show where they are. Each difference is represented by a vector of seven
+elements. The first two are markers to the beginning and end of the difference
+section in the A buffer, the second two are markers for the B buffer, the third
+two are markers for the merge buffer, and the last element is the \"state\" of
+that difference in the merge buffer.
+ A section of a buffer is described by two markers, one to the beginning of
+the first line of the section, and one to the beginning of the first line
+after the section. (If the section is empty, both markers point to the same
+point.) If the section is part of the selected difference, then the markers
+are moved into the flags, so the user can edit the section without disturbing
+the markers.
+ The \"states\" are:
+ A the merge buffer currently contains the A variant
+ B the merge buffer currently contains the B variant
+ default-A the merge buffer contains the A variant by default,
+ but this difference hasn't been selected yet, so
+ change-default commands can alter it
+ default-B the merge buffer contains the B variant by default,
+ but this difference hasn't been selected yet, so
+ change-default commands can alter it
+ prefer-A in a three-file merge, the A variant is the preferred
+ choice
+ prefer-B in a three-file merge, the B variant is the preferred
+ choice")
+(emerge-defvar-local emerge-current-difference -1
+ "The difference that is currently selected.")
+(emerge-defvar-local emerge-number-of-differences nil
+ "Number of differences found.")
+(emerge-defvar-local emerge-edit-keymap nil
+ "The local keymap for the merge buffer, with the emerge commands defined in
+it. Used to save the local keymap during fast mode, when the local keymap is
+replaced by emerge-fast-keymap.")
+(emerge-defvar-local emerge-old-keymap nil
+ "The original local keymap for the merge buffer.")
+(emerge-defvar-local emerge-auto-advance nil
+ "*If non-nil, emerge-select-A and emerge-select-B automatically advance to
+the next difference.")
+(emerge-defvar-local emerge-skip-prefers nil
+ "*If non-nil, differences for which there is a preference are automatically
+skipped.")
+(emerge-defvar-local emerge-quit-hook nil
+ "Hooks to run in the merge buffer after the merge has been finished.
+`emerge-prefix-argument' will hold the prefix argument of the `emerge-quit'
+command.
+This is *not* a user option, since Emerge uses it for its own processing.")
+(emerge-defvar-local emerge-output-description nil
+ "Describes output destination of emerge, for `emerge-file-names'.")
+
+;;; Setup functions for two-file mode.
+
+(defun emerge-files-internal (file-A file-B &optional startup-hooks quit-hooks
+ output-file)
+ (if (not (file-readable-p file-A))
+ (error "File `%s' does not exist or is not readable" file-A))
+ (if (not (file-readable-p file-B))
+ (error "File `%s' does not exist or is not readable" file-B))
+ (let ((buffer-A (find-file-noselect file-A))
+ (buffer-B (find-file-noselect file-B)))
+ ;; Record the directories of the files
+ (setq emerge-last-dir-A (file-name-directory file-A))
+ (setq emerge-last-dir-B (file-name-directory file-B))
+ (if output-file
+ (setq emerge-last-dir-output (file-name-directory output-file)))
+ ;; Make sure the entire files are seen, and they reflect what is on disk
+ (emerge-eval-in-buffer
+ buffer-A
+ (widen)
+ (let ((temp (file-local-copy file-A)))
+ (if temp
+ (setq file-A temp
+ startup-hooks
+ (cons `(lambda () (delete-file ,file-A))
+ startup-hooks))
+ ;; Verify that the file matches the buffer
+ (emerge-verify-file-buffer))))
+ (emerge-eval-in-buffer
+ buffer-B
+ (widen)
+ (let ((temp (file-local-copy file-B)))
+ (if temp
+ (setq file-B temp
+ startup-hooks
+ (cons `(lambda () (delete-file ,file-B))
+ startup-hooks))
+ ;; Verify that the file matches the buffer
+ (emerge-verify-file-buffer))))
+ (emerge-setup buffer-A file-A buffer-B file-B startup-hooks quit-hooks
+ output-file)))
+
+;; Start up Emerge on two files
+(defun emerge-setup (buffer-A file-A buffer-B file-B startup-hooks quit-hooks
+ output-file)
+ (setq file-A (expand-file-name file-A))
+ (setq file-B (expand-file-name file-B))
+ (setq output-file (and output-file (expand-file-name output-file)))
+ (let* ((merge-buffer-name (emerge-unique-buffer-name "*merge" "*"))
+ ;; create the merge buffer from buffer A, so it inherits buffer A's
+ ;; default directory, etc.
+ (merge-buffer (emerge-eval-in-buffer
+ buffer-A
+ (get-buffer-create merge-buffer-name))))
+ (emerge-eval-in-buffer
+ merge-buffer
+ (emerge-copy-modes buffer-A)
+ (setq buffer-read-only nil)
+ (auto-save-mode 1)
+ (setq emerge-mode t)
+ (setq emerge-A-buffer buffer-A)
+ (setq emerge-B-buffer buffer-B)
+ (setq emerge-ancestor-buffer nil)
+ (setq emerge-merge-buffer merge-buffer)
+ (setq emerge-output-description
+ (if output-file
+ (concat "Output to file: " output-file)
+ (concat "Output to buffer: " (buffer-name merge-buffer))))
+ (save-excursion (insert-buffer-substring emerge-A-buffer))
+ (emerge-set-keys)
+ (setq emerge-difference-list (emerge-make-diff-list file-A file-B))
+ (setq emerge-number-of-differences (length emerge-difference-list))
+ (setq emerge-current-difference -1)
+ (setq emerge-quit-hook quit-hooks)
+ (emerge-remember-buffer-characteristics)
+ (emerge-handle-local-variables))
+ (emerge-setup-windows buffer-A buffer-B merge-buffer t)
+ (emerge-eval-in-buffer merge-buffer
+ (run-hooks 'startup-hooks 'emerge-startup-hook)
+ (setq buffer-read-only t))))
+
+;; Generate the Emerge difference list between two files
+(defun emerge-make-diff-list (file-A file-B)
+ (setq emerge-diff-buffer (get-buffer-create "*emerge-diff*"))
+ (emerge-eval-in-buffer
+ emerge-diff-buffer
+ (erase-buffer)
+ (shell-command
+ (format "%s %s %s %s"
+ emerge-diff-program emerge-diff-options
+ (emerge-protect-metachars file-A)
+ (emerge-protect-metachars file-B))
+ t))
+ (emerge-prepare-error-list emerge-diff-ok-lines-regexp)
+ (emerge-convert-diffs-to-markers
+ emerge-A-buffer emerge-B-buffer emerge-merge-buffer
+ (emerge-extract-diffs emerge-diff-buffer)))
+
+(defun emerge-extract-diffs (diff-buffer)
+ (let (list)
+ (emerge-eval-in-buffer
+ diff-buffer
+ (goto-char (point-min))
+ (while (re-search-forward emerge-match-diff-line nil t)
+ (let* ((a-begin (string-to-number (buffer-substring (match-beginning 1)
+ (match-end 1))))
+ (a-end (let ((b (match-beginning 3))
+ (e (match-end 3)))
+ (if b
+ (string-to-number (buffer-substring b e))
+ a-begin)))
+ (diff-type (buffer-substring (match-beginning 4) (match-end 4)))
+ (b-begin (string-to-number (buffer-substring (match-beginning 5)
+ (match-end 5))))
+ (b-end (let ((b (match-beginning 7))
+ (e (match-end 7)))
+ (if b
+ (string-to-number (buffer-substring b e))
+ b-begin))))
+ ;; fix the beginning and end numbers, because diff is somewhat
+ ;; strange about how it numbers lines
+ (if (string-equal diff-type "a")
+ (progn
+ (setq b-end (1+ b-end))
+ (setq a-begin (1+ a-begin))
+ (setq a-end a-begin))
+ (if (string-equal diff-type "d")
+ (progn
+ (setq a-end (1+ a-end))
+ (setq b-begin (1+ b-begin))
+ (setq b-end b-begin))
+ ;; (string-equal diff-type "c")
+ (progn
+ (setq a-end (1+ a-end))
+ (setq b-end (1+ b-end)))))
+ (setq list (cons (vector a-begin a-end
+ b-begin b-end
+ 'default-A)
+ list)))))
+ (nreverse list)))
+
+;; Set up buffer of diff/diff3 error messages.
+(defun emerge-prepare-error-list (ok-regexp)
+ (setq emerge-diff-error-buffer (get-buffer-create "*emerge-diff-errors*"))
+ (emerge-eval-in-buffer
+ emerge-diff-error-buffer
+ (erase-buffer)
+ (save-excursion (insert-buffer-substring emerge-diff-buffer))
+ (delete-matching-lines ok-regexp)))
+
+;;; Top-level and setup functions for three-file mode.
+
+(defun emerge-files-with-ancestor-internal (file-A file-B file-ancestor
+ &optional startup-hooks quit-hooks
+ output-file)
+ (if (not (file-readable-p file-A))
+ (error "File `%s' does not exist or is not readable" file-A))
+ (if (not (file-readable-p file-B))
+ (error "File `%s' does not exist or is not readable" file-B))
+ (if (not (file-readable-p file-ancestor))
+ (error "File `%s' does not exist or is not readable" file-ancestor))
+ (let ((buffer-A (find-file-noselect file-A))
+ (buffer-B (find-file-noselect file-B))
+ (buffer-ancestor (find-file-noselect file-ancestor)))
+ ;; Record the directories of the files
+ (setq emerge-last-dir-A (file-name-directory file-A))
+ (setq emerge-last-dir-B (file-name-directory file-B))
+ (setq emerge-last-dir-ancestor (file-name-directory file-ancestor))
+ (if output-file
+ (setq emerge-last-dir-output (file-name-directory output-file)))
+ ;; Make sure the entire files are seen, and they reflect what is on disk
+ (emerge-eval-in-buffer
+ buffer-A
+ (widen)
+ (let ((temp (file-local-copy file-A)))
+ (if temp
+ (setq file-A temp
+ startup-hooks
+ (cons `(lambda () (delete-file ,file-A))
+ startup-hooks))
+ ;; Verify that the file matches the buffer
+ (emerge-verify-file-buffer))))
+ (emerge-eval-in-buffer
+ buffer-B
+ (widen)
+ (let ((temp (file-local-copy file-B)))
+ (if temp
+ (setq file-B temp
+ startup-hooks
+ (cons `(lambda () (delete-file ,file-B))
+ startup-hooks))
+ ;; Verify that the file matches the buffer
+ (emerge-verify-file-buffer))))
+ (emerge-eval-in-buffer
+ buffer-ancestor
+ (widen)
+ (let ((temp (file-local-copy file-ancestor)))
+ (if temp
+ (setq file-ancestor temp
+ startup-hooks
+ (cons `(lambda () (delete-file ,file-ancestor))
+ startup-hooks))
+ ;; Verify that the file matches the buffer
+ (emerge-verify-file-buffer))))
+ (emerge-setup-with-ancestor buffer-A file-A buffer-B file-B
+ buffer-ancestor file-ancestor
+ startup-hooks quit-hooks output-file)))
+
+;; Start up Emerge on two files with an ancestor
+(defun emerge-setup-with-ancestor (buffer-A file-A buffer-B file-B
+ buffer-ancestor file-ancestor
+ &optional startup-hooks quit-hooks
+ output-file)
+ (setq file-A (expand-file-name file-A))
+ (setq file-B (expand-file-name file-B))
+ (setq file-ancestor (expand-file-name file-ancestor))
+ (setq output-file (and output-file (expand-file-name output-file)))
+ (let* ((merge-buffer-name (emerge-unique-buffer-name "*merge" "*"))
+ ;; create the merge buffer from buffer A, so it inherits buffer A's
+ ;; default directory, etc.
+ (merge-buffer (emerge-eval-in-buffer
+ buffer-A
+ (get-buffer-create merge-buffer-name))))
+ (emerge-eval-in-buffer
+ merge-buffer
+ (emerge-copy-modes buffer-A)
+ (setq buffer-read-only nil)
+ (auto-save-mode 1)
+ (setq emerge-mode t)
+ (setq emerge-A-buffer buffer-A)
+ (setq emerge-B-buffer buffer-B)
+ (setq emerge-ancestor-buffer buffer-ancestor)
+ (setq emerge-merge-buffer merge-buffer)
+ (setq emerge-output-description
+ (if output-file
+ (concat "Output to file: " output-file)
+ (concat "Output to buffer: " (buffer-name merge-buffer))))
+ (save-excursion (insert-buffer-substring emerge-A-buffer))
+ (emerge-set-keys)
+ (setq emerge-difference-list
+ (emerge-make-diff3-list file-A file-B file-ancestor))
+ (setq emerge-number-of-differences (length emerge-difference-list))
+ (setq emerge-current-difference -1)
+ (setq emerge-quit-hook quit-hooks)
+ (emerge-remember-buffer-characteristics)
+ (emerge-select-prefer-Bs)
+ (emerge-handle-local-variables))
+ (emerge-setup-windows buffer-A buffer-B merge-buffer t)
+ (emerge-eval-in-buffer merge-buffer
+ (run-hooks 'startup-hooks 'emerge-startup-hook)
+ (setq buffer-read-only t))))
+
+;; Generate the Emerge difference list between two files with an ancestor
+(defun emerge-make-diff3-list (file-A file-B file-ancestor)
+ (setq emerge-diff-buffer (get-buffer-create "*emerge-diff*"))
+ (emerge-eval-in-buffer
+ emerge-diff-buffer
+ (erase-buffer)
+ (shell-command
+ (format "%s %s %s %s %s"
+ emerge-diff3-program emerge-diff-options
+ (emerge-protect-metachars file-A)
+ (emerge-protect-metachars file-ancestor)
+ (emerge-protect-metachars file-B))
+ t))
+ (emerge-prepare-error-list emerge-diff3-ok-lines-regexp)
+ (emerge-convert-diffs-to-markers
+ emerge-A-buffer emerge-B-buffer emerge-merge-buffer
+ (emerge-extract-diffs3 emerge-diff-buffer)))
+
+(defun emerge-extract-diffs3 (diff-buffer)
+ (let (list)
+ (emerge-eval-in-buffer
+ diff-buffer
+ (while (re-search-forward "^====\\(.?\\)$" nil t)
+ ;; leave point after matched line
+ (beginning-of-line 2)
+ (let ((agreement (buffer-substring (match-beginning 1) (match-end 1))))
+ ;; if the A and B files are the same, ignore the difference
+ (if (not (string-equal agreement "2"))
+ (setq list
+ (cons
+ (let (group-1 group-3 pos)
+ (setq pos (point))
+ (setq group-1 (emerge-get-diff3-group "1"))
+ (goto-char pos)
+ (setq group-3 (emerge-get-diff3-group "3"))
+ (vector (car group-1) (car (cdr group-1))
+ (car group-3) (car (cdr group-3))
+ (cond ((string-equal agreement "1") 'prefer-A)
+ ((string-equal agreement "3") 'prefer-B)
+ (t 'default-A))))
+ list))))))
+ (nreverse list)))
+
+(defun emerge-get-diff3-group (file)
+ ;; This save-excursion allows emerge-get-diff3-group to be called for the
+ ;; various groups of lines (1, 2, 3) in any order, and for the lines to
+ ;; appear in any order. The reason this is necessary is that Gnu diff3
+ ;; can produce the groups in the order 1, 2, 3 or 1, 3, 2.
+ (save-excursion
+ (re-search-forward
+ (concat "^" file ":\\([0-9]+\\)\\(,\\([0-9]+\\)\\)?\\([ac]\\)$"))
+ (beginning-of-line 2)
+ ;; treatment depends on whether it is an "a" group or a "c" group
+ (if (string-equal (buffer-substring (match-beginning 4) (match-end 4)) "c")
+ ;; it is a "c" group
+ (if (match-beginning 2)
+ ;; it has two numbers
+ (list (string-to-number
+ (buffer-substring (match-beginning 1) (match-end 1)))
+ (1+ (string-to-number
+ (buffer-substring (match-beginning 3) (match-end 3)))))
+ ;; it has one number
+ (let ((x (string-to-number
+ (buffer-substring (match-beginning 1) (match-end 1)))))
+ (list x (1+ x))))
+ ;; it is an "a" group
+ (let ((x (1+ (string-to-number
+ (buffer-substring (match-beginning 1) (match-end 1))))))
+ (list x x)))))
+
+;;; Functions to start Emerge on files
+
+;;;###autoload
+(defun emerge-files (arg file-A file-B file-out &optional startup-hooks
+ quit-hooks)
+ "Run Emerge on two files."
+ (interactive
+ (let (f)
+ (list current-prefix-arg
+ (setq f (emerge-read-file-name "File A to merge" emerge-last-dir-A
+ nil nil t))
+ (emerge-read-file-name "File B to merge" emerge-last-dir-B nil f t)
+ (and current-prefix-arg
+ (emerge-read-file-name "Output file" emerge-last-dir-output
+ f f nil)))))
+ (if file-out
+ (add-hook 'quit-hooks `(lambda () (emerge-files-exit ,file-out))))
+ (emerge-files-internal
+ file-A file-B startup-hooks
+ quit-hooks
+ file-out))
+
+;;;###autoload
+(defun emerge-files-with-ancestor (arg file-A file-B file-ancestor file-out
+ &optional startup-hooks quit-hooks)
+ "Run Emerge on two files, giving another file as the ancestor."
+ (interactive
+ (let (f)
+ (list current-prefix-arg
+ (setq f (emerge-read-file-name "File A to merge" emerge-last-dir-A
+ nil nil t))
+ (emerge-read-file-name "File B to merge" emerge-last-dir-B nil f t)
+ (emerge-read-file-name "Ancestor file" emerge-last-dir-ancestor
+ nil f t)
+ (and current-prefix-arg
+ (emerge-read-file-name "Output file" emerge-last-dir-output
+ f f nil)))))
+ (if file-out
+ (add-hook 'quit-hooks `(lambda () (emerge-files-exit ,file-out))))
+ (emerge-files-with-ancestor-internal
+ file-A file-B file-ancestor startup-hooks
+ quit-hooks
+ file-out))
+
+;; Write the merge buffer out in place of the file the A buffer is visiting.
+(defun emerge-files-exit (file-out)
+ ;; if merge was successful was given, save to disk
+ (if (not emerge-prefix-argument)
+ (emerge-write-and-delete file-out)))
+
+;;; Functions to start Emerge on buffers
+
+;;;###autoload
+(defun emerge-buffers (buffer-A buffer-B &optional startup-hooks quit-hooks)
+ "Run Emerge on two buffers."
+ (interactive "bBuffer A to merge: \nbBuffer B to merge: ")
+ (let ((emerge-file-A (emerge-make-temp-file "A"))
+ (emerge-file-B (emerge-make-temp-file "B")))
+ (emerge-eval-in-buffer
+ buffer-A
+ (write-region (point-min) (point-max) emerge-file-A nil 'no-message))
+ (emerge-eval-in-buffer
+ buffer-B
+ (write-region (point-min) (point-max) emerge-file-B nil 'no-message))
+ (emerge-setup (get-buffer buffer-A) emerge-file-A
+ (get-buffer buffer-B) emerge-file-B
+ (cons `(lambda ()
+ (delete-file ,emerge-file-A)
+ (delete-file ,emerge-file-B))
+ startup-hooks)
+ quit-hooks
+ nil)))
+
+;;;###autoload
+(defun emerge-buffers-with-ancestor (buffer-A buffer-B buffer-ancestor
+ &optional startup-hooks
+ quit-hooks)
+ "Run Emerge on two buffers, giving another buffer as the ancestor."
+ (interactive
+ "bBuffer A to merge: \nbBuffer B to merge: \nbAncestor buffer: ")
+ (let ((emerge-file-A (emerge-make-temp-file "A"))
+ (emerge-file-B (emerge-make-temp-file "B"))
+ (emerge-file-ancestor (emerge-make-temp-file "anc")))
+ (emerge-eval-in-buffer
+ buffer-A
+ (write-region (point-min) (point-max) emerge-file-A nil 'no-message))
+ (emerge-eval-in-buffer
+ buffer-B
+ (write-region (point-min) (point-max) emerge-file-B nil 'no-message))
+ (emerge-eval-in-buffer
+ buffer-ancestor
+ (write-region (point-min) (point-max) emerge-file-ancestor nil
+ 'no-message))
+ (emerge-setup-with-ancestor (get-buffer buffer-A) emerge-file-A
+ (get-buffer buffer-B) emerge-file-B
+ (get-buffer buffer-ancestor)
+ emerge-file-ancestor
+ (cons `(lambda ()
+ (delete-file ,emerge-file-A)
+ (delete-file ,emerge-file-B)
+ (delete-file
+ ,emerge-file-ancestor))
+ startup-hooks)
+ quit-hooks
+ nil)))
+
+;;; Functions to start Emerge from the command line
+
+;;;###autoload
+(defun emerge-files-command ()
+ (let ((file-a (nth 0 command-line-args-left))
+ (file-b (nth 1 command-line-args-left))
+ (file-out (nth 2 command-line-args-left)))
+ (setq command-line-args-left (nthcdr 3 command-line-args-left))
+ (emerge-files-internal
+ file-a file-b nil
+ (list `(lambda () (emerge-command-exit ,file-out))))))
+
+;;;###autoload
+(defun emerge-files-with-ancestor-command ()
+ (let (file-a file-b file-anc file-out)
+ ;; check for a -a flag, for filemerge compatibility
+ (if (string= (car command-line-args-left) "-a")
+ ;; arguments are "-a ancestor file-a file-b file-out"
+ (progn
+ (setq file-a (nth 2 command-line-args-left))
+ (setq file-b (nth 3 command-line-args-left))
+ (setq file-anc (nth 1 command-line-args-left))
+ (setq file-out (nth 4 command-line-args-left))
+ (setq command-line-args-left (nthcdr 5 command-line-args-left)))
+ ;; arguments are "file-a file-b ancestor file-out"
+ (setq file-a (nth 0 command-line-args-left))
+ (setq file-b (nth 1 command-line-args-left))
+ (setq file-anc (nth 2 command-line-args-left))
+ (setq file-out (nth 3 command-line-args-left))
+ (setq command-line-args-left (nthcdr 4 command-line-args-left)))
+ (emerge-files-with-ancestor-internal
+ file-a file-b file-anc nil
+ (list `(lambda () (emerge-command-exit ,file-out))))))
+
+(defun emerge-command-exit (file-out)
+ (emerge-write-and-delete file-out)
+ (kill-emacs (if emerge-prefix-argument 1 0)))
+
+;;; Functions to start Emerge via remote request
+
+;;;###autoload
+(defun emerge-files-remote (file-a file-b file-out)
+ (setq emerge-file-out file-out)
+ (emerge-files-internal
+ file-a file-b nil
+ (list `(lambda () (emerge-remote-exit ,file-out ',emerge-exit-func)))
+ file-out)
+ (throw 'client-wait nil))
+
+;;;###autoload
+(defun emerge-files-with-ancestor-remote (file-a file-b file-anc file-out)
+ (setq emerge-file-out file-out)
+ (emerge-files-with-ancestor-internal
+ file-a file-b file-anc nil
+ (list `(lambda () (emerge-remote-exit ,file-out ',emerge-exit-func)))
+ file-out)
+ (throw 'client-wait nil))
+
+(defun emerge-remote-exit (file-out emerge-exit-func)
+ (emerge-write-and-delete file-out)
+ (kill-buffer emerge-merge-buffer)
+ (funcall emerge-exit-func (if emerge-prefix-argument 1 0)))
+
+;;; Functions to start Emerge on RCS versions
+
+;;;###autoload
+(defun emerge-revisions (arg file revision-A revision-B
+ &optional startup-hooks quit-hooks)
+ "Emerge two RCS revisions of a file."
+ (interactive
+ (list current-prefix-arg
+ (read-file-name "File to merge: " nil nil 'confirm)
+ (read-string "Revision A to merge: " emerge-last-revision-A)
+ (read-string "Revision B to merge: " emerge-last-revision-B)))
+ (setq emerge-last-revision-A revision-A
+ emerge-last-revision-B revision-B)
+ (emerge-revisions-internal
+ file revision-A revision-B startup-hooks
+ (if arg
+ (cons `(lambda ()
+ (shell-command
+ ,(format "%s %s" emerge-rcs-ci-program file)))
+ quit-hooks)
+ quit-hooks)))
+
+;;;###autoload
+(defun emerge-revisions-with-ancestor (arg file revision-A
+ revision-B ancestor
+ &optional
+ startup-hooks quit-hooks)
+ "Emerge two RCS revisions of a file, with another revision as ancestor."
+ (interactive
+ (list current-prefix-arg
+ (read-file-name "File to merge: " nil nil 'confirm)
+ (read-string "Revision A to merge: " emerge-last-revision-A)
+ (read-string "Revision B to merge: " emerge-last-revision-B)
+ (read-string "Ancestor: " emerge-last-revision-ancestor)))
+ (setq emerge-last-revision-A revision-A
+ emerge-last-revision-B revision-B
+ emerge-last-revision-ancestor ancestor)
+ (emerge-revision-with-ancestor-internal
+ file revision-A revision-B ancestor startup-hooks
+ (if arg
+ (let ((cmd ))
+ (cons `(lambda ()
+ (shell-command
+ ,(format "%s %s" emerge-rcs-ci-program file)))
+ quit-hooks))
+ quit-hooks)))
+
+(defun emerge-revisions-internal (file revision-A revision-B &optional
+ startup-hooks quit-hooks output-file)
+ (let ((buffer-A (get-buffer-create (format "%s,%s" file revision-A)))
+ (buffer-B (get-buffer-create (format "%s,%s" file revision-B)))
+ (emerge-file-A (emerge-make-temp-file "A"))
+ (emerge-file-B (emerge-make-temp-file "B")))
+ ;; Get the revisions into buffers
+ (emerge-eval-in-buffer
+ buffer-A
+ (erase-buffer)
+ (shell-command
+ (format "%s -q -p%s %s" emerge-rcs-co-program revision-A file)
+ t)
+ (write-region (point-min) (point-max) emerge-file-A nil 'no-message)
+ (set-buffer-modified-p nil))
+ (emerge-eval-in-buffer
+ buffer-B
+ (erase-buffer)
+ (shell-command
+ (format "%s -q -p%s %s" emerge-rcs-co-program revision-B file)
+ t)
+ (write-region (point-min) (point-max) emerge-file-B nil 'no-message)
+ (set-buffer-modified-p nil))
+ ;; Do the merge
+ (emerge-setup buffer-A emerge-file-A
+ buffer-B emerge-file-B
+ (cons `(lambda ()
+ (delete-file ,emerge-file-A)
+ (delete-file ,emerge-file-B))
+ startup-hooks)
+ (cons `(lambda () (emerge-files-exit ,file))
+ quit-hooks)
+ nil)))
+
+(defun emerge-revision-with-ancestor-internal (file revision-A revision-B
+ ancestor
+ &optional startup-hooks
+ quit-hooks output-file)
+ (let ((buffer-A (get-buffer-create (format "%s,%s" file revision-A)))
+ (buffer-B (get-buffer-create (format "%s,%s" file revision-B)))
+ (buffer-ancestor (get-buffer-create (format "%s,%s" file ancestor)))
+ (emerge-file-A (emerge-make-temp-file "A"))
+ (emerge-file-B (emerge-make-temp-file "B"))
+ (emerge-ancestor (emerge-make-temp-file "ancestor")))
+ ;; Get the revisions into buffers
+ (emerge-eval-in-buffer
+ buffer-A
+ (erase-buffer)
+ (shell-command
+ (format "%s -q -p%s %s" emerge-rcs-co-program
+ revision-A file)
+ t)
+ (write-region (point-min) (point-max) emerge-file-A nil 'no-message)
+ (set-buffer-modified-p nil))
+ (emerge-eval-in-buffer
+ buffer-B
+ (erase-buffer)
+ (shell-command
+ (format "%s -q -p%s %s" emerge-rcs-co-program revision-B file)
+ t)
+ (write-region (point-min) (point-max) emerge-file-B nil 'no-message)
+ (set-buffer-modified-p nil))
+ (emerge-eval-in-buffer
+ buffer-ancestor
+ (erase-buffer)
+ (shell-command
+ (format "%s -q -p%s %s" emerge-rcs-co-program ancestor file)
+ t)
+ (write-region (point-min) (point-max) emerge-ancestor nil 'no-message)
+ (set-buffer-modified-p nil))
+ ;; Do the merge
+ (emerge-setup-with-ancestor
+ buffer-A emerge-file-A buffer-B emerge-file-B
+ buffer-ancestor emerge-ancestor
+ (cons `(lambda ()
+ (delete-file ,emerge-file-A)
+ (delete-file ,emerge-file-B)
+ (delete-file ,emerge-ancestor))
+ startup-hooks)
+ (cons `(lambda () (emerge-files-exit ,file))
+ quit-hooks)
+ output-file)))
+
+;;; Function to start Emerge based on a line in a file
+
+(defun emerge-execute-line ()
+ "Run Emerge using files named in current text line.
+Looks in that line for whitespace-separated entries of these forms:
+ a=file1
+ b=file2
+ ancestor=file3
+ output=file4
+to specify the files to use in Emerge.
+
+In addition, if only one of `a=file' or `b=file' is present, and `output=file'
+is present:
+If `emerge-execute-line-deletions' is non-nil and `ancestor=file' is present,
+it is assumed that the file in question has been deleted, and it is
+not copied to the output file.
+Otherwise, the A or B file present is copied to the output file."
+ (interactive)
+ (let (file-A file-B file-ancestor file-out
+ (case-fold-search t))
+ ;; Stop if at end of buffer (even though we might be in a line, if
+ ;; the line does not end with newline)
+ (if (eobp)
+ (error "At end of buffer"))
+ ;; Go to the beginning of the line
+ (beginning-of-line)
+ ;; Skip any initial whitespace
+ (if (looking-at "[ \t]*")
+ (goto-char (match-end 0)))
+ ;; Process the entire line
+ (while (not (eolp))
+ ;; Get the next entry
+ (if (looking-at "\\([a-z]+\\)=\\([^ \t\n]+\\)[ \t]*")
+ ;; Break apart the tab (before =) and the filename (after =)
+ (let ((tag (downcase
+ (buffer-substring (match-beginning 1) (match-end 1))))
+ (file (buffer-substring (match-beginning 2) (match-end 2))))
+ ;; Move point after the entry
+ (goto-char (match-end 0))
+ ;; Store the filename in the right variable
+ (cond
+ ((string-equal tag "a")
+ (if file-A
+ (error "This line has two `A' entries"))
+ (setq file-A file))
+ ((string-equal tag "b")
+ (if file-B
+ (error "This line has two `B' entries"))
+ (setq file-B file))
+ ((or (string-equal tag "anc") (string-equal tag "ancestor"))
+ (if file-ancestor
+ (error "This line has two `ancestor' entries"))
+ (setq file-ancestor file))
+ ((or (string-equal tag "out") (string-equal tag "output"))
+ (if file-out
+ (error "This line has two `output' entries"))
+ (setq file-out file))
+ (t
+ (error "Unrecognized entry"))))
+ ;; If the match on the entry pattern failed
+ (error "Unparsable entry")))
+ ;; Make sure that file-A and file-B are present
+ (if (not (or (and file-A file-B) file-out))
+ (error "Must have both `A' and `B' entries"))
+ (if (not (or file-A file-B))
+ (error "Must have `A' or `B' entry"))
+ ;; Go to the beginning of the next line, so next execution will use
+ ;; next line in buffer.
+ (beginning-of-line 2)
+ ;; Execute the correct command
+ (cond
+ ;; Merge of two files with ancestor
+ ((and file-A file-B file-ancestor)
+ (message "Merging %s and %s..." file-A file-B)
+ (emerge-files-with-ancestor (not (not file-out)) file-A file-B
+ file-ancestor file-out
+ nil
+ ;; When done, return to this buffer.
+ (list
+ `(lambda ()
+ (switch-to-buffer ,(current-buffer))
+ (message "Merge done.")))))
+ ;; Merge of two files without ancestor
+ ((and file-A file-B)
+ (message "Merging %s and %s..." file-A file-B)
+ (emerge-files (not (not file-out)) file-A file-B file-out
+ nil
+ ;; When done, return to this buffer.
+ (list
+ `(lambda ()
+ (switch-to-buffer ,(current-buffer))
+ (message "Merge done.")))))
+ ;; There is an output file (or there would have been an error above),
+ ;; but only one input file.
+ ;; The file appears to have been deleted in one version; do nothing.
+ ((and file-ancestor emerge-execute-line-deletions)
+ (message "No action."))
+ ;; The file should be copied from the version that contains it
+ (t (let ((input-file (or file-A file-B)))
+ (message "Copying...")
+ (copy-file input-file file-out)
+ (message "%s copied to %s." input-file file-out))))))
+
+;;; Sample function for creating information for emerge-execute-line
+
+(defcustom emerge-merge-directories-filename-regexp "[^.]"
+ "Regexp describing files to be processed by `emerge-merge-directories'."
+ :type 'regexp
+ :group 'emerge)
+
+;;;###autoload
+(defun emerge-merge-directories (a-dir b-dir ancestor-dir output-dir)
+ (interactive
+ (list
+ (read-file-name "A directory: " nil nil 'confirm)
+ (read-file-name "B directory: " nil nil 'confirm)
+ (read-file-name "Ancestor directory (null for none): " nil nil 'confirm)
+ (read-file-name "Output directory (null for none): " nil nil 'confirm)))
+ ;; Check that we're not on a line
+ (if (not (and (bolp) (eolp)))
+ (error "There is text on this line"))
+ ;; Turn null strings into nil to indicate directories not used.
+ (if (and ancestor-dir (string-equal ancestor-dir ""))
+ (setq ancestor-dir nil))
+ (if (and output-dir (string-equal output-dir ""))
+ (setq output-dir nil))
+ ;; Canonicalize the directory names
+ (setq a-dir (expand-file-name a-dir))
+ (if (not (string-equal (substring a-dir -1) "/"))
+ (setq a-dir (concat a-dir "/")))
+ (setq b-dir (expand-file-name b-dir))
+ (if (not (string-equal (substring b-dir -1) "/"))
+ (setq b-dir (concat b-dir "/")))
+ (if ancestor-dir
+ (progn
+ (setq ancestor-dir (expand-file-name ancestor-dir))
+ (if (not (string-equal (substring ancestor-dir -1) "/"))
+ (setq ancestor-dir (concat ancestor-dir "/")))))
+ (if output-dir
+ (progn
+ (setq output-dir (expand-file-name output-dir))
+ (if (not (string-equal (substring output-dir -1) "/"))
+ (setq output-dir (concat output-dir "/")))))
+ ;; Set the mark to where we start
+ (push-mark)
+ ;; Find out what files are in the directories.
+ (let* ((a-dir-files
+ (directory-files a-dir nil emerge-merge-directories-filename-regexp))
+ (b-dir-files
+ (directory-files b-dir nil emerge-merge-directories-filename-regexp))
+ (ancestor-dir-files
+ (and ancestor-dir
+ (directory-files ancestor-dir nil
+ emerge-merge-directories-filename-regexp)))
+ (all-files (sort (nconc (copy-sequence a-dir-files)
+ (copy-sequence b-dir-files)
+ (copy-sequence ancestor-dir-files))
+ (function string-lessp))))
+ ;; Remove duplicates from all-files.
+ (let ((p all-files))
+ (while p
+ (if (and (cdr p) (string-equal (car p) (car (cdr p))))
+ (setcdr p (cdr (cdr p)))
+ (setq p (cdr p)))))
+ ;; Generate the control lines for the various files.
+ (while all-files
+ (let ((f (car all-files)))
+ (setq all-files (cdr all-files))
+ (if (and a-dir-files (string-equal (car a-dir-files) f))
+ (progn
+ (insert "A=" a-dir f "\t")
+ (setq a-dir-files (cdr a-dir-files))))
+ (if (and b-dir-files (string-equal (car b-dir-files) f))
+ (progn
+ (insert "B=" b-dir f "\t")
+ (setq b-dir-files (cdr b-dir-files))))
+ (if (and ancestor-dir-files (string-equal (car ancestor-dir-files) f))
+ (progn
+ (insert "ancestor=" ancestor-dir f "\t")
+ (setq ancestor-dir-files (cdr ancestor-dir-files))))
+ (if output-dir
+ (insert "output=" output-dir f "\t"))
+ (backward-delete-char 1)
+ (insert "\n")))))
+
+;;; Common setup routines
+
+;; Set up the window configuration. If POS is given, set the points to
+;; the beginnings of the buffers.
+(defun emerge-setup-windows (buffer-A buffer-B merge-buffer &optional pos)
+ ;; Make sure we are not in the minibuffer window when we try to delete
+ ;; all other windows.
+ (if (eq (selected-window) (minibuffer-window))
+ (other-window 1))
+ (delete-other-windows)
+ (switch-to-buffer merge-buffer)
+ (emerge-refresh-mode-line)
+ (split-window-vertically)
+ (split-window-horizontally)
+ (switch-to-buffer buffer-A)
+ (if pos
+ (goto-char (point-min)))
+ (other-window 1)
+ (switch-to-buffer buffer-B)
+ (if pos
+ (goto-char (point-min)))
+ (other-window 1)
+ (if pos
+ (goto-char (point-min)))
+ ;; If diff/diff3 reports errors, display them rather than the merge buffer.
+ (if (/= 0 (emerge-eval-in-buffer emerge-diff-error-buffer (buffer-size)))
+ (progn
+ (ding)
+ (message "Errors found in diff/diff3 output. Merge buffer is %s."
+ (buffer-name emerge-merge-buffer))
+ (switch-to-buffer emerge-diff-error-buffer))))
+
+;; Set up the keymap in the merge buffer
+(defun emerge-set-keys ()
+ ;; Set up fixed keymaps if necessary
+ (if (not emerge-basic-keymap)
+ (emerge-setup-fixed-keymaps))
+ ;; Save the old local map
+ (setq emerge-old-keymap (current-local-map))
+ ;; Construct the edit keymap
+ (setq emerge-edit-keymap (if emerge-old-keymap
+ (copy-keymap emerge-old-keymap)
+ (make-sparse-keymap)))
+ ;; Install the Emerge commands
+ (emerge-force-define-key emerge-edit-keymap emerge-command-prefix
+ 'emerge-basic-keymap)
+ (define-key emerge-edit-keymap [menu-bar] (make-sparse-keymap))
+
+ ;; Create the additional menu bar items.
+ (define-key emerge-edit-keymap [menu-bar emerge-options]
+ (cons "Merge-Options" emerge-options-menu))
+ (define-key emerge-edit-keymap [menu-bar merge]
+ (cons "Merge" emerge-merge-menu))
+ (define-key emerge-edit-keymap [menu-bar move]
+ (cons "Move" emerge-move-menu))
+
+ ;; Suppress write-file and save-buffer
+ (substitute-key-definition 'write-file
+ 'emerge-query-write-file
+ emerge-edit-keymap)
+ (substitute-key-definition 'save-buffer
+ 'emerge-query-save-buffer
+ emerge-edit-keymap)
+ (define-key emerge-edit-keymap [remap write-file] 'emerge-query-write-file)
+ (define-key emerge-edit-keymap [remap save-buffer] 'emerge-query-save-buffer)
+ (use-local-map emerge-fast-keymap)
+ (setq emerge-edit-mode nil)
+ (setq emerge-fast-mode t))
+
+(defun emerge-remember-buffer-characteristics ()
+ "Record certain properties of the buffers being merged.
+Must be called in the merge buffer. Remembers read-only, modified,
+auto-save, and saves them in buffer local variables. Sets the buffers
+read-only and turns off `auto-save-mode'.
+These characteristics are restored by `emerge-restore-buffer-characteristics'."
+ ;; force auto-save, because we will turn off auto-saving in buffers for the
+ ;; duration
+ (do-auto-save)
+ ;; remember and alter buffer characteristics
+ (setq emerge-A-buffer-values
+ (emerge-eval-in-buffer
+ emerge-A-buffer
+ (prog1
+ (emerge-save-variables emerge-saved-variables)
+ (emerge-restore-variables emerge-saved-variables
+ emerge-merging-values))))
+ (setq emerge-B-buffer-values
+ (emerge-eval-in-buffer
+ emerge-B-buffer
+ (prog1
+ (emerge-save-variables emerge-saved-variables)
+ (emerge-restore-variables emerge-saved-variables
+ emerge-merging-values)))))
+
+(defun emerge-restore-buffer-characteristics ()
+ "Restore characteristics saved by `emerge-remember-buffer-characteristics'."
+ (let ((A-values emerge-A-buffer-values)
+ (B-values emerge-B-buffer-values))
+ (emerge-eval-in-buffer emerge-A-buffer
+ (emerge-restore-variables emerge-saved-variables
+ A-values))
+ (emerge-eval-in-buffer emerge-B-buffer
+ (emerge-restore-variables emerge-saved-variables
+ B-values))))
+
+;; Move to line DESIRED-LINE assuming we are at line CURRENT-LINE.
+;; Return DESIRED-LINE.
+(defun emerge-goto-line (desired-line current-line)
+ (forward-line (- desired-line current-line))
+ desired-line)
+
+(defun emerge-convert-diffs-to-markers (A-buffer
+ B-buffer
+ merge-buffer
+ lineno-list)
+ (let* (marker-list
+ (A-point-min (emerge-eval-in-buffer A-buffer (point-min)))
+ (offset (1- A-point-min))
+ (B-point-min (emerge-eval-in-buffer B-buffer (point-min)))
+ ;; Record current line number in each buffer
+ ;; so we don't have to count from the beginning.
+ (a-line 1)
+ (b-line 1))
+ (emerge-eval-in-buffer A-buffer (goto-char (point-min)))
+ (emerge-eval-in-buffer B-buffer (goto-char (point-min)))
+ (while lineno-list
+ (let* ((list-element (car lineno-list))
+ a-begin-marker
+ a-end-marker
+ b-begin-marker
+ b-end-marker
+ merge-begin-marker
+ merge-end-marker
+ (a-begin (aref list-element 0))
+ (a-end (aref list-element 1))
+ (b-begin (aref list-element 2))
+ (b-end (aref list-element 3))
+ (state (aref list-element 4)))
+ ;; place markers at the appropriate places in the buffers
+ (emerge-eval-in-buffer
+ A-buffer
+ (setq a-line (emerge-goto-line a-begin a-line))
+ (setq a-begin-marker (point-marker))
+ (setq a-line (emerge-goto-line a-end a-line))
+ (setq a-end-marker (point-marker)))
+ (emerge-eval-in-buffer
+ B-buffer
+ (setq b-line (emerge-goto-line b-begin b-line))
+ (setq b-begin-marker (point-marker))
+ (setq b-line (emerge-goto-line b-end b-line))
+ (setq b-end-marker (point-marker)))
+ (setq merge-begin-marker (set-marker
+ (make-marker)
+ (- (marker-position a-begin-marker)
+ offset)
+ merge-buffer))
+ (setq merge-end-marker (set-marker
+ (make-marker)
+ (- (marker-position a-end-marker)
+ offset)
+ merge-buffer))
+ ;; record all the markers for this difference
+ (setq marker-list (cons (vector a-begin-marker a-end-marker
+ b-begin-marker b-end-marker
+ merge-begin-marker merge-end-marker
+ state)
+ marker-list)))
+ (setq lineno-list (cdr lineno-list)))
+ ;; convert the list of difference information into a vector for
+ ;; fast access
+ (setq emerge-difference-list (apply 'vector (nreverse marker-list)))))
+
+;; If we have an ancestor, select all B variants that we prefer
+(defun emerge-select-prefer-Bs ()
+ (let ((n 0))
+ (while (< n emerge-number-of-differences)
+ (if (eq (aref (aref emerge-difference-list n) 6) 'prefer-B)
+ (progn
+ (emerge-unselect-and-select-difference n t)
+ (emerge-select-B)
+ (aset (aref emerge-difference-list n) 6 'prefer-B)))
+ (setq n (1+ n))))
+ (emerge-unselect-and-select-difference -1))
+
+;; Process the local-variables list at the end of the merged file, if
+;; requested.
+(defun emerge-handle-local-variables ()
+ (if emerge-process-local-variables
+ (condition-case err
+ (hack-local-variables)
+ (error (message "Local-variables error in merge buffer: %s"
+ (prin1-to-string err))))))
+
+;;; Common exit routines
+
+(defun emerge-write-and-delete (file-out)
+ ;; clear screen format
+ (delete-other-windows)
+ ;; delete A, B, and ancestor buffers, if they haven't been changed
+ (if (not (buffer-modified-p emerge-A-buffer))
+ (kill-buffer emerge-A-buffer))
+ (if (not (buffer-modified-p emerge-B-buffer))
+ (kill-buffer emerge-B-buffer))
+ (if (and emerge-ancestor-buffer
+ (not (buffer-modified-p emerge-ancestor-buffer)))
+ (kill-buffer emerge-ancestor-buffer))
+ ;; Write merge buffer to file
+ (and file-out
+ (write-file file-out)))
+
+;;; Commands
+
+(defun emerge-recenter (&optional arg)
+ "Bring the highlighted region of all three merge buffers into view.
+This brings the buffers into view if they are in windows.
+With an argument, reestablish the default three-window display."
+ (interactive "P")
+ ;; If there is an argument, rebuild the window structure
+ (if arg
+ (emerge-setup-windows emerge-A-buffer emerge-B-buffer
+ emerge-merge-buffer))
+ ;; Redisplay whatever buffers are showing, if there is a selected difference
+ (if (and (>= emerge-current-difference 0)
+ (< emerge-current-difference emerge-number-of-differences))
+ (let* ((merge-buffer emerge-merge-buffer)
+ (buffer-A emerge-A-buffer)
+ (buffer-B emerge-B-buffer)
+ (window-A (get-buffer-window buffer-A 'visible))
+ (window-B (get-buffer-window buffer-B 'visible))
+ (merge-window (get-buffer-window merge-buffer))
+ (diff-vector
+ (aref emerge-difference-list emerge-current-difference)))
+ (if window-A (progn
+ (select-window window-A)
+ (emerge-position-region
+ (- (aref diff-vector 0)
+ (1- emerge-before-flag-length))
+ (+ (aref diff-vector 1)
+ (1- emerge-after-flag-length))
+ (1+ (aref diff-vector 0)))))
+ (if window-B (progn
+ (select-window window-B)
+ (emerge-position-region
+ (- (aref diff-vector 2)
+ (1- emerge-before-flag-length))
+ (+ (aref diff-vector 3)
+ (1- emerge-after-flag-length))
+ (1+ (aref diff-vector 2)))))
+ (if merge-window (progn
+ (select-window merge-window)
+ (emerge-position-region
+ (- (aref diff-vector 4)
+ (1- emerge-before-flag-length))
+ (+ (aref diff-vector 5)
+ (1- emerge-after-flag-length))
+ (1+ (aref diff-vector 4))))))))
+
+;;; Window scrolling operations
+;; These operations are designed to scroll all three windows the same amount,
+;; so as to keep the text in them aligned.
+
+;; Perform some operation on all three windows (if they are showing).
+;; Catches all errors on the operation in the A and B windows, but not
+;; in the merge window. Usually, errors come from scrolling off the
+;; beginning or end of the buffer, and this gives a nice error message:
+;; End of buffer is reported in the merge buffer, but if the scroll was
+;; possible in the A or B windows, it is performed there before the error
+;; is reported.
+(defun emerge-operate-on-windows (operation arg)
+ (let* ((merge-buffer emerge-merge-buffer)
+ (buffer-A emerge-A-buffer)
+ (buffer-B emerge-B-buffer)
+ (window-A (get-buffer-window buffer-A 'visible))
+ (window-B (get-buffer-window buffer-B 'visible))
+ (merge-window (get-buffer-window merge-buffer)))
+ (if window-A (progn
+ (select-window window-A)
+ (condition-case nil
+ (funcall operation arg)
+ (error))))
+ (if window-B (progn
+ (select-window window-B)
+ (condition-case nil
+ (funcall operation arg)
+ (error))))
+ (if merge-window (progn
+ (select-window merge-window)
+ (funcall operation arg)))))
+
+(defun emerge-scroll-up (&optional arg)
+ "Scroll up all three merge buffers, if they are in windows.
+With argument N, scroll N lines; otherwise scroll by nearly
+the height of the merge window.
+`C-u -' alone as argument scrolls half the height of the merge window."
+ (interactive "P")
+ (emerge-operate-on-windows
+ 'scroll-up
+ ;; calculate argument to scroll-up
+ ;; if there is an explicit argument
+ (if (and arg (not (equal arg '-)))
+ ;; use it
+ (prefix-numeric-value arg)
+ ;; if not, see if we can determine a default amount (the window height)
+ (let ((merge-window (get-buffer-window emerge-merge-buffer)))
+ (if (null merge-window)
+ ;; no window, use nil
+ nil
+ (let ((default-amount
+ (- (window-height merge-window) 1 next-screen-context-lines)))
+ ;; the window was found
+ (if arg
+ ;; C-u as argument means half of default amount
+ (/ default-amount 2)
+ ;; no argument means default amount
+ default-amount)))))))
+
+(defun emerge-scroll-down (&optional arg)
+ "Scroll down all three merge buffers, if they are in windows.
+With argument N, scroll N lines; otherwise scroll by nearly
+the height of the merge window.
+`C-u -' alone as argument scrolls half the height of the merge window."
+ (interactive "P")
+ (emerge-operate-on-windows
+ 'scroll-down
+ ;; calculate argument to scroll-down
+ ;; if there is an explicit argument
+ (if (and arg (not (equal arg '-)))
+ ;; use it
+ (prefix-numeric-value arg)
+ ;; if not, see if we can determine a default amount (the window height)
+ (let ((merge-window (get-buffer-window emerge-merge-buffer)))
+ (if (null merge-window)
+ ;; no window, use nil
+ nil
+ (let ((default-amount
+ (- (window-height merge-window) 1 next-screen-context-lines)))
+ ;; the window was found
+ (if arg
+ ;; C-u as argument means half of default amount
+ (/ default-amount 2)
+ ;; no argument means default amount
+ default-amount)))))))
+
+(defun emerge-scroll-left (&optional arg)
+ "Scroll left all three merge buffers, if they are in windows.
+If an argument is given, that is how many columns are scrolled, else nearly
+the width of the A and B windows. `C-u -' alone as argument scrolls half the
+width of the A and B windows."
+ (interactive "P")
+ (emerge-operate-on-windows
+ 'scroll-left
+ ;; calculate argument to scroll-left
+ ;; if there is an explicit argument
+ (if (and arg (not (equal arg '-)))
+ ;; use it
+ (prefix-numeric-value arg)
+ ;; if not, see if we can determine a default amount
+ ;; (half the window width)
+ (let ((merge-window (get-buffer-window emerge-merge-buffer)))
+ (if (null merge-window)
+ ;; no window, use nil
+ nil
+ (let ((default-amount
+ (- (/ (window-width merge-window) 2) 3)))
+ ;; the window was found
+ (if arg
+ ;; C-u as argument means half of default amount
+ (/ default-amount 2)
+ ;; no argument means default amount
+ default-amount)))))))
+
+(defun emerge-scroll-right (&optional arg)
+ "Scroll right all three merge buffers, if they are in windows.
+If an argument is given, that is how many columns are scrolled, else nearly
+the width of the A and B windows. `C-u -' alone as argument scrolls half the
+width of the A and B windows."
+ (interactive "P")
+ (emerge-operate-on-windows
+ 'scroll-right
+ ;; calculate argument to scroll-right
+ ;; if there is an explicit argument
+ (if (and arg (not (equal arg '-)))
+ ;; use it
+ (prefix-numeric-value arg)
+ ;; if not, see if we can determine a default amount
+ ;; (half the window width)
+ (let ((merge-window (get-buffer-window emerge-merge-buffer)))
+ (if (null merge-window)
+ ;; no window, use nil
+ nil
+ (let ((default-amount
+ (- (/ (window-width merge-window) 2) 3)))
+ ;; the window was found
+ (if arg
+ ;; C-u as argument means half of default amount
+ (/ default-amount 2)
+ ;; no argument means default amount
+ default-amount)))))))
+
+(defun emerge-scroll-reset ()
+ "Reset horizontal scrolling in Emerge.
+This resets the horizontal scrolling of all three merge buffers
+to the left margin, if they are in windows."
+ (interactive)
+ (emerge-operate-on-windows
+ (function (lambda (x) (set-window-hscroll (selected-window) 0)))
+ nil))
+
+;; Attempt to show the region nicely.
+;; If there are min-lines lines above and below the region, then don't do
+;; anything.
+;; If not, recenter the region to make it so.
+;; If that isn't possible, remove context lines balancedly from top and bottom
+;; so the entire region shows.
+;; If that isn't possible, show the top of the region.
+;; BEG must be at the beginning of a line.
+(defun emerge-position-region (beg end pos)
+ ;; First test whether the entire region is visible with
+ ;; emerge-min-visible-lines above and below it
+ (if (not (and (<= (progn
+ (move-to-window-line emerge-min-visible-lines)
+ (point))
+ beg)
+ (<= end (progn
+ (move-to-window-line
+ (- (1+ emerge-min-visible-lines)))
+ (point)))))
+ ;; We failed that test, see if it fits at all
+ ;; Meanwhile positioning it correctly in case it doesn't fit
+ (progn
+ (set-window-start (selected-window) beg)
+ (if (pos-visible-in-window-p end)
+ ;; Determine the number of lines that the region occupies
+ (let ((lines 0))
+ (while (> end (progn
+ (move-to-window-line lines)
+ (point)))
+ (setq lines (1+ lines)))
+ ;; And position the beginning on the right line
+ (goto-char beg)
+ (recenter (/ (1+ (- (1- (window-height (selected-window)))
+ lines))
+ 2))))))
+ (goto-char pos))
+
+(defun emerge-next-difference ()
+ "Advance to the next difference."
+ (interactive)
+ (if (< emerge-current-difference emerge-number-of-differences)
+ (let ((n (1+ emerge-current-difference)))
+ (while (and emerge-skip-prefers
+ (< n emerge-number-of-differences)
+ (memq (aref (aref emerge-difference-list n) 6)
+ '(prefer-A prefer-B)))
+ (setq n (1+ n)))
+ (let ((buffer-read-only nil))
+ (emerge-unselect-and-select-difference n)))
+ (error "At end")))
+
+(defun emerge-previous-difference ()
+ "Go to the previous difference."
+ (interactive)
+ (if (> emerge-current-difference -1)
+ (let ((n (1- emerge-current-difference)))
+ (while (and emerge-skip-prefers
+ (> n -1)
+ (memq (aref (aref emerge-difference-list n) 6)
+ '(prefer-A prefer-B)))
+ (setq n (1- n)))
+ (let ((buffer-read-only nil))
+ (emerge-unselect-and-select-difference n)))
+ (error "At beginning")))
+
+(defun emerge-jump-to-difference (difference-number)
+ "Go to the N-th difference."
+ (interactive "p")
+ (let ((buffer-read-only nil))
+ (setq difference-number (1- difference-number))
+ (if (and (>= difference-number -1)
+ (< difference-number (1+ emerge-number-of-differences)))
+ (emerge-unselect-and-select-difference difference-number)
+ (error "Bad difference number"))))
+
+(defun emerge-abort ()
+ "Abort the Emerge session."
+ (interactive)
+ (emerge-quit t))
+
+(defun emerge-quit (arg)
+ "Finish the Emerge session and exit Emerge.
+Prefix argument means to abort rather than successfully finish.
+The difference depends on how the merge was started,
+but usually means to not write over one of the original files, or to signal
+to some process which invoked Emerge a failure code.
+
+Unselects the selected difference, if any, restores the read-only and modified
+flags of the merged file buffers, restores the local keymap of the merge
+buffer, and sets off various emerge flags. Using Emerge commands in this
+buffer after this will cause serious problems."
+ (interactive "P")
+ (if (prog1
+ (y-or-n-p
+ (if (not arg)
+ "Do you really want to successfully finish this merge? "
+ "Do you really want to abort this merge? "))
+ (message ""))
+ (emerge-really-quit arg)))
+
+;; Perform the quit operations.
+(defun emerge-really-quit (arg)
+ (setq buffer-read-only nil)
+ (emerge-unselect-and-select-difference -1)
+ (emerge-restore-buffer-characteristics)
+ ;; null out the difference markers so they don't slow down future editing
+ ;; operations
+ (mapc (function (lambda (d)
+ (set-marker (aref d 0) nil)
+ (set-marker (aref d 1) nil)
+ (set-marker (aref d 2) nil)
+ (set-marker (aref d 3) nil)
+ (set-marker (aref d 4) nil)
+ (set-marker (aref d 5) nil)))
+ emerge-difference-list)
+ ;; allow them to be garbage collected
+ (setq emerge-difference-list nil)
+ ;; restore the local map
+ (use-local-map emerge-old-keymap)
+ ;; turn off all the emerge modes
+ (setq emerge-mode nil)
+ (setq emerge-fast-mode nil)
+ (setq emerge-edit-mode nil)
+ (setq emerge-auto-advance nil)
+ (setq emerge-skip-prefers nil)
+ ;; restore mode line
+ (kill-local-variable 'mode-line-buffer-identification)
+ (let ((emerge-prefix-argument arg))
+ (run-hooks 'emerge-quit-hook)))
+
+(defun emerge-select-A (&optional force)
+ "Select the A variant of this difference.
+Refuses to function if this difference has been edited, i.e., if it
+is neither the A nor the B variant.
+A prefix argument forces the variant to be selected
+even if the difference has been edited."
+ (interactive "P")
+ (let ((operate
+ (function (lambda ()
+ (emerge-select-A-edit merge-begin merge-end A-begin A-end)
+ (if emerge-auto-advance
+ (emerge-next-difference)))))
+ (operate-no-change
+ (function (lambda ()
+ (if emerge-auto-advance
+ (emerge-next-difference))))))
+ (emerge-select-version force operate-no-change operate operate)))
+
+;; Actually select the A variant
+(defun emerge-select-A-edit (merge-begin merge-end A-begin A-end)
+ (emerge-eval-in-buffer
+ emerge-merge-buffer
+ (delete-region merge-begin merge-end)
+ (goto-char merge-begin)
+ (insert-buffer-substring emerge-A-buffer A-begin A-end)
+ (goto-char merge-begin)
+ (aset diff-vector 6 'A)
+ (emerge-refresh-mode-line)))
+
+(defun emerge-select-B (&optional force)
+ "Select the B variant of this difference.
+Refuses to function if this difference has been edited, i.e., if it
+is neither the A nor the B variant.
+A prefix argument forces the variant to be selected
+even if the difference has been edited."
+ (interactive "P")
+ (let ((operate
+ (function (lambda ()
+ (emerge-select-B-edit merge-begin merge-end B-begin B-end)
+ (if emerge-auto-advance
+ (emerge-next-difference)))))
+ (operate-no-change
+ (function (lambda ()
+ (if emerge-auto-advance
+ (emerge-next-difference))))))
+ (emerge-select-version force operate operate-no-change operate)))
+
+;; Actually select the B variant
+(defun emerge-select-B-edit (merge-begin merge-end B-begin B-end)
+ (emerge-eval-in-buffer
+ emerge-merge-buffer
+ (delete-region merge-begin merge-end)
+ (goto-char merge-begin)
+ (insert-buffer-substring emerge-B-buffer B-begin B-end)
+ (goto-char merge-begin)
+ (aset diff-vector 6 'B)
+ (emerge-refresh-mode-line)))
+
+(defun emerge-default-A ()
+ "Make the A variant the default from here down.
+This selects the A variant for all differences from here down in the buffer
+which are still defaulted, i.e., which the user has not selected and for
+which there is no preference."
+ (interactive)
+ (let ((buffer-read-only nil))
+ (let ((selected-difference emerge-current-difference)
+ (n (max emerge-current-difference 0)))
+ (while (< n emerge-number-of-differences)
+ (let ((diff-vector (aref emerge-difference-list n)))
+ (if (eq (aref diff-vector 6) 'default-B)
+ (progn
+ (emerge-unselect-and-select-difference n t)
+ (emerge-select-A)
+ (aset diff-vector 6 'default-A))))
+ (setq n (1+ n))
+ (if (zerop (% n 10))
+ (message "Setting default to A...%d" n)))
+ (emerge-unselect-and-select-difference selected-difference)))
+ (message "Default choice is now A"))
+
+(defun emerge-default-B ()
+ "Make the B variant the default from here down.
+This selects the B variant for all differences from here down in the buffer
+which are still defaulted, i.e., which the user has not selected and for
+which there is no preference."
+ (interactive)
+ (let ((buffer-read-only nil))
+ (let ((selected-difference emerge-current-difference)
+ (n (max emerge-current-difference 0)))
+ (while (< n emerge-number-of-differences)
+ (let ((diff-vector (aref emerge-difference-list n)))
+ (if (eq (aref diff-vector 6) 'default-A)
+ (progn
+ (emerge-unselect-and-select-difference n t)
+ (emerge-select-B)
+ (aset diff-vector 6 'default-B))))
+ (setq n (1+ n))
+ (if (zerop (% n 10))
+ (message "Setting default to B...%d" n)))
+ (emerge-unselect-and-select-difference selected-difference)))
+ (message "Default choice is now B"))
+
+(defun emerge-fast-mode ()
+ "Set fast mode, for Emerge.
+In this mode ordinary Emacs commands are disabled, and Emerge commands
+need not be prefixed with \\<emerge-fast-keymap>\\[emerge-basic-keymap]."
+ (interactive)
+ (setq buffer-read-only t)
+ (use-local-map emerge-fast-keymap)
+ (setq emerge-mode t)
+ (setq emerge-fast-mode t)
+ (setq emerge-edit-mode nil)
+ (message "Fast mode set")
+ (force-mode-line-update))
+
+(defun emerge-edit-mode ()
+ "Set edit mode, for Emerge.
+In this mode ordinary Emacs commands are available, and Emerge commands
+must be prefixed with \\<emerge-fast-keymap>\\[emerge-basic-keymap]."
+ (interactive)
+ (setq buffer-read-only nil)
+ (use-local-map emerge-edit-keymap)
+ (setq emerge-mode t)
+ (setq emerge-fast-mode nil)
+ (setq emerge-edit-mode t)
+ (message "Edit mode set")
+ (force-mode-line-update))
+
+(defun emerge-auto-advance (arg)
+ "Toggle Auto-Advance mode, for Emerge.
+This mode causes `emerge-select-A' and `emerge-select-B' to automatically
+advance to the next difference.
+With a positive argument, turn on Auto-Advance mode.
+With a negative argument, turn off Auto-Advance mode."
+ (interactive "P")
+ (setq emerge-auto-advance (if (null arg)
+ (not emerge-auto-advance)
+ (> (prefix-numeric-value arg) 0)))
+ (message (if emerge-auto-advance
+ "Auto-advance set"
+ "Auto-advance cleared"))
+ (force-mode-line-update))
+
+(defun emerge-skip-prefers (arg)
+ "Toggle Skip-Prefers mode, for Emerge.
+This mode causes `emerge-next-difference' and `emerge-previous-difference'
+to automatically skip over differences for which there is a preference.
+With a positive argument, turn on Skip-Prefers mode.
+With a negative argument, turn off Skip-Prefers mode."
+ (interactive "P")
+ (setq emerge-skip-prefers (if (null arg)
+ (not emerge-skip-prefers)
+ (> (prefix-numeric-value arg) 0)))
+ (message (if emerge-skip-prefers
+ "Skip-prefers set"
+ "Skip-prefers cleared"))
+ (force-mode-line-update))
+
+(defun emerge-copy-as-kill-A ()
+ "Put the A variant of this difference in the kill ring."
+ (interactive)
+ (emerge-validate-difference)
+ (let* ((diff-vector
+ (aref emerge-difference-list emerge-current-difference))
+ (A-begin (1+ (aref diff-vector 0)))
+ (A-end (1- (aref diff-vector 1)))
+ ;; so further kills don't append
+ this-command)
+ (with-current-buffer emerge-A-buffer
+ (copy-region-as-kill A-begin A-end))))
+
+(defun emerge-copy-as-kill-B ()
+ "Put the B variant of this difference in the kill ring."
+ (interactive)
+ (emerge-validate-difference)
+ (let* ((diff-vector
+ (aref emerge-difference-list emerge-current-difference))
+ (B-begin (1+ (aref diff-vector 2)))
+ (B-end (1- (aref diff-vector 3)))
+ ;; so further kills don't append
+ this-command)
+ (with-current-buffer emerge-B-buffer
+ (copy-region-as-kill B-begin B-end))))
+
+(defun emerge-insert-A (arg)
+ "Insert the A variant of this difference at the point.
+Leaves point after text, mark before.
+With prefix argument, puts point before, mark after."
+ (interactive "P")
+ (emerge-validate-difference)
+ (let* ((diff-vector
+ (aref emerge-difference-list emerge-current-difference))
+ (A-begin (1+ (aref diff-vector 0)))
+ (A-end (1- (aref diff-vector 1)))
+ (opoint (point))
+ (buffer-read-only nil))
+ (insert-buffer-substring emerge-A-buffer A-begin A-end)
+ (if (not arg)
+ (set-mark opoint)
+ (set-mark (point))
+ (goto-char opoint))))
+
+(defun emerge-insert-B (arg)
+ "Insert the B variant of this difference at the point.
+Leaves point after text, mark before.
+With prefix argument, puts point before, mark after."
+ (interactive "P")
+ (emerge-validate-difference)
+ (let* ((diff-vector
+ (aref emerge-difference-list emerge-current-difference))
+ (B-begin (1+ (aref diff-vector 2)))
+ (B-end (1- (aref diff-vector 3)))
+ (opoint (point))
+ (buffer-read-only nil))
+ (insert-buffer-substring emerge-B-buffer B-begin B-end)
+ (if (not arg)
+ (set-mark opoint)
+ (set-mark (point))
+ (goto-char opoint))))
+
+(defun emerge-mark-difference (arg)
+ "Leaves the point before this difference and the mark after it.
+With prefix argument, puts mark before, point after."
+ (interactive "P")
+ (emerge-validate-difference)
+ (let* ((diff-vector
+ (aref emerge-difference-list emerge-current-difference))
+ (merge-begin (1+ (aref diff-vector 4)))
+ (merge-end (1- (aref diff-vector 5))))
+ (if (not arg)
+ (progn
+ (goto-char merge-begin)
+ (set-mark merge-end))
+ (goto-char merge-end)
+ (set-mark merge-begin))))
+
+(defun emerge-file-names ()
+ "Show the names of the buffers or files being operated on by Emerge.
+Use C-u l to reset the windows afterward."
+ (interactive)
+ (delete-other-windows)
+ (let ((temp-buffer-show-function
+ (function (lambda (buf)
+ (split-window-vertically)
+ (switch-to-buffer buf)
+ (other-window 1)))))
+ (with-output-to-temp-buffer "*Help*"
+ (emerge-eval-in-buffer emerge-A-buffer
+ (if buffer-file-name
+ (progn
+ (princ "File A is: ")
+ (princ buffer-file-name))
+ (progn
+ (princ "Buffer A is: ")
+ (princ (buffer-name))))
+ (princ "\n"))
+ (emerge-eval-in-buffer emerge-B-buffer
+ (if buffer-file-name
+ (progn
+ (princ "File B is: ")
+ (princ buffer-file-name))
+ (progn
+ (princ "Buffer B is: ")
+ (princ (buffer-name))))
+ (princ "\n"))
+ (if emerge-ancestor-buffer
+ (emerge-eval-in-buffer emerge-ancestor-buffer
+ (if buffer-file-name
+ (progn
+ (princ "Ancestor file is: ")
+ (princ buffer-file-name))
+ (progn
+ (princ "Ancestor buffer is: ")
+ (princ (buffer-name))))
+ (princ "\n")))
+ (princ emerge-output-description)
+ (with-current-buffer standard-output
+ (help-mode)))))
+
+(defun emerge-join-differences (arg)
+ "Join the selected difference with the following one.
+With a prefix argument, join with the preceding one."
+ (interactive "P")
+ (let ((n emerge-current-difference))
+ ;; adjust n to be first difference to join
+ (if arg
+ (setq n (1- n)))
+ ;; n and n+1 are the differences to join
+ ;; check that they are both differences
+ (if (or (< n 0) (>= n (1- emerge-number-of-differences)))
+ (error "Incorrect differences to join"))
+ ;; remove the flags
+ (emerge-unselect-difference emerge-current-difference)
+ ;; decrement total number of differences
+ (setq emerge-number-of-differences (1- emerge-number-of-differences))
+ ;; build new differences vector
+ (let ((i 0)
+ (new-differences (make-vector emerge-number-of-differences nil)))
+ (while (< i emerge-number-of-differences)
+ (aset new-differences i
+ (cond
+ ((< i n) (aref emerge-difference-list i))
+ ((> i n) (aref emerge-difference-list (1+ i)))
+ (t (let ((prev (aref emerge-difference-list i))
+ (next (aref emerge-difference-list (1+ i))))
+ (vector (aref prev 0)
+ (aref next 1)
+ (aref prev 2)
+ (aref next 3)
+ (aref prev 4)
+ (aref next 5)
+ (let ((ps (aref prev 6))
+ (ns (aref next 6)))
+ (cond
+ ((eq ps ns)
+ ps)
+ ((and (or (eq ps 'B) (eq ps 'prefer-B))
+ (or (eq ns 'B) (eq ns 'prefer-B)))
+ 'B)
+ (t 'A))))))))
+ (setq i (1+ i)))
+ (setq emerge-difference-list new-differences))
+ ;; set the current difference correctly
+ (setq emerge-current-difference n)
+ ;; fix the mode line
+ (emerge-refresh-mode-line)
+ ;; reinsert the flags
+ (emerge-select-difference emerge-current-difference)
+ (emerge-recenter)))
+
+(defun emerge-split-difference ()
+ "Split the current difference where the points are in the three windows."
+ (interactive)
+ (let ((n emerge-current-difference))
+ ;; check that this is a valid difference
+ (emerge-validate-difference)
+ ;; get the point values and old difference
+ (let ((A-point (emerge-eval-in-buffer emerge-A-buffer
+ (point-marker)))
+ (B-point (emerge-eval-in-buffer emerge-B-buffer
+ (point-marker)))
+ (merge-point (point-marker))
+ (old-diff (aref emerge-difference-list n)))
+ ;; check location of the points, give error if they aren't in the
+ ;; differences
+ (if (or (< A-point (aref old-diff 0))
+ (> A-point (aref old-diff 1)))
+ (error "Point outside of difference in A buffer"))
+ (if (or (< B-point (aref old-diff 2))
+ (> B-point (aref old-diff 3)))
+ (error "Point outside of difference in B buffer"))
+ (if (or (< merge-point (aref old-diff 4))
+ (> merge-point (aref old-diff 5)))
+ (error "Point outside of difference in merge buffer"))
+ ;; remove the flags
+ (emerge-unselect-difference emerge-current-difference)
+ ;; increment total number of differences
+ (setq emerge-number-of-differences (1+ emerge-number-of-differences))
+ ;; build new differences vector
+ (let ((i 0)
+ (new-differences (make-vector emerge-number-of-differences nil)))
+ (while (< i emerge-number-of-differences)
+ (aset new-differences i
+ (cond
+ ((< i n)
+ (aref emerge-difference-list i))
+ ((> i (1+ n))
+ (aref emerge-difference-list (1- i)))
+ ((= i n)
+ (vector (aref old-diff 0)
+ A-point
+ (aref old-diff 2)
+ B-point
+ (aref old-diff 4)
+ merge-point
+ (aref old-diff 6)))
+ (t
+ (vector (copy-marker A-point)
+ (aref old-diff 1)
+ (copy-marker B-point)
+ (aref old-diff 3)
+ (copy-marker merge-point)
+ (aref old-diff 5)
+ (aref old-diff 6)))))
+ (setq i (1+ i)))
+ (setq emerge-difference-list new-differences))
+ ;; set the current difference correctly
+ (setq emerge-current-difference n)
+ ;; fix the mode line
+ (emerge-refresh-mode-line)
+ ;; reinsert the flags
+ (emerge-select-difference emerge-current-difference)
+ (emerge-recenter))))
+
+(defun emerge-trim-difference ()
+ "Trim lines off top and bottom of difference that are the same.
+If lines are the same in both the A and the B versions, strip them off.
+\(This can happen when the A and B versions have common lines that the
+ancestor version does not share.)"
+ (interactive)
+ ;; make sure we are in a real difference
+ (emerge-validate-difference)
+ ;; remove the flags
+ (emerge-unselect-difference emerge-current-difference)
+ (let* ((diff (aref emerge-difference-list emerge-current-difference))
+ (top-a (marker-position (aref diff 0)))
+ (bottom-a (marker-position (aref diff 1)))
+ (top-b (marker-position (aref diff 2)))
+ (bottom-b (marker-position (aref diff 3)))
+ (top-m (marker-position (aref diff 4)))
+ (bottom-m (marker-position (aref diff 5)))
+ size success sa sb sm)
+ ;; move down the tops of the difference regions as much as possible
+ ;; Try advancing comparing 1000 chars at a time.
+ ;; When that fails, go 500 chars at a time, and so on.
+ (setq size 1000)
+ (while (> size 0)
+ (setq success t)
+ (while success
+ (setq size (min size (- bottom-a top-a) (- bottom-b top-b)
+ (- bottom-m top-m)))
+ (setq sa (emerge-eval-in-buffer emerge-A-buffer
+ (buffer-substring top-a
+ (+ size top-a))))
+ (setq sb (emerge-eval-in-buffer emerge-B-buffer
+ (buffer-substring top-b
+ (+ size top-b))))
+ (setq sm (buffer-substring top-m (+ size top-m)))
+ (setq success (and (> size 0) (equal sa sb) (equal sb sm)))
+ (if success
+ (setq top-a (+ top-a size)
+ top-b (+ top-b size)
+ top-m (+ top-m size))))
+ (setq size (/ size 2)))
+ ;; move up the bottoms of the difference regions as much as possible
+ ;; Try advancing comparing 1000 chars at a time.
+ ;; When that fails, go 500 chars at a time, and so on.
+ (setq size 1000)
+ (while (> size 0)
+ (setq success t)
+ (while success
+ (setq size (min size (- bottom-a top-a) (- bottom-b top-b)
+ (- bottom-m top-m)))
+ (setq sa (emerge-eval-in-buffer emerge-A-buffer
+ (buffer-substring (- bottom-a size)
+ bottom-a)))
+ (setq sb (emerge-eval-in-buffer emerge-B-buffer
+ (buffer-substring (- bottom-b size)
+ bottom-b)))
+ (setq sm (buffer-substring (- bottom-m size) bottom-m))
+ (setq success (and (> size 0) (equal sa sb) (equal sb sm)))
+ (if success
+ (setq bottom-a (- bottom-a size)
+ bottom-b (- bottom-b size)
+ bottom-m (- bottom-m size))))
+ (setq size (/ size 2)))
+ ;; {top,bottom}-{a,b,m} are now set at the new beginnings and ends
+ ;; of the difference regions. Move them to the beginning of lines, as
+ ;; appropriate.
+ (emerge-eval-in-buffer emerge-A-buffer
+ (goto-char top-a)
+ (beginning-of-line)
+ (aset diff 0 (point-marker))
+ (goto-char bottom-a)
+ (beginning-of-line 2)
+ (aset diff 1 (point-marker)))
+ (emerge-eval-in-buffer emerge-B-buffer
+ (goto-char top-b)
+ (beginning-of-line)
+ (aset diff 2 (point-marker))
+ (goto-char bottom-b)
+ (beginning-of-line 2)
+ (aset diff 3 (point-marker)))
+ (goto-char top-m)
+ (beginning-of-line)
+ (aset diff 4 (point-marker))
+ (goto-char bottom-m)
+ (beginning-of-line 2)
+ (aset diff 5 (point-marker))
+ ;; put the flags back in, recenter the display
+ (emerge-select-difference emerge-current-difference)
+ (emerge-recenter)))
+
+;; FIXME the manual advertised this as working in the A or B buffers,
+;; but it does not, because all the buffer locals are nil there.
+;; It would work to call it from the merge buffer and specify that one
+;; wants to use the value of point in the A or B buffer.
+;; But with the prefix argument already in use, there is no easy way
+;; to have it ask for a buffer.
+(defun emerge-find-difference (arg)
+ "Find the difference containing the current position of the point.
+If there is no containing difference and the prefix argument is positive,
+it finds the nearest following difference. A negative prefix argument finds
+the nearest previous difference."
+ (interactive "P")
+ (cond ((eq (current-buffer) emerge-A-buffer)
+ (emerge-find-difference-A arg))
+ ((eq (current-buffer) emerge-B-buffer)
+ (emerge-find-difference-B arg))
+ (t (emerge-find-difference-merge arg))))
+
+(defun emerge-find-difference-merge (arg)
+ "Find the difference containing point, in the merge buffer.
+If there is no containing difference and the prefix argument is positive,
+it finds the nearest following difference. A negative prefix argument finds
+the nearest previous difference."
+ (interactive "P")
+ ;; search for the point in the merge buffer, using the markers
+ ;; for the beginning and end of the differences in the merge buffer
+ (emerge-find-difference1 arg (point) 4 5))
+
+(defun emerge-find-difference-A (arg)
+ "Find the difference containing point, in the A buffer.
+This command must be executed in the merge buffer.
+If there is no containing difference and the prefix argument is positive,
+it finds the nearest following difference. A negative prefix argument finds
+the nearest previous difference."
+ (interactive "P")
+ ;; search for the point in the A buffer, using the markers
+ ;; for the beginning and end of the differences in the A buffer
+ (emerge-find-difference1 arg
+ (emerge-eval-in-buffer emerge-A-buffer (point))
+ 0 1))
+
+(defun emerge-find-difference-B (arg)
+ "Find the difference containing point, in the B buffer.
+This command must be executed in the merge buffer.
+If there is no containing difference and the prefix argument is positive,
+it finds the nearest following difference. A negative prefix argument finds
+the nearest previous difference."
+ (interactive "P")
+ ;; search for the point in the B buffer, using the markers
+ ;; for the beginning and end of the differences in the B buffer
+ (emerge-find-difference1 arg
+ (emerge-eval-in-buffer emerge-B-buffer (point))
+ 2 3))
+
+(defun emerge-find-difference1 (arg location begin end)
+ (let* ((index
+ ;; find first difference containing or after the current position
+ (catch 'search
+ (let ((n 0))
+ (while (< n emerge-number-of-differences)
+ (let ((diff-vector (aref emerge-difference-list n)))
+ (if (<= location (marker-position (aref diff-vector end)))
+ (throw 'search n)))
+ (setq n (1+ n))))
+ emerge-number-of-differences))
+ (contains
+ ;; whether the found difference contains the current position
+ (and (< index emerge-number-of-differences)
+ (<= (marker-position (aref (aref emerge-difference-list index)
+ begin))
+ location)))
+ (arg-value
+ ;; numeric value of prefix argument
+ (prefix-numeric-value arg)))
+ (emerge-unselect-and-select-difference
+ (cond
+ ;; if the point is in a difference, select it
+ (contains index)
+ ;; if the arg is nil and the point is not in a difference, error
+ ((null arg) (error "No difference contains point"))
+ ;; if the arg is positive, select the following difference
+ ((> arg-value 0)
+ (if (< index emerge-number-of-differences)
+ index
+ (error "No difference contains or follows point")))
+ ;; if the arg is negative, select the preceding difference
+ (t
+ (if (> index 0)
+ (1- index)
+ (error "No difference contains or precedes point")))))))
+
+(defun emerge-line-numbers ()
+ "Display the current line numbers.
+This function displays the line numbers of the points in the A, B, and
+merge buffers."
+ (interactive)
+ (let* ((valid-diff
+ (and (>= emerge-current-difference 0)
+ (< emerge-current-difference emerge-number-of-differences)))
+ (diff (and valid-diff
+ (aref emerge-difference-list emerge-current-difference)))
+ (merge-line (emerge-line-number-in-buf 4 5))
+ (A-line (emerge-eval-in-buffer emerge-A-buffer
+ (emerge-line-number-in-buf 0 1)))
+ (B-line (emerge-eval-in-buffer emerge-B-buffer
+ (emerge-line-number-in-buf 2 3))))
+ (message "At lines: merge = %d, A = %d, B = %d"
+ merge-line A-line B-line)))
+
+(defun emerge-line-number-in-buf (begin-marker end-marker)
+ (let (temp)
+ (setq temp (save-excursion
+ (beginning-of-line)
+ (1+ (count-lines 1 (point)))))
+ (if valid-diff
+ (progn
+ (if (> (point) (aref diff begin-marker))
+ (setq temp (- temp emerge-before-flag-lines)))
+ (if (> (point) (aref diff end-marker))
+ (setq temp (- temp emerge-after-flag-lines)))))
+ temp))
+
+(defun emerge-set-combine-template (string &optional localize)
+ "Set `emerge-combine-versions-template' to STRING.
+This value controls how `emerge-combine-versions' combines the two versions.
+With prefix argument, `emerge-combine-versions-template' is made local to this
+merge buffer. Localization is permanent for any particular merge buffer."
+ (interactive "s\nP")
+ (if localize
+ (make-local-variable 'emerge-combine-versions-template))
+ (setq emerge-combine-versions-template string)
+ (message
+ (if (assq 'emerge-combine-versions-template (buffer-local-variables))
+ "emerge-set-combine-versions-template set locally"
+ "emerge-set-combine-versions-template set")))
+
+(defun emerge-set-combine-versions-template (start end &optional localize)
+ "Copy region into `emerge-combine-versions-template'.
+This controls how `emerge-combine-versions' will combine the two versions.
+With prefix argument, `emerge-combine-versions-template' is made local to this
+merge buffer. Localization is permanent for any particular merge buffer."
+ (interactive "r\nP")
+ (if localize
+ (make-local-variable 'emerge-combine-versions-template))
+ (setq emerge-combine-versions-template (buffer-substring start end))
+ (message
+ (if (assq 'emerge-combine-versions-template (buffer-local-variables))
+ "emerge-set-combine-versions-template set locally."
+ "emerge-set-combine-versions-template set.")))
+
+(defun emerge-combine-versions (&optional force)
+ "Combine versions using the template in `emerge-combine-versions-template'.
+Refuses to function if this difference has been edited, i.e., if it is
+neither the A nor the B variant.
+An argument forces the variant to be selected even if the difference has
+been edited."
+ (interactive "P")
+ (emerge-combine-versions-internal emerge-combine-versions-template force))
+
+(defun emerge-combine-versions-register (char &optional force)
+ "Combine the two versions using the template in register REG.
+See documentation of the variable `emerge-combine-versions-template'
+for how the template is interpreted.
+Refuses to function if this difference has been edited, i.e., if it is
+neither the A nor the B variant.
+An argument forces the variant to be selected even if the difference has
+been edited."
+ (interactive "cRegister containing template: \nP")
+ (let ((template (get-register char)))
+ (if (not (stringp template))
+ (error "Register does not contain text"))
+ (emerge-combine-versions-internal template force)))
+
+(defun emerge-combine-versions-internal (template force)
+ (let ((operate
+ (function (lambda ()
+ (emerge-combine-versions-edit merge-begin merge-end
+ A-begin A-end B-begin B-end)
+ (if emerge-auto-advance
+ (emerge-next-difference))))))
+ (emerge-select-version force operate operate operate)))
+
+(defun emerge-combine-versions-edit (merge-begin merge-end
+ A-begin A-end B-begin B-end)
+ (emerge-eval-in-buffer
+ emerge-merge-buffer
+ (delete-region merge-begin merge-end)
+ (goto-char merge-begin)
+ (let ((i 0))
+ (while (< i (length template))
+ (let ((c (aref template i)))
+ (if (= c ?%)
+ (progn
+ (setq i (1+ i))
+ (setq c
+ (condition-case nil
+ (aref template i)
+ (error ?%)))
+ (cond ((= c ?a)
+ (insert-buffer-substring emerge-A-buffer A-begin A-end))
+ ((= c ?b)
+ (insert-buffer-substring emerge-B-buffer B-begin B-end))
+ ((= c ?%)
+ (insert ?%))
+ (t
+ (insert c))))
+ (insert c)))
+ (setq i (1+ i))))
+ (goto-char merge-begin)
+ (aset diff-vector 6 'combined)
+ (emerge-refresh-mode-line)))
+
+(defun emerge-set-merge-mode (mode)
+ "Set the major mode in a merge buffer.
+Overrides any change that the mode might make to the mode line or local
+keymap. Leaves merge in fast mode."
+ (interactive
+ (list (intern (completing-read "New major mode for merge buffer: "
+ obarray 'commandp t nil))))
+ (funcall mode)
+ (emerge-refresh-mode-line)
+ (if emerge-fast-mode
+ (emerge-fast-mode)
+ (emerge-edit-mode)))
+
+(defun emerge-one-line-window ()
+ (interactive)
+ (let ((window-min-height 1))
+ (shrink-window (- (window-height) 2))))
+
+;;; Support routines
+
+;; Select a difference by placing the visual flags around the appropriate
+;; group of lines in the A, B, and merge buffers
+(defun emerge-select-difference (n)
+ (let ((emerge-globalized-difference-list emerge-difference-list)
+ (emerge-globalized-number-of-differences emerge-number-of-differences))
+ (emerge-place-flags-in-buffer emerge-A-buffer n 0 1)
+ (emerge-place-flags-in-buffer emerge-B-buffer n 2 3)
+ (emerge-place-flags-in-buffer nil n 4 5))
+ (run-hooks 'emerge-select-hook))
+
+(defun emerge-place-flags-in-buffer (buffer difference before-index
+ after-index)
+ (if buffer
+ (emerge-eval-in-buffer
+ buffer
+ (emerge-place-flags-in-buffer1 difference before-index after-index))
+ (emerge-place-flags-in-buffer1 difference before-index after-index)))
+
+(defun emerge-place-flags-in-buffer1 (difference before-index after-index)
+ (let ((buffer-read-only nil))
+ ;; insert the flag before the difference
+ (let ((before (aref (aref emerge-globalized-difference-list difference)
+ before-index))
+ here)
+ (goto-char before)
+ ;; insert the flag itself
+ (insert-before-markers emerge-before-flag)
+ (setq here (point))
+ ;; Put the marker(s) referring to this position 1 character before the
+ ;; end of the flag, so it won't be damaged by the user.
+ ;; This gets a bit tricky, as there could be a number of markers
+ ;; that have to be moved.
+ (set-marker before (1- before))
+ (let ((n (1- difference)) after-marker before-marker diff-list)
+ (while (and
+ (>= n 0)
+ (progn
+ (setq diff-list (aref emerge-globalized-difference-list n)
+ after-marker (aref diff-list after-index))
+ (= after-marker here)))
+ (set-marker after-marker (1- after-marker))
+ (setq before-marker (aref diff-list before-index))
+ (if (= before-marker here)
+ (setq before-marker (1- before-marker)))
+ (setq n (1- n)))))
+ ;; insert the flag after the difference
+ (let* ((after (aref (aref emerge-globalized-difference-list difference)
+ after-index))
+ (here (marker-position after)))
+ (goto-char here)
+ ;; insert the flag itself
+ (insert emerge-after-flag)
+ ;; Put the marker(s) referring to this position 1 character after the
+ ;; beginning of the flag, so it won't be damaged by the user.
+ ;; This gets a bit tricky, as there could be a number of markers
+ ;; that have to be moved.
+ (set-marker after (1+ after))
+ (let ((n (1+ difference)) before-marker after-marker diff-list)
+ (while (and
+ (< n emerge-globalized-number-of-differences)
+ (progn
+ (setq diff-list (aref emerge-globalized-difference-list n)
+ before-marker (aref diff-list before-index))
+ (= before-marker here)))
+ (set-marker before-marker (1+ before-marker))
+ (setq after-marker (aref diff-list after-index))
+ (if (= after-marker here)
+ (setq after-marker (1+ after-marker)))
+ (setq n (1+ n)))))))
+
+;; Unselect a difference by removing the visual flags in the buffers.
+(defun emerge-unselect-difference (n)
+ (let ((diff-vector (aref emerge-difference-list n)))
+ (emerge-remove-flags-in-buffer emerge-A-buffer
+ (aref diff-vector 0) (aref diff-vector 1))
+ (emerge-remove-flags-in-buffer emerge-B-buffer
+ (aref diff-vector 2) (aref diff-vector 3))
+ (emerge-remove-flags-in-buffer emerge-merge-buffer
+ (aref diff-vector 4) (aref diff-vector 5)))
+ (run-hooks 'emerge-unselect-hook))
+
+(defun emerge-remove-flags-in-buffer (buffer before after)
+ (emerge-eval-in-buffer
+ buffer
+ (let ((buffer-read-only nil))
+ ;; remove the flags, if they're there
+ (goto-char (- before (1- emerge-before-flag-length)))
+ (if (looking-at emerge-before-flag-match)
+ (delete-char emerge-before-flag-length)
+ ;; the flag isn't there
+ (ding)
+ (message "Trouble removing flag"))
+ (goto-char (1- after))
+ (if (looking-at emerge-after-flag-match)
+ (delete-char emerge-after-flag-length)
+ ;; the flag isn't there
+ (ding)
+ (message "Trouble removing flag")))))
+
+;; Select a difference, removing any flags that exist now.
+(defun emerge-unselect-and-select-difference (n &optional suppress-display)
+ (if (and (>= emerge-current-difference 0)
+ (< emerge-current-difference emerge-number-of-differences))
+ (emerge-unselect-difference emerge-current-difference))
+ (if (and (>= n 0) (< n emerge-number-of-differences))
+ (progn
+ (emerge-select-difference n)
+ (let* ((diff-vector (aref emerge-difference-list n))
+ (selection-type (aref diff-vector 6)))
+ (if (eq selection-type 'default-A)
+ (aset diff-vector 6 'A)
+ (if (eq selection-type 'default-B)
+ (aset diff-vector 6 'B))))))
+ (setq emerge-current-difference n)
+ (if (not suppress-display)
+ (progn
+ (emerge-recenter)
+ (emerge-refresh-mode-line))))
+
+;; Perform tests to see whether user should be allowed to select a version
+;; of this difference:
+;; a valid difference has been selected; and
+;; the difference text in the merge buffer is:
+;; the A version (execute a-version), or
+;; the B version (execute b-version), or
+;; empty (execute neither-version), or
+;; argument FORCE is true (execute neither-version)
+;; Otherwise, signal an error.
+(defun emerge-select-version (force a-version b-version neither-version)
+ (emerge-validate-difference)
+ (let ((buffer-read-only nil))
+ (let* ((diff-vector
+ (aref emerge-difference-list emerge-current-difference))
+ (A-begin (1+ (aref diff-vector 0)))
+ (A-end (1- (aref diff-vector 1)))
+ (B-begin (1+ (aref diff-vector 2)))
+ (B-end (1- (aref diff-vector 3)))
+ (merge-begin (1+ (aref diff-vector 4)))
+ (merge-end (1- (aref diff-vector 5))))
+ (if (emerge-compare-buffers emerge-A-buffer A-begin A-end
+ emerge-merge-buffer merge-begin
+ merge-end)
+ (funcall a-version)
+ (if (emerge-compare-buffers emerge-B-buffer B-begin B-end
+ emerge-merge-buffer merge-begin
+ merge-end)
+ (funcall b-version)
+ (if (or force (= merge-begin merge-end))
+ (funcall neither-version)
+ (error "This difference region has been edited")))))))
+
+;; Read a file name, handling all of the various defaulting rules.
+
+(defun emerge-read-file-name (prompt alternative-default-dir default-file
+ A-file must-match)
+ ;; `prompt' should not have trailing ": ", so that it can be modified
+ ;; according to context.
+ ;; If alternative-default-dir is non-nil, it should be used as the default
+ ;; directory instead if default-directory, if emerge-default-last-directories
+ ;; is set.
+ ;; If default-file is set, it should be used as the default value.
+ ;; If A-file is set, and its directory is different from
+ ;; alternative-default-dir, and if emerge-default-last-directories is set,
+ ;; the default file should be the last part of A-file in the default
+ ;; directory. (Overriding default-file.)
+ (cond
+ ;; If this is not the A-file argument (shown by non-nil A-file), and
+ ;; if emerge-default-last-directories is set, and
+ ;; the default directory exists but is not the same as the directory of the
+ ;; A-file,
+ ;; then make the default file have the same name as the A-file, but in
+ ;; the default directory.
+ ((and emerge-default-last-directories
+ A-file
+ alternative-default-dir
+ (not (string-equal alternative-default-dir
+ (file-name-directory A-file))))
+ (read-file-name (format "%s (default %s): "
+ prompt (file-name-nondirectory A-file))
+ alternative-default-dir
+ (concat alternative-default-dir
+ (file-name-nondirectory A-file))
+ (and must-match 'confirm)))
+ ;; If there is a default file, use it.
+ (default-file
+ (read-file-name (format "%s (default %s): " prompt default-file)
+ ;; If emerge-default-last-directories is set, use the
+ ;; directory from the same argument of the last call of
+ ;; Emerge as the default for this argument.
+ (and emerge-default-last-directories
+ alternative-default-dir)
+ default-file (and must-match 'confirm)))
+ (t
+ (read-file-name (concat prompt ": ")
+ ;; If emerge-default-last-directories is set, use the
+ ;; directory from the same argument of the last call of
+ ;; Emerge as the default for this argument.
+ (and emerge-default-last-directories
+ alternative-default-dir)
+ nil (and must-match 'confirm)))))
+
+;; Revise the mode line to display which difference we have selected
+
+(defun emerge-refresh-mode-line ()
+ (setq mode-line-buffer-identification
+ (list (format "Emerge: %%b diff %d of %d%s"
+ (1+ emerge-current-difference)
+ emerge-number-of-differences
+ (if (and (>= emerge-current-difference 0)
+ (< emerge-current-difference
+ emerge-number-of-differences))
+ (cdr (assq (aref (aref emerge-difference-list
+ emerge-current-difference)
+ 6)
+ '((A . " - A")
+ (B . " - B")
+ (prefer-A . " - A*")
+ (prefer-B . " - B*")
+ (combined . " - comb"))))
+ ""))))
+ (force-mode-line-update))
+
+;; compare two regions in two buffers for containing the same text
+(defun emerge-compare-buffers (buffer-x x-begin x-end buffer-y y-begin y-end)
+ ;; first check that the two regions are the same length
+ (if (not (and (= (- x-end x-begin) (- y-end y-begin))))
+ nil
+ (catch 'exit
+ (while (< x-begin x-end)
+ ;; bite off and compare no more than 1000 characters at a time
+ (let* ((compare-length (min (- x-end x-begin) 1000))
+ (x-string (emerge-eval-in-buffer
+ buffer-x
+ (buffer-substring x-begin
+ (+ x-begin compare-length))))
+ (y-string (emerge-eval-in-buffer
+ buffer-y
+ (buffer-substring y-begin
+ (+ y-begin compare-length)))))
+ (if (not (string-equal x-string y-string))
+ (throw 'exit nil)
+ (setq x-begin (+ x-begin compare-length))
+ (setq y-begin (+ y-begin compare-length)))))
+ t)))
+
+;; Construct a unique buffer name.
+;; The first one tried is prefixsuffix, then prefix<2>suffix,
+;; prefix<3>suffix, etc.
+(defun emerge-unique-buffer-name (prefix suffix)
+ (if (null (get-buffer (concat prefix suffix)))
+ (concat prefix suffix)
+ (let ((n 2))
+ (while (get-buffer (format "%s<%d>%s" prefix n suffix))
+ (setq n (1+ n)))
+ (format "%s<%d>%s" prefix n suffix))))
+
+;; Verify that we have a difference selected.
+(defun emerge-validate-difference ()
+ (if (not (and (>= emerge-current-difference 0)
+ (< emerge-current-difference emerge-number-of-differences)))
+ (error "No difference selected")))
+
+;;; Functions for saving and restoring a batch of variables
+
+;; These functions save (get the values of) and restore (set the values of)
+;; a list of variables. The argument is a list of symbols (the names of
+;; the variables). A list element can also be a list of two functions,
+;; the first of which (when called with no arguments) gets the value, and
+;; the second (when called with a value as an argument) sets the value.
+;; A "function" is anything that funcall can handle as an argument.
+
+(defun emerge-save-variables (vars)
+ (mapcar (function (lambda (v) (if (symbolp v)
+ (symbol-value v)
+ (funcall (car v)))))
+ vars))
+
+(defun emerge-restore-variables (vars values)
+ (while vars
+ (let ((var (car vars))
+ (value (car values)))
+ (if (symbolp var)
+ (set var value)
+ (funcall (car (cdr var)) value)))
+ (setq vars (cdr vars))
+ (setq values (cdr values))))
+
+;; Make a temporary file that only we have access to.
+;; PREFIX is appended to emerge-temp-file-prefix to make the filename prefix.
+(defun emerge-make-temp-file (prefix)
+ (let (f (old-modes (default-file-modes)))
+ (unwind-protect
+ (progn
+ (set-default-file-modes emerge-temp-file-mode)
+ (setq f (make-temp-file (concat emerge-temp-file-prefix prefix))))
+ (set-default-file-modes old-modes))
+ f))
+
+;;; Functions that query the user before he can write out the current buffer.
+
+(defun emerge-query-write-file ()
+ "Ask the user whether to write out an incomplete merge.
+If answer is yes, call `write-file' to do so. See `emerge-query-and-call'
+for details of the querying process."
+ (interactive)
+ (emerge-query-and-call 'write-file))
+
+(defun emerge-query-save-buffer ()
+ "Ask the user whether to save an incomplete merge.
+If answer is yes, call `save-buffer' to do so. See `emerge-query-and-call'
+for details of the querying process."
+ (interactive)
+ (emerge-query-and-call 'save-buffer))
+
+(defun emerge-query-and-call (command)
+ "Ask the user whether to save or write out the incomplete merge.
+If answer is yes, call COMMAND interactively. During the call, the flags
+around the current difference are removed."
+ (if (yes-or-no-p "Do you really write to write out this unfinished merge? ")
+ ;; He really wants to do it -- unselect the difference for the duration
+ (progn
+ (if (and (>= emerge-current-difference 0)
+ (< emerge-current-difference emerge-number-of-differences))
+ (emerge-unselect-difference emerge-current-difference))
+ ;; call-interactively takes the value of current-prefix-arg as the
+ ;; prefix argument value to be passed to the command. Thus, we have
+ ;; to do nothing special to make sure the prefix argument is
+ ;; transmitted to the command.
+ (call-interactively command)
+ (if (and (>= emerge-current-difference 0)
+ (< emerge-current-difference emerge-number-of-differences))
+ (progn
+ (emerge-select-difference emerge-current-difference)
+ (emerge-recenter))))
+ ;; He's being smart and not doing it
+ (message "Not written")))
+
+;; Make sure the current buffer (for a file) has the same contents as the
+;; file on disk, and attempt to remedy the situation if not.
+;; Signal an error if we can't make them the same, or the user doesn't want
+;; to do what is necessary to make them the same.
+(defun emerge-verify-file-buffer ()
+ ;; First check if the file has been modified since the buffer visited it.
+ (if (verify-visited-file-modtime (current-buffer))
+ (if (buffer-modified-p)
+ ;; If buffer is not obsolete and is modified, offer to save
+ (if (yes-or-no-p (format "Save file %s? " buffer-file-name))
+ (save-buffer)
+ (error "Buffer out of sync for file %s" buffer-file-name))
+ ;; If buffer is not obsolete and is not modified, do nothing
+ nil)
+ (if (buffer-modified-p)
+ ;; If buffer is obsolete and is modified, give error
+ (error "Buffer out of sync for file %s" buffer-file-name)
+ ;; If buffer is obsolete and is not modified, offer to revert
+ (if (yes-or-no-p (format "Revert file %s? " buffer-file-name))
+ (revert-buffer t t)
+ (error "Buffer out of sync for file %s" buffer-file-name)))))
+\f
+;; Utilities that might have value outside of Emerge.
+
+;; Set up the mode in the current buffer to duplicate the mode in another
+;; buffer.
+(defun emerge-copy-modes (buffer)
+ ;; Set the major mode
+ (funcall (emerge-eval-in-buffer buffer major-mode)))
+
+;; Define a key, even if a prefix of it is defined
+(defun emerge-force-define-key (keymap key definition)
+ "Like `define-key', but forcibly creates prefix characters as needed.
+If some prefix of KEY has a non-prefix definition, it is redefined."
+ ;; Find out if a prefix of key is defined
+ (let ((v (lookup-key keymap key)))
+ ;; If so, undefine it
+ (if (integerp v)
+ (define-key keymap (substring key 0 v) nil)))
+ ;; Now define the key
+ (define-key keymap key definition))
+
+;;;;; Improvements to describe-mode, so that it describes minor modes as well
+;;;;; as the major mode
+;;(defun describe-mode (&optional minor)
+;; "Display documentation of current major mode.
+;;If optional arg MINOR is non-nil (or prefix argument is given if interactive),
+;;display documentation of active minor modes as well.
+;;For this to work correctly for a minor mode, the mode's indicator variable
+;;\(listed in `minor-mode-alist') must also be a function whose documentation
+;;describes the minor mode."
+;; (interactive)
+;; (with-output-to-temp-buffer "*Help*"
+;; (princ mode-name)
+;; (princ " Mode:\n")
+;; (princ (documentation major-mode))
+;; (let ((minor-modes minor-mode-alist)
+;; (locals (buffer-local-variables)))
+;; (while minor-modes
+;; (let* ((minor-mode (car (car minor-modes)))
+;; (indicator (car (cdr (car minor-modes))))
+;; (local-binding (assq minor-mode locals)))
+;; ;; Document a minor mode if it is listed in minor-mode-alist,
+;; ;; bound locally in this buffer, non-nil, and has a function
+;; ;; definition.
+;; (if (and local-binding
+;; (cdr local-binding)
+;; (fboundp minor-mode))
+;; (progn
+;; (princ (format "\n\n\n%s minor mode (indicator%s):\n"
+;; minor-mode indicator))
+;; (princ (documentation minor-mode)))))
+;; (setq minor-modes (cdr minor-modes))))
+;; (with-current-buffer standard-output
+;; (help-mode))
+;; (help-print-return-message)))
+
+;; This goes with the redefinition of describe-mode.
+;;;; Adjust things so that keyboard macro definitions are documented correctly.
+;;(fset 'defining-kbd-macro (symbol-function 'start-kbd-macro))
+
+;; substitute-key-definition should work now.
+;;;; Function to shadow a definition in a keymap with definitions in another.
+;;(defun emerge-shadow-key-definition (olddef newdef keymap shadowmap)
+;; "Shadow OLDDEF with NEWDEF for any keys in KEYMAP with entries in SHADOWMAP.
+;;In other words, SHADOWMAP will now shadow all definitions of OLDDEF in KEYMAP
+;;with NEWDEF. Does not affect keys that are already defined in SHADOWMAP,
+;;including those whose definition is OLDDEF."
+;; ;; loop through all keymaps accessible from keymap
+;; (let ((maps (accessible-keymaps keymap)))
+;; (while maps
+;; (let ((prefix (car (car maps)))
+;; (map (cdr (car maps))))
+;; ;; examine a keymap
+;; (if (arrayp map)
+;; ;; array keymap
+;; (let ((len (length map))
+;; (i 0))
+;; (while (< i len)
+;; (if (eq (aref map i) olddef)
+;; ;; set the shadowing definition
+;; (let ((key (concat prefix (char-to-string i))))
+;; (emerge-define-key-if-possible shadowmap key newdef)))
+;; (setq i (1+ i))))
+;; ;; sparse keymap
+;; (while map
+;; (if (eq (cdr-safe (car-safe map)) olddef)
+;; ;; set the shadowing definition
+;; (let ((key
+;; (concat prefix (char-to-string (car (car map))))))
+;; (emerge-define-key-if-possible shadowmap key newdef)))
+;; (setq map (cdr map)))))
+;; (setq maps (cdr maps)))))
+
+;; Define a key if it (or a prefix) is not already defined in the map.
+(defun emerge-define-key-if-possible (keymap key definition)
+ ;; look up the present definition of the key
+ (let ((present (lookup-key keymap key)))
+ (if (integerp present)
+ ;; if it is "too long", look up the valid prefix
+ (if (not (lookup-key keymap (substring key 0 present)))
+ ;; if the prefix isn't defined, define it
+ (define-key keymap key definition))
+ ;; if there is no present definition, define it
+ (if (not present)
+ (define-key keymap key definition)))))
+
+;; Ordinary substitute-key-definition should do this now.
+;;(defun emerge-recursively-substitute-key-definition (olddef newdef keymap)
+;; "Like `substitute-key-definition', but act recursively on subkeymaps.
+;;Make sure that subordinate keymaps aren't shared with other keymaps!
+;;\(`copy-keymap' will suffice.)"
+;; ;; Loop through all keymaps accessible from keymap
+;; (let ((maps (accessible-keymaps keymap)))
+;; (while maps
+;; ;; Substitute in this keymap
+;; (substitute-key-definition olddef newdef (cdr (car maps)))
+;; (setq maps (cdr maps)))))
+
+;; Show the name of the file in the buffer.
+(defun emerge-show-file-name ()
+ "Displays the name of the file loaded into the current buffer.
+If the name won't fit on one line, the minibuffer is expanded to hold it,
+and the command waits for a keystroke from the user. If the keystroke is
+SPC, it is ignored; if it is anything else, it is processed as a command."
+ (interactive)
+ (let ((name (buffer-file-name)))
+ (or name
+ (setq name "Buffer has no file name."))
+ (save-window-excursion
+ (select-window (minibuffer-window))
+ (unwind-protect
+ (progn
+ (erase-buffer)
+ (insert name)
+ (while (and (not (pos-visible-in-window-p))
+ (not (window-full-height-p)))
+ (enlarge-window 1))
+ (let* ((echo-keystrokes 0)
+ (c (read-event)))
+ (if (not (eq c 32))
+ (setq unread-command-events (list c)))))
+ (erase-buffer)))))
+
+;; Improved auto-save file names.
+;; This function fixes many problems with the standard auto-save file names:
+;; Auto-save files for non-file buffers get put in the default directory
+;; for the buffer, whether that makes sense or not.
+;; Auto-save files for file buffers get put in the directory of the file,
+;; regardless of whether we can write into it or not.
+;; Auto-save files for non-file buffers don't use the process id, so if a
+;; user runs more than on Emacs, they can make auto-save files that overwrite
+;; each other.
+;; To use this function, do:
+;; (fset 'make-auto-save-file-name
+;; (symbol-function 'emerge-make-auto-save-file-name))
+(defun emerge-make-auto-save-file-name ()
+ "Return file name to use for auto-saves of current buffer.
+Does not consider `auto-save-visited-file-name';
+that is checked before calling this function.
+You can redefine this for customization.
+See also `auto-save-file-name-p'."
+ (if buffer-file-name
+ ;; if buffer has a file, try the format <file directory>/#<file name>#
+ (let ((f (concat (file-name-directory buffer-file-name)
+ "#"
+ (file-name-nondirectory buffer-file-name)
+ "#")))
+ (if (file-writable-p f)
+ ;; the file is writable, so use it
+ f
+ ;; the file isn't writable, so use the format
+ ;; ~/#&<file name>&<hash of directory>#
+ (concat (getenv "HOME")
+ "/#&"
+ (file-name-nondirectory buffer-file-name)
+ "&"
+ (emerge-hash-string-into-string
+ (file-name-directory buffer-file-name))
+ "#")))
+ ;; if buffer has no file, use the format ~/#%<buffer name>%<process id>#
+ (expand-file-name (concat (getenv "HOME")
+ "/#%"
+ ;; quote / into \! and \ into \\
+ (emerge-unslashify-name (buffer-name))
+ "%"
+ (make-temp-name "")
+ "#"))))
+
+;; Hash a string into five characters more-or-less suitable for use in a file
+;; name. (Allowed characters are ! through ~, except /.)
+(defun emerge-hash-string-into-string (s)
+ (let ((bins (vector 0 0 0 0 0))
+ (i 0))
+ (while (< i (length s))
+ (aset bins (% i 5) (% (+ (* (aref bins (% i 5)) 35)
+ (aref s i))
+ 65536))
+ (setq i (1+ i)))
+ (mapconcat (function (lambda (b)
+ (setq b (+ (% b 93) ?!))
+ (if (>= b ?/)
+ (setq b (1+ b)))
+ (char-to-string b)))
+ bins "")))
+
+;; Quote any /s in a string by replacing them with \!.
+;; Also, replace any \s by \\, to make it one-to-one.
+(defun emerge-unslashify-name (s)
+ (let ((limit 0))
+ (while (string-match "[/\\]" s limit)
+ (setq s (concat (substring s 0 (match-beginning 0))
+ (if (string= (substring s (match-beginning 0)
+ (match-end 0))
+ "/")
+ "\\!"
+ "\\\\")
+ (substring s (match-end 0))))
+ (setq limit (1+ (match-end 0)))))
+ s)
+
+;; Metacharacters that have to be protected from the shell when executing
+;; a diff/diff3 command.
+(defcustom emerge-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]"
+ "Characters that must be quoted with \\ when used in a shell command line.
+More precisely, a [...] regexp to match any one such character."
+ :type 'regexp
+ :group 'emerge)
+
+;; Quote metacharacters (using \) when executing a diff/diff3 command.
+(defun emerge-protect-metachars (s)
+ (let ((limit 0))
+ (while (string-match emerge-metachars s limit)
+ (setq s (concat (substring s 0 (match-beginning 0))
+ "\\"
+ (substring s (match-beginning 0))))
+ (setq limit (1+ (match-end 0)))))
+ s)
+
+(provide 'emerge)
+
+;; arch-tag: a575f092-6e44-400e-b8a2-4124e9377585
+;;; emerge.el ends here
--- /dev/null
+;;; log-edit.el --- Major mode for editing CVS commit messages
+
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: pcl-cvs cvs commit log
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Todo:
+
+;; - Move in VC's code
+;; - Add compatibility for VC's hook variables
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'add-log) ; for all the ChangeLog goodies
+(require 'pcvs-util)
+(require 'ring)
+
+;;;;
+;;;; Global Variables
+;;;;
+
+(defgroup log-edit nil
+ "Major mode for editing RCS and CVS commit messages."
+ :group 'pcl-cvs
+ :group 'vc ; It's used by VC.
+ :version "21.1"
+ :prefix "log-edit-")
+
+;; compiler pacifiers
+(defvar cvs-buffer)
+
+\f
+;; The main keymap
+
+(easy-mmode-defmap log-edit-mode-map
+ `(("\C-c\C-c" . log-edit-done)
+ ("\C-c\C-a" . log-edit-insert-changelog)
+ ("\C-c\C-d" . log-edit-show-diff)
+ ("\C-c\C-f" . log-edit-show-files)
+ ("\M-n" . log-edit-next-comment)
+ ("\M-p" . log-edit-previous-comment)
+ ("\M-r" . log-edit-comment-search-backward)
+ ("\M-s" . log-edit-comment-search-forward)
+ ("\C-c?" . log-edit-mode-help))
+ "Keymap for the `log-edit-mode' (to edit version control log messages)."
+ :group 'log-edit)
+
+;; Compatibility with old names. Should we bother ?
+(defvar vc-log-mode-map log-edit-mode-map)
+(defvar vc-log-entry-mode vc-log-mode-map)
+
+(easy-menu-define log-edit-menu log-edit-mode-map
+ "Menu used for `log-edit-mode'."
+ '("Log-Edit"
+ ["Done" log-edit-done
+ :help "Exit log-edit and proceed with the actual action."]
+ "--"
+ ["Insert ChangeLog" log-edit-insert-changelog
+ :help "Insert a log message by looking at the ChangeLog"]
+ ["Add to ChangeLog" log-edit-add-to-changelog
+ :help "Insert this log message into the appropriate ChangeLog file"]
+ "--"
+ ["Show diff" log-edit-show-diff
+ :help "Show the diff for the files to be committed."]
+ ["List files" log-edit-show-files
+ :help "Show the list of relevant files."]
+ "--"
+ ["Previous comment" log-edit-previous-comment
+ :help "Cycle backwards through comment history"]
+ ["Next comment" log-edit-next-comment
+ :help "Cycle forwards through comment history."]
+ ["Search comment forward" log-edit-comment-search-forward
+ :help "Search forwards through comment history for a substring match of str"]
+ ["Search comment backward" log-edit-comment-search-backward
+ :help "Search backwards through comment history for substring match of str"]))
+
+(defcustom log-edit-confirm 'changed
+ "If non-nil, `log-edit-done' will request confirmation.
+If 'changed, only request confirmation if the list of files has
+ changed since the beginning of the log-edit session."
+ :group 'log-edit
+ :type '(choice (const changed) (const t) (const nil)))
+
+(defcustom log-edit-keep-buffer nil
+ "If non-nil, don't hide the buffer after `log-edit-done'."
+ :group 'log-edit
+ :type 'boolean)
+
+(defvar cvs-commit-buffer-require-final-newline t)
+(make-obsolete-variable 'cvs-commit-buffer-require-final-newline
+ 'log-edit-require-final-newline
+ "21.1")
+
+(defcustom log-edit-require-final-newline
+ cvs-commit-buffer-require-final-newline
+ "Enforce a newline at the end of commit log messages.
+Enforce it silently if t, query if non-nil and don't do anything if nil."
+ :group 'log-edit
+ :type '(choice (const ask) (const t) (const nil)))
+
+(defcustom log-edit-setup-invert nil
+ "Non-nil means `log-edit' should invert the meaning of its SETUP arg.
+If SETUP is 'force, this variable has no effect."
+ :group 'log-edit
+ :type 'boolean)
+
+(defcustom log-edit-hook '(log-edit-insert-cvs-template
+ log-edit-show-files
+ log-edit-insert-changelog)
+ "Hook run at the end of `log-edit'."
+ :group 'log-edit
+ :type '(hook :options (log-edit-insert-changelog
+ log-edit-insert-cvs-rcstemplate
+ log-edit-insert-cvs-template
+ log-edit-insert-filenames)))
+
+(defcustom log-edit-mode-hook (if (boundp 'vc-log-mode-hook) vc-log-mode-hook)
+ "Hook run when entering `log-edit-mode'."
+ :group 'log-edit
+ :type 'hook)
+
+(defcustom log-edit-done-hook nil
+ "Hook run before doing the actual commit.
+This hook can be used to cleanup the message, enforce various
+conventions, or to allow recording the message in some other database,
+such as a bug-tracking system. The list of files about to be committed
+can be obtained from `log-edit-files'."
+ :group 'log-edit
+ :type '(hook :options (log-edit-set-common-indentation
+ log-edit-add-to-changelog)))
+
+(defcustom log-edit-strip-single-file-name nil
+ "If non-nil, remove file name from single-file log entries."
+ :type 'boolean
+ :safe 'booleanp
+ :group 'log-edit
+ :version "24.1")
+
+(defvar cvs-changelog-full-paragraphs t)
+(make-obsolete-variable 'cvs-changelog-full-paragraphs
+ 'log-edit-changelog-full-paragraphs
+ "21.1")
+
+(defvar log-edit-changelog-full-paragraphs cvs-changelog-full-paragraphs
+ "*If non-nil, include full ChangeLog paragraphs in the log.
+This may be set in the ``local variables'' section of a ChangeLog, to
+indicate the policy for that ChangeLog.
+
+A ChangeLog paragraph is a bunch of log text containing no blank lines;
+a paragraph usually describes a set of changes with a single purpose,
+but perhaps spanning several functions in several files. Changes in
+different paragraphs are unrelated.
+
+You could argue that the log entry for a file should contain the
+full ChangeLog paragraph mentioning the change to the file, even though
+it may mention other files, because that gives you the full context you
+need to understand the change. This is the behavior you get when this
+variable is set to t.
+
+On the other hand, you could argue that the log entry for a change
+should contain only the text for the changes which occurred in that
+file, because the log is per-file. This is the behavior you get
+when this variable is set to nil.")
+
+;;;; Internal global or buffer-local vars
+
+(defconst log-edit-files-buf "*log-edit-files*")
+(defvar log-edit-initial-files nil)
+(defvar log-edit-callback nil)
+(defvar log-edit-diff-function nil)
+(defvar log-edit-listfun nil)
+
+(defvar log-edit-parent-buffer nil)
+
+;;; Originally taken from VC-Log mode
+
+(defconst log-edit-maximum-comment-ring-size 32
+ "Maximum number of saved comments in the comment ring.")
+(defvar log-edit-comment-ring (make-ring log-edit-maximum-comment-ring-size))
+(defvar log-edit-comment-ring-index nil)
+(defvar log-edit-last-comment-match "")
+
+(defun log-edit-new-comment-index (stride len)
+ "Return the comment index STRIDE elements from the current one.
+LEN is the length of `log-edit-comment-ring'."
+ (mod (cond
+ (log-edit-comment-ring-index (+ log-edit-comment-ring-index stride))
+ ;; Initialize the index on the first use of this command
+ ;; so that the first M-p gets index 0, and the first M-n gets
+ ;; index -1.
+ ((> stride 0) (1- stride))
+ (t stride))
+ len))
+
+(defun log-edit-previous-comment (arg)
+ "Cycle backwards through comment history.
+With a numeric prefix ARG, go back ARG comments."
+ (interactive "*p")
+ (let ((len (ring-length log-edit-comment-ring)))
+ (if (<= len 0)
+ (progn (message "Empty comment ring") (ding))
+ ;; Don't use `erase-buffer' because we don't want to `widen'.
+ (delete-region (point-min) (point-max))
+ (setq log-edit-comment-ring-index (log-edit-new-comment-index arg len))
+ (message "Comment %d" (1+ log-edit-comment-ring-index))
+ (insert (ring-ref log-edit-comment-ring log-edit-comment-ring-index)))))
+
+(defun log-edit-next-comment (arg)
+ "Cycle forwards through comment history.
+With a numeric prefix ARG, go forward ARG comments."
+ (interactive "*p")
+ (log-edit-previous-comment (- arg)))
+
+(defun log-edit-comment-search-backward (str &optional stride)
+ "Search backwards through comment history for substring match of STR.
+If the optional argument STRIDE is present, that is a step-width to use
+when going through the comment ring."
+ ;; Why substring rather than regexp ? -sm
+ (interactive
+ (list (read-string "Comment substring: " nil nil log-edit-last-comment-match)))
+ (unless stride (setq stride 1))
+ (if (string= str "")
+ (setq str log-edit-last-comment-match)
+ (setq log-edit-last-comment-match str))
+ (let* ((str (regexp-quote str))
+ (len (ring-length log-edit-comment-ring))
+ (n (log-edit-new-comment-index stride len)))
+ (while (progn (when (or (>= n len) (< n 0)) (error "Not found"))
+ (not (string-match str (ring-ref log-edit-comment-ring n))))
+ (setq n (+ n stride)))
+ (setq log-edit-comment-ring-index n)
+ (log-edit-previous-comment 0)))
+
+(defun log-edit-comment-search-forward (str)
+ "Search forwards through comment history for a substring match of STR."
+ (interactive
+ (list (read-string "Comment substring: " nil nil log-edit-last-comment-match)))
+ (log-edit-comment-search-backward str -1))
+
+(defun log-edit-comment-to-change-log (&optional whoami file-name)
+ "Enter last VC comment into the change log for the current file.
+WHOAMI (interactive prefix) non-nil means prompt for user name
+and site. FILE-NAME is the name of the change log; if nil, use
+`change-log-default-name'.
+
+This may be useful as a `log-edit-checkin-hook' to update change logs
+automatically."
+ (interactive (if current-prefix-arg
+ (list current-prefix-arg
+ (prompt-for-change-log-name))))
+ (let (;; Extract the comment first so we get any error before doing anything.
+ (comment (ring-ref log-edit-comment-ring 0))
+ ;; Don't let add-change-log-entry insert a defun name.
+ (add-log-current-defun-function 'ignore)
+ end)
+ ;; Call add-log to do half the work.
+ (add-change-log-entry whoami file-name t t)
+ ;; Insert the VC comment, leaving point before it.
+ (setq end (save-excursion (insert comment) (point-marker)))
+ (if (looking-at "\\s *\\s(")
+ ;; It starts with an open-paren, as in "(foo): Frobbed."
+ ;; So remove the ": " add-log inserted.
+ (delete-char -2))
+ ;; Canonicalize the white space between the file name and comment.
+ (just-one-space)
+ ;; Indent rest of the text the same way add-log indented the first line.
+ (let ((indentation (current-indentation)))
+ (save-excursion
+ (while (< (point) end)
+ (forward-line 1)
+ (indent-to indentation))
+ (setq end (point))))
+ ;; Fill the inserted text, preserving open-parens at bol.
+ (let ((paragraph-start (concat paragraph-start "\\|\\s *\\s(")))
+ (beginning-of-line)
+ (fill-region (point) end))
+ ;; Canonicalize the white space at the end of the entry so it is
+ ;; separated from the next entry by a single blank line.
+ (skip-syntax-forward " " end)
+ (delete-char (- (skip-syntax-backward " ")))
+ (or (eobp) (looking-at "\n\n")
+ (insert "\n"))))
+
+;; Compatibility with old names.
+(define-obsolete-variable-alias 'vc-comment-ring 'log-edit-comment-ring "22.1")
+(define-obsolete-variable-alias 'vc-comment-ring-index 'log-edit-comment-ring-index "22.1")
+(define-obsolete-function-alias 'vc-previous-comment 'log-edit-previous-comment "22.1")
+(define-obsolete-function-alias 'vc-next-comment 'log-edit-next-comment "22.1")
+(define-obsolete-function-alias 'vc-comment-search-reverse 'log-edit-comment-search-backward "22.1")
+(define-obsolete-function-alias 'vc-comment-search-forward 'log-edit-comment-search-forward "22.1")
+(define-obsolete-function-alias 'vc-comment-to-change-log 'log-edit-comment-to-change-log "22.1")
+
+;;;
+;;; Actual code
+;;;
+
+(defface log-edit-summary '((t :inherit font-lock-function-name-face))
+ "Face for the summary in `log-edit-mode' buffers.")
+
+(defface log-edit-header '((t :inherit font-lock-keyword-face))
+ "Face for the headers in `log-edit-mode' buffers.")
+
+(defface log-edit-unknown-header '((t :inherit font-lock-comment-face))
+ "Face for unknown headers in `log-edit-mode' buffers.")
+
+(defvar log-edit-headers-alist '(("Summary" . log-edit-summary)
+ ("Fixes") ("Author"))
+ "AList of known headers and the face to use to highlight them.")
+
+(defconst log-edit-header-contents-regexp
+ "[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?")
+
+(defun log-edit-match-to-eoh (limit)
+ ;; FIXME: copied from message-match-to-eoh.
+ (let ((start (point)))
+ (rfc822-goto-eoh)
+ ;; Typical situation: some temporary change causes the header to be
+ ;; incorrect, so EOH comes earlier than intended: the last lines of the
+ ;; intended headers are now not considered part of the header any more,
+ ;; so they don't have the multiline property set. When the change is
+ ;; completed and the header has its correct shape again, the lack of the
+ ;; multiline property means we won't rehighlight the last lines of
+ ;; the header.
+ (if (< (point) start)
+ nil ;No header within start..limit.
+ ;; Here we disregard LIMIT so that we may extend the area again.
+ (set-match-data (list start (point)))
+ (point))))
+
+(defvar log-edit-font-lock-keywords
+ ;; Copied/inspired by message-font-lock-keywords.
+ `((log-edit-match-to-eoh
+ (,(concat "^\\(\\([a-z]+\\):\\)" log-edit-header-contents-regexp
+ "\\|\\(.*\\)")
+ (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+ (1 (if (assoc (match-string 2) log-edit-headers-alist)
+ 'log-edit-header
+ 'log-edit-unknown-header)
+ nil lax)
+ (3 (or (cdr (assoc (match-string 2) log-edit-headers-alist))
+ 'log-edit-header)
+ nil lax)
+ (4 font-lock-warning-face nil lax)))))
+
+;;;###autoload
+(defun log-edit (callback &optional setup params buffer mode &rest ignore)
+ "Setup a buffer to enter a log message.
+\\<log-edit-mode-map>The buffer will be put in mode MODE or `log-edit-mode'
+if MODE is nil.
+If SETUP is non-nil, the buffer is then erased and `log-edit-hook' is run.
+Mark and point will be set around the entire contents of the buffer so
+that it is easy to kill the contents of the buffer with \\[kill-region].
+Once you're done editing the message, pressing \\[log-edit-done] will call
+`log-edit-done' which will end up calling CALLBACK to do the actual commit.
+
+PARAMS if non-nil is an alist. Possible keys and associated values:
+ `log-edit-listfun' -- function taking no arguments that returns the list of
+ files that are concerned by the current operation (using relative names);
+ `log-edit-diff-function' -- function taking no arguments that
+ displays a diff of the files concerned by the current operation.
+
+If BUFFER is non-nil `log-edit' will jump to that buffer, use it to edit the
+log message and go back to the current buffer when done. Otherwise, it
+uses the current buffer."
+ (let ((parent (current-buffer)))
+ (if buffer (pop-to-buffer buffer))
+ (when (and log-edit-setup-invert (not (eq setup 'force)))
+ (setq setup (not setup)))
+ (when setup
+ (erase-buffer)
+ (insert "Summary: ")
+ (save-excursion (insert "\n\n")))
+ (if mode
+ (funcall mode)
+ (log-edit-mode))
+ (set (make-local-variable 'log-edit-callback) callback)
+ (if (listp params)
+ (dolist (crt params)
+ (set (make-local-variable (car crt)) (cdr crt)))
+ ;; For backward compatibility with log-edit up to version 22.2
+ ;; accept non-list PARAMS to mean `log-edit-list'.
+ (set (make-local-variable 'log-edit-listfun) params))
+
+ (if buffer (set (make-local-variable 'log-edit-parent-buffer) parent))
+ (set (make-local-variable 'log-edit-initial-files) (log-edit-files))
+ (when setup (run-hooks 'log-edit-hook))
+ (goto-char (point-min)) (push-mark (point-max))
+ (message "%s" (substitute-command-keys
+ "Press \\[log-edit-done] when you are done editing."))))
+
+(define-derived-mode log-edit-mode text-mode "Log-Edit"
+ "Major mode for editing version-control log messages.
+When done editing the log entry, just type \\[log-edit-done] which
+will trigger the actual commit of the file(s).
+Several other handy support commands are provided of course and
+the package from which this is used might also provide additional
+commands (under C-x v for VC, for example).
+
+\\{log-edit-mode-map}"
+ (set (make-local-variable 'font-lock-defaults)
+ '(log-edit-font-lock-keywords t t))
+ (make-local-variable 'log-edit-comment-ring-index)
+ (hack-dir-local-variables-non-file-buffer))
+
+(defun log-edit-hide-buf (&optional buf where)
+ (when (setq buf (get-buffer (or buf log-edit-files-buf)))
+ (let ((win (get-buffer-window buf where)))
+ (if win (ignore-errors (delete-window win))))
+ (bury-buffer buf)))
+
+(defun log-edit-done ()
+ "Finish editing the log message and commit the files.
+If you want to abort the commit, simply delete the buffer."
+ (interactive)
+ ;; Clean up empty headers.
+ (goto-char (point-min))
+ (while (looking-at (concat "^[a-z]*:" log-edit-header-contents-regexp))
+ (let ((beg (match-beginning 0)))
+ (goto-char (match-end 0))
+ (if (string-match "\\`[ \n\t]*\\'" (match-string 1))
+ (delete-region beg (point)))))
+ ;; Get rid of leading empty lines.
+ (goto-char (point-min))
+ (when (looking-at "\\([ \t]*\n\\)+")
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; Get rid of trailing empty lines
+ (goto-char (point-max))
+ (skip-syntax-backward " ")
+ (when (equal (char-after) ?\n) (forward-char 1))
+ (delete-region (point) (point-max))
+ ;; Check for final newline
+ (if (and (> (point-max) (point-min))
+ (/= (char-before (point-max)) ?\n)
+ (or (eq log-edit-require-final-newline t)
+ (and log-edit-require-final-newline
+ (y-or-n-p
+ (format "Buffer %s does not end in newline. Add one? "
+ (buffer-name))))))
+ (save-excursion
+ (goto-char (point-max))
+ (insert ?\n)))
+ (let ((comment (buffer-string)))
+ (when (or (ring-empty-p log-edit-comment-ring)
+ (not (equal comment (ring-ref log-edit-comment-ring 0))))
+ (ring-insert log-edit-comment-ring comment)))
+ (let ((win (get-buffer-window log-edit-files-buf)))
+ (if (and log-edit-confirm
+ (not (and (eq log-edit-confirm 'changed)
+ (equal (log-edit-files) log-edit-initial-files)))
+ (progn
+ (log-edit-show-files)
+ (not (y-or-n-p "Really commit? "))))
+ (progn (when (not win) (log-edit-hide-buf))
+ (message "Oh, well! Later maybe?"))
+ (run-hooks 'log-edit-done-hook)
+ (log-edit-hide-buf)
+ (unless (or log-edit-keep-buffer (not log-edit-parent-buffer))
+ (cvs-bury-buffer (current-buffer) log-edit-parent-buffer))
+ (call-interactively log-edit-callback))))
+
+(defun log-edit-files ()
+ "Return the list of files that are about to be committed."
+ (ignore-errors (funcall log-edit-listfun)))
+
+(defun log-edit-mode-help ()
+ "Provide help for the `log-edit-mode-map'."
+ (interactive)
+ (if (eq last-command 'log-edit-mode-help)
+ (describe-function major-mode)
+ (message "%s"
+ (substitute-command-keys
+ "Type `\\[log-edit-done]' to finish commit. Try `\\[describe-function] log-edit-done' for more help."))))
+
+(defcustom log-edit-common-indent 0
+ "Minimum indentation to use in `log-edit-set-common-indentation'."
+ :group 'log-edit
+ :type 'integer)
+
+(defun log-edit-set-common-indentation ()
+ "(Un)Indent the current buffer rigidly to `log-edit-common-indent'."
+ (save-excursion
+ (let ((common (point-max)))
+ (rfc822-goto-eoh)
+ (while (< (point) (point-max))
+ (if (not (looking-at "^[ \t]*$"))
+ (setq common (min common (current-indentation))))
+ (forward-line 1))
+ (rfc822-goto-eoh)
+ (indent-rigidly (point) (point-max)
+ (- log-edit-common-indent common)))))
+
+(defun log-edit-show-diff ()
+ "Show the diff for the files to be committed."
+ (interactive)
+ (if (functionp log-edit-diff-function)
+ (funcall log-edit-diff-function)
+ (error "Diff functionality has not been setup")))
+
+(defun log-edit-show-files ()
+ "Show the list of files to be committed."
+ (interactive)
+ (let* ((files (log-edit-files))
+ (buf (get-buffer-create log-edit-files-buf)))
+ (with-current-buffer buf
+ (log-edit-hide-buf buf 'all)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (cvs-insert-strings files)
+ (setq buffer-read-only t)
+ (goto-char (point-min))
+ (save-selected-window
+ (cvs-pop-to-buffer-same-frame buf)
+ (shrink-window-if-larger-than-buffer)
+ (selected-window)))))
+
+(defun log-edit-insert-cvs-template ()
+ "Insert the template specified by the CVS administrator, if any.
+This simply uses the local CVS/Template file."
+ (interactive)
+ (when (or (called-interactively-p 'interactive)
+ (= (point-min) (point-max)))
+ (when (file-readable-p "CVS/Template")
+ (insert-file-contents "CVS/Template"))))
+
+(defun log-edit-insert-cvs-rcstemplate ()
+ "Insert the rcstemplate from the CVS repository.
+This contacts the repository to get the rcstemplate file and
+can thus take some time."
+ (interactive)
+ (when (or (called-interactively-p 'interactive)
+ (= (point-min) (point-max)))
+ (when (file-readable-p "CVS/Root")
+ ;; Ignore the stderr stuff, even if it's an error.
+ (call-process "cvs" nil '(t nil) nil
+ "checkout" "-p" "CVSROOT/rcstemplate"))))
+
+(defun log-edit-insert-filenames ()
+ "Insert the list of files that are to be committed."
+ (interactive)
+ (insert "Affected files: \n"
+ (mapconcat 'identity (log-edit-files) " \n")))
+
+(defun log-edit-add-to-changelog ()
+ "Insert this log message into the appropriate ChangeLog file."
+ (interactive)
+ ;; Yuck!
+ (unless (string= (buffer-string) (ring-ref log-edit-comment-ring 0))
+ (ring-insert log-edit-comment-ring (buffer-string)))
+ (dolist (f (log-edit-files))
+ (let ((buffer-file-name (expand-file-name f)))
+ (save-excursion
+ (log-edit-comment-to-change-log)))))
+
+(defvar log-edit-changelog-use-first nil)
+(defun log-edit-insert-changelog (&optional use-first)
+ "Insert a log message by looking at the ChangeLog.
+The idea is to write your ChangeLog entries first, and then use this
+command to commit your changes.
+
+To select default log text, we:
+- find the ChangeLog entries for the files to be checked in,
+- verify that the top entry in the ChangeLog is on the current date
+ and by the current user; if not, we don't provide any default text,
+- search the ChangeLog entry for paragraphs containing the names of
+ the files we're checking in, and finally
+- use those paragraphs as the log text.
+
+If the optional prefix arg USE-FIRST is given (via \\[universal-argument]),
+or if the command is repeated a second time in a row, use the first log entry
+regardless of user name or time."
+ (interactive "P")
+ (let ((eoh (save-excursion (rfc822-goto-eoh) (point))))
+ (when (<= (point) eoh)
+ (goto-char eoh)
+ (if (looking-at "\n") (forward-char 1))))
+ (let ((log-edit-changelog-use-first
+ (or use-first (eq last-command 'log-edit-insert-changelog))))
+ (log-edit-insert-changelog-entries (log-edit-files)))
+ (log-edit-set-common-indentation)
+ (goto-char (point-min))
+ (when (and log-edit-strip-single-file-name (looking-at "\\*\\s-+"))
+ (forward-line 1)
+ (when (not (re-search-forward "^\\*\\s-+" nil t))
+ (goto-char (point-min))
+ (skip-chars-forward "^():")
+ (skip-chars-forward ": ")
+ (delete-region (point-min) (point)))))
+
+;;;;
+;;;; functions for getting commit message from ChangeLog a file...
+;;;; Courtesy Jim Blandy
+;;;;
+
+(defun log-edit-narrow-changelog ()
+ "Narrow to the top page of the current buffer, a ChangeLog file.
+Actually, the narrowed region doesn't include the date line.
+A \"page\" in a ChangeLog file is the area between two dates."
+ (or (eq major-mode 'change-log-mode)
+ (error "log-edit-narrow-changelog: current buffer isn't a ChangeLog"))
+
+ (goto-char (point-min))
+
+ ;; Skip date line and subsequent blank lines.
+ (forward-line 1)
+ (if (looking-at "[ \t\n]*\n")
+ (goto-char (match-end 0)))
+
+ (let ((start (point)))
+ (forward-page 1)
+ (narrow-to-region start (point))
+ (goto-char (point-min))))
+
+(defun log-edit-changelog-paragraph ()
+ "Return the bounds of the ChangeLog paragraph containing point.
+If we are between paragraphs, return the previous paragraph."
+ (beginning-of-line)
+ (if (looking-at "^[ \t]*$")
+ (skip-chars-backward " \t\n" (point-min)))
+ (list (progn
+ (if (re-search-backward "^[ \t]*\n" nil 'or-to-limit)
+ (goto-char (match-end 0)))
+ (point))
+ (if (re-search-forward "^[ \t\n]*$" nil t)
+ (match-beginning 0)
+ (point-max))))
+
+(defun log-edit-changelog-subparagraph ()
+ "Return the bounds of the ChangeLog subparagraph containing point.
+A subparagraph is a block of non-blank lines beginning with an asterisk.
+If we are between sub-paragraphs, return the previous subparagraph."
+ (end-of-line)
+ (if (search-backward "*" nil t)
+ (list (progn (beginning-of-line) (point))
+ (progn
+ (forward-line 1)
+ (if (re-search-forward "^[ \t]*[\n*]" nil t)
+ (match-beginning 0)
+ (point-max))))
+ (list (point) (point))))
+
+(defun log-edit-changelog-entry ()
+ "Return the bounds of the ChangeLog entry containing point.
+The variable `log-edit-changelog-full-paragraphs' decides whether an
+\"entry\" is a paragraph or a subparagraph; see its documentation string
+for more details."
+ (save-excursion
+ (if log-edit-changelog-full-paragraphs
+ (log-edit-changelog-paragraph)
+ (log-edit-changelog-subparagraph))))
+
+(defvar user-full-name)
+(defvar user-mail-address)
+(defun log-edit-changelog-ours-p ()
+ "See if ChangeLog entry at point is for the current user, today.
+Return non-nil if it is."
+ ;; Code adapted from add-change-log-entry.
+ (let ((name (or (and (boundp 'add-log-full-name) add-log-full-name)
+ (and (fboundp 'user-full-name) (user-full-name))
+ (and (boundp 'user-full-name) user-full-name)))
+ (mail (or (and (boundp 'add-log-mailing-address) add-log-mailing-address)
+ ;;(and (fboundp 'user-mail-address) (user-mail-address))
+ (and (boundp 'user-mail-address) user-mail-address)))
+ (time (or (and (boundp 'add-log-time-format)
+ (functionp add-log-time-format)
+ (funcall add-log-time-format))
+ (format-time-string "%Y-%m-%d"))))
+ (looking-at (if log-edit-changelog-use-first
+ "[^ \t]"
+ (regexp-quote (format "%s %s <%s>" time name mail))))))
+
+(defun log-edit-changelog-entries (file)
+ "Return the ChangeLog entries for FILE, and the ChangeLog they came from.
+The return value looks like this:
+ (LOGBUFFER (ENTRYSTART ENTRYEND) ...)
+where LOGBUFFER is the name of the ChangeLog buffer, and each
+\(ENTRYSTART . ENTRYEND\) pair is a buffer region."
+ (let ((changelog-file-name
+ (let ((default-directory
+ (file-name-directory (expand-file-name file)))
+ (visiting-buffer (find-buffer-visiting file)))
+ ;; If there is a buffer visiting FILE, and it has a local
+ ;; value for `change-log-default-name', use that.
+ (if (and visiting-buffer
+ (local-variable-p 'change-log-default-name
+ visiting-buffer))
+ (with-current-buffer visiting-buffer
+ change-log-default-name)
+ ;; `find-change-log' uses `change-log-default-name' if set
+ ;; and sets it before exiting, so we need to work around
+ ;; that memoizing which is undesired here
+ (setq change-log-default-name nil)
+ (find-change-log)))))
+ (with-current-buffer (find-file-noselect changelog-file-name)
+ (unless (eq major-mode 'change-log-mode) (change-log-mode))
+ (goto-char (point-min))
+ (if (looking-at "\\s-*\n") (goto-char (match-end 0)))
+ (if (not (log-edit-changelog-ours-p))
+ (list (current-buffer))
+ (save-restriction
+ (log-edit-narrow-changelog)
+ (goto-char (point-min))
+
+ ;; Search for the name of FILE relative to the ChangeLog. If that
+ ;; doesn't occur anywhere, they're not using full relative
+ ;; filenames in the ChangeLog, so just look for FILE; we'll accept
+ ;; some false positives.
+ (let ((pattern (file-relative-name
+ file (file-name-directory changelog-file-name))))
+ (if (or (string= pattern "")
+ (not (save-excursion
+ (search-forward pattern nil t))))
+ (setq pattern (file-name-nondirectory file)))
+
+ (setq pattern (concat "\\(^\\|[^[:alnum:]]\\)"
+ pattern
+ "\\($\\|[^[:alnum:]]\\)"))
+
+ (let (texts
+ (pos (point)))
+ (while (and (not (eobp)) (re-search-forward pattern nil t))
+ (let ((entry (log-edit-changelog-entry)))
+ (if (< (elt entry 1) (max (1+ pos) (point)))
+ ;; This is not relevant, actually.
+ nil
+ (push entry texts))
+ ;; Make sure we make progress.
+ (setq pos (max (1+ pos) (elt entry 1)))
+ (goto-char pos)))
+
+ (cons (current-buffer) texts))))))))
+
+(defun log-edit-changelog-insert-entries (buffer beg end &rest files)
+ "Insert the text from BUFFER between BEG and END.
+Rename relative filenames in the ChangeLog entry as FILES."
+ (let ((opoint (point))
+ (log-name (buffer-file-name buffer))
+ (case-fold-search nil)
+ bound)
+ (insert-buffer-substring buffer beg end)
+ (setq bound (point-marker))
+ (when log-name
+ (dolist (f files)
+ (save-excursion
+ (goto-char opoint)
+ (when (re-search-forward
+ (concat "\\(^\\|[ \t]\\)\\("
+ (file-relative-name f (file-name-directory log-name))
+ "\\)[, :\n]")
+ bound t)
+ (replace-match f t t nil 2)))))
+ ;; Eliminate tabs at the beginning of the line.
+ (save-excursion
+ (goto-char opoint)
+ (while (re-search-forward "^\\(\t+\\)" bound t)
+ (replace-match "")))))
+
+(defun log-edit-insert-changelog-entries (files)
+ "Given a list of files FILES, insert the ChangeLog entries for them."
+ (let ((log-entries nil))
+ ;; Note that any ChangeLog entry can apply to more than one file.
+ ;; Here we construct a log-entries list with elements of the form
+ ;; ((LOGBUFFER ENTRYSTART ENTRYEND) FILE1 FILE2...)
+ (dolist (file files)
+ (let* ((entries (log-edit-changelog-entries file))
+ (buf (car entries))
+ key entry)
+ (dolist (region (cdr entries))
+ (setq key (cons buf region))
+ (if (setq entry (assoc key log-entries))
+ (setcdr entry (append (cdr entry) (list file)))
+ (push (list key file) log-entries)))))
+ ;; Now map over log-entries, and extract the strings.
+ (dolist (log-entry (nreverse log-entries))
+ (apply 'log-edit-changelog-insert-entries
+ (append (car log-entry) (cdr log-entry)))
+ (insert "\n"))))
+
+(defun log-edit-extract-headers (headers comment)
+ "Extract headers from COMMENT to form command line arguments.
+HEADERS should be an alist with elements of the form (HEADER . CMDARG)
+associating header names to the corresponding cmdline option name and the
+result is then a list of the form (MSG CMDARG1 HDRTEXT1 CMDARG2 HDRTEXT2...).
+where MSG is the remaining text from STRING.
+If \"Summary\" is not in HEADERS, then the \"Summary\" header is extracted
+anyway and put back as the first line of MSG."
+ (with-temp-buffer
+ (insert comment)
+ (rfc822-goto-eoh)
+ (narrow-to-region (point-min) (point))
+ (let ((case-fold-search t)
+ (summary ())
+ (res ()))
+ (dolist (header (if (assoc "Summary" headers) headers
+ (cons '("Summary" . t) headers)))
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^" (car header)
+ ":" log-edit-header-contents-regexp)
+ nil t)
+ (if (eq t (cdr header))
+ (setq summary (match-string 1))
+ (push (match-string 1) res)
+ (push (or (cdr header) (car header)) res))
+ (replace-match "" t t)))
+ ;; Remove header separator if the header is empty.
+ (widen)
+ (goto-char (point-min))
+ (when (looking-at "\\([ \t]*\n\\)+")
+ (delete-region (match-beginning 0) (match-end 0)))
+ (if summary (insert summary "\n"))
+ (cons (buffer-string) res))))
+
+(provide 'log-edit)
+
+;; arch-tag: 8089b39c-983b-4e83-93cd-ed0a64c7fdcc
+;;; log-edit.el ends here
--- /dev/null
+;;; log-view.el --- Major mode for browsing RCS/CVS/SCCS log output
+
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: rcs, sccs, cvs, log, version control, tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Major mode to browse revision log histories.
+;; Currently supports the format output by:
+;; RCS, SCCS, CVS, Subversion, and DaRCS.
+
+;; Examples of log output:
+
+;;;; RCS/CVS:
+
+;; ----------------------------
+;; revision 1.35 locked by: turlutut
+;; date: 2005-03-22 18:48:38 +0000; author: monnier; state: Exp; lines: +6 -8
+;; (gnus-display-time-event-handler):
+;; Check display-time-timer at runtime rather than only at load time
+;; in case display-time-mode is turned off in the mean time.
+;; ----------------------------
+;; revision 1.34
+;; date: 2005-02-09 15:50:38 +0000; author: kfstorm; state: Exp; lines: +7 -7
+;; branches: 1.34.2;
+;; Change release version from 21.4 to 22.1 throughout.
+;; Change development version from 21.3.50 to 22.0.50.
+
+;;;; SCCS:
+
+;;;; Subversion:
+
+;; ------------------------------------------------------------------------
+;; r4622 | ckuethe | 2007-12-23 18:18:01 -0500 (Sun, 23 Dec 2007) | 2 lines
+;;
+;; uBlox AEK-4T in binary mode. Added to unstable because it breaks gpsfake
+;;
+;; ------------------------------------------------------------------------
+;; r4621 | ckuethe | 2007-12-23 16:48:11 -0500 (Sun, 23 Dec 2007) | 3 lines
+;;
+;; Add a note about requiring usbfs to use the garmin gps18 (usb)
+;; Mention firmware testing the AC12 with firmware BQ00 and BQ04
+;;
+;; ------------------------------------------------------------------------
+;; r4620 | ckuethe | 2007-12-23 15:52:34 -0500 (Sun, 23 Dec 2007) | 1 line
+;;
+;; add link to latest hardware reference
+;; ------------------------------------------------------------------------
+;; r4619 | ckuethe | 2007-12-23 14:37:31 -0500 (Sun, 23 Dec 2007) | 1 line
+;;
+;; there is now a regression test for AC12 without raw data output
+
+;;;; Darcs:
+
+;; Changes to darcsum.el:
+;;
+;; Mon Nov 28 15:19:38 GMT 2005 Dave Love <fx@gnu.org>
+;; * Abstract process startup into darcsum-start-process. Use TERM=dumb.
+;; TERM=dumb avoids escape characters, at least, for any old darcs that
+;; doesn't understand DARCS_DONT_COLOR & al.
+;;
+;; Thu Nov 24 15:20:45 GMT 2005 Dave Love <fx@gnu.org>
+;; * darcsum-mode-related changes.
+;; Don't call font-lock-mode (unnecessary) or use-local-map (redundant).
+;; Use mode-class 'special. Add :group.
+;; Add trailing-whitespace option to mode hook and fix
+;; darcsum-display-changeset not to use trailing whitespace.
+
+;;;; Mercurial
+
+;; changeset: 11:8ff1a4166444
+;; tag: tip
+;; user: Eric S. Raymond <esr@thyrsus.com>
+;; date: Wed Dec 26 12:18:58 2007 -0500
+;; summary: Explain keywords. Add markup fixes.
+;;
+;; changeset: 10:20abc7ab09c3
+;; user: Eric S. Raymond <esr@thyrsus.com>
+;; date: Wed Dec 26 11:37:28 2007 -0500
+;; summary: Typo fixes.
+;;
+;; changeset: 9:ada9f4da88aa
+;; user: Eric S. Raymond <esr@thyrsus.com>
+;; date: Wed Dec 26 11:23:00 2007 -0500
+;; summary: Add RCS example session.
+
+;;; Todo:
+
+;; - add ability to modify a log-entry (via cvs-mode-admin ;-)
+;; - remove references to cvs-*
+;; - make it easier to add support for new backends without changing the code.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'pcvs-util)
+(autoload 'vc-find-revision "vc")
+(autoload 'vc-diff-internal "vc")
+
+(defvar cvs-minor-wrap-function)
+
+(defgroup log-view nil
+ "Major mode for browsing log output of RCS/CVS/SCCS."
+ :group 'pcl-cvs
+ :prefix "log-view-")
+
+;; Needed because log-view-mode-map inherits from widget-keymap. (Bug#5311)
+(require 'wid-edit)
+
+(easy-mmode-defmap log-view-mode-map
+ '(("z" . kill-this-buffer)
+ ("q" . quit-window)
+ ("m" . log-view-toggle-mark-entry)
+ ("e" . log-view-modify-change-comment)
+ ("d" . log-view-diff)
+ ("=" . log-view-diff)
+ ("D" . log-view-diff-changeset)
+ ("a" . log-view-annotate-version)
+ ("f" . log-view-find-revision)
+ ("n" . log-view-msg-next)
+ ("p" . log-view-msg-prev)
+ ("\t" . log-view-msg-next)
+ ([backtab] . log-view-msg-prev)
+ ("N" . log-view-file-next)
+ ("P" . log-view-file-prev)
+ ("\M-n" . log-view-file-next)
+ ("\M-p" . log-view-file-prev))
+ "Log-View's keymap."
+ :inherit widget-keymap
+ :group 'log-view)
+
+(easy-menu-define log-view-mode-menu log-view-mode-map
+ "Log-View Display Menu"
+ `("Log-View"
+ ;; XXX Do we need menu entries for these?
+ ;; ["Quit" quit-window]
+ ;; ["Kill This Buffer" kill-this-buffer]
+ ["Mark Log Entry for Diff" set-mark-command
+ :help ""]
+ ["Diff Revisions" log-view-diff
+ :help "Get the diff between two revisions"]
+ ["Changeset Diff" log-view-diff-changeset
+ :help "Get the changeset diff between two revisions"]
+ ["Visit Version" log-view-find-revision
+ :help "Visit the version at point"]
+ ["Annotate Version" log-view-annotate-version
+ :help "Annotate the version at point"]
+ ["Modify Log Comment" log-view-modify-change-comment
+ :help "Edit the change comment displayed at point"]
+ "-----"
+ ["Next Log Entry" log-view-msg-next
+ :help "Go to the next count'th log message"]
+ ["Previous Log Entry" log-view-msg-prev
+ :help "Go to the previous count'th log message"]
+ ["Next File" log-view-file-next
+ :help "Go to the next count'th file"]
+ ["Previous File" log-view-file-prev
+ :help "Go to the previous count'th file"]))
+
+(defvar log-view-mode-hook nil
+ "Hook run at the end of `log-view-mode'.")
+
+(defface log-view-file
+ '((((class color) (background light))
+ (:background "grey70" :weight bold))
+ (t (:weight bold)))
+ "Face for the file header line in `log-view-mode'."
+ :group 'log-view)
+(define-obsolete-face-alias 'log-view-file-face 'log-view-file "22.1")
+(defvar log-view-file-face 'log-view-file)
+
+(defface log-view-message
+ '((((class color) (background light))
+ (:background "grey85"))
+ (t (:weight bold)))
+ "Face for the message header line in `log-view-mode'."
+ :group 'log-view)
+;; backward-compatibility alias
+(define-obsolete-face-alias 'log-view-message-face 'log-view-message "22.1")
+(defvar log-view-message-face 'log-view-message)
+
+(defvar log-view-file-re
+ (concat "^\\(?:Working file: \\(?1:.+\\)" ;RCS and CVS.
+ ;; Subversion has no such thing??
+ "\\|\\(?:SCCS/s\\.\\|Changes to \\)\\(?1:.+\\):" ;SCCS and Darcs.
+ "\\)\n") ;Include the \n for font-lock reasons.
+ "Regexp matching the text identifying the file.
+The match group number 1 should match the file name itself.")
+
+(defvar log-view-per-file-logs t
+ "Set if to t if the logs are shown one file at a time.")
+
+(defvar log-view-message-re
+ (concat "^\\(?:revision \\(?1:[.0-9]+\\)\\(?:\t.*\\)?" ; RCS and CVS.
+ "\\|r\\(?1:[0-9]+\\) | .* | .*" ; Subversion.
+ "\\|D \\(?1:[.0-9]+\\) .*" ; SCCS.
+ ;; Darcs doesn't have revision names. VC-darcs uses patch names
+ ;; instead. Darcs patch names are hashcodes, which do not appear
+ ;; in the log output :-(, but darcs accepts any prefix of the log
+ ;; message as a patch name, so we match the first line of the log
+ ;; message.
+ ;; First loosely match the date format.
+ (concat "\\|[^ \n].*[^0-9\n][0-9][0-9]:[0-9][0-9][^0-9\n].*[^ \n]"
+ ;;Email of user and finally Msg, used as revision name.
+ " .*@.*\n\\(?: \\* \\(?1:.*\\)\\)?")
+ "\\)$")
+ "Regexp matching the text identifying a revision.
+The match group number 1 should match the revision number itself.")
+
+(defvar log-view-font-lock-keywords
+ ;; We use `eval' so as to use the buffer-local value of log-view-file-re
+ ;; and log-view-message-re, if applicable.
+ '((eval . `(,log-view-file-re
+ (1 (if (boundp 'cvs-filename-face) cvs-filename-face))
+ (0 log-view-file-face append)))
+ (eval . `(,log-view-message-re . log-view-message-face))))
+
+(defconst log-view-font-lock-defaults
+ '(log-view-font-lock-keywords t nil nil nil))
+
+(defvar log-view-vc-fileset nil
+ "Set this to the fileset corresponding to the current log.")
+
+(defvar log-view-vc-backend nil
+ "Set this to the VC backend that created the current log.")
+
+;;;;
+;;;; Actual code
+;;;;
+
+;;;###autoload
+(define-derived-mode log-view-mode special-mode "Log-View"
+ "Major mode for browsing CVS log output."
+ (setq buffer-read-only t)
+ (set (make-local-variable 'font-lock-defaults) log-view-font-lock-defaults)
+ (set (make-local-variable 'beginning-of-defun-function)
+ 'log-view-beginning-of-defun)
+ (set (make-local-variable 'end-of-defun-function)
+ 'log-view-end-of-defun)
+ (set (make-local-variable 'cvs-minor-wrap-function) 'log-view-minor-wrap)
+ (hack-dir-local-variables-non-file-buffer))
+
+;;;;
+;;;; Navigation
+;;;;
+
+;; define log-view-{msg,file}-{next,prev}
+(easy-mmode-define-navigation log-view-msg log-view-message-re "log message")
+(easy-mmode-define-navigation log-view-file log-view-file-re "file")
+
+(defun log-view-goto-rev (rev)
+ (goto-char (point-min))
+ (ignore-errors
+ (while (not (equal rev (log-view-current-tag)))
+ (log-view-msg-next))
+ t))
+
+;;;;
+;;;; Linkage to PCL-CVS (mostly copied from cvs-status.el)
+;;;;
+
+(defconst log-view-dir-re "^cvs[.ex]* [a-z]+: Logging \\(.+\\)$")
+
+(defun log-view-current-file ()
+ (save-excursion
+ (forward-line 1)
+ (or (re-search-backward log-view-file-re nil t)
+ (re-search-forward log-view-file-re nil t)
+ (error "Unable to determine the current file"))
+ (let* ((file (match-string 1))
+ (cvsdir (and (re-search-backward log-view-dir-re nil t)
+ (match-string 1)))
+ (pcldir (and (boundp 'cvs-pcl-cvs-dirchange-re)
+ (re-search-backward cvs-pcl-cvs-dirchange-re nil t)
+ (match-string 1)))
+ (dir ""))
+ (let ((default-directory ""))
+ (when pcldir (setq dir (expand-file-name pcldir dir)))
+ (when cvsdir (setq dir (expand-file-name cvsdir dir))))
+ (expand-file-name file dir))))
+
+(defun log-view-current-tag (&optional where)
+ (save-excursion
+ (when where (goto-char where))
+ (forward-line 1)
+ (let ((pt (point)))
+ (when (re-search-backward log-view-message-re nil t)
+ (let ((rev (match-string-no-properties 1)))
+ (unless (re-search-forward log-view-file-re pt t)
+ rev))))))
+
+(defun log-view-toggle-mark-entry ()
+ "Toggle the marked state for the log entry at point.
+Individual log entries can be marked and unmarked. The marked
+entries are denoted by changing their background color.
+`log-view-get-marked' returns the list of tags for the marked
+log entries."
+ (interactive)
+ (save-excursion
+ (forward-line 1)
+ (let ((pt (point)))
+ (when (re-search-backward log-view-message-re nil t)
+ (let ((beg (match-beginning 0))
+ end ov ovlist found tag)
+ (unless (re-search-forward log-view-file-re pt t)
+ ;; Look to see if the current entry is marked.
+ (setq found (get-char-property (point) 'log-view-self))
+ (if found
+ (delete-overlay found)
+ ;; Create an overlay that covers this entry and change
+ ;; its color.
+ (setq tag (log-view-current-tag (point)))
+ (forward-line 1)
+ (setq end
+ (if (re-search-forward log-view-message-re nil t)
+ (match-beginning 0)
+ (point-max)))
+ (setq ov (make-overlay beg end))
+ (overlay-put ov 'face 'log-view-file)
+ ;; This is used to check if the overlay is present.
+ (overlay-put ov 'log-view-self ov)
+ (overlay-put ov 'log-view-marked tag))))))))
+
+(defun log-view-get-marked ()
+ "Return the list of tags for the marked log entries."
+ (save-excursion
+ (let ((pos (point-min))
+ marked-list ov)
+ (while (setq pos (next-single-property-change pos 'face))
+ (when (setq ov (get-char-property pos 'log-view-self))
+ (push (overlay-get ov 'log-view-marked) marked-list)
+ (setq pos (overlay-end ov))))
+ marked-list)))
+
+(defun log-view-beginning-of-defun ()
+ ;; This assumes that a log entry starts with a line matching
+ ;; `log-view-message-re'. Modes that derive from `log-view-mode'
+ ;; for which this assumption is not valid will have to provide
+ ;; another implementation of this function. `log-view-msg-prev'
+ ;; does a similar job to this function, we can't use it here
+ ;; directly because it prints messages that are not appropriate in
+ ;; this context and it does not move to the beginning of the buffer
+ ;; when the point is before the first log entry.
+
+ ;; `log-view-beginning-of-defun' and `log-view-end-of-defun' have
+ ;; been checked to work with logs produced by RCS, CVS, git,
+ ;; mercurial and subversion.
+
+ (re-search-backward log-view-message-re nil 'move))
+
+(defun log-view-end-of-defun ()
+ ;; The idea in this function is to search for the beginning of the
+ ;; next log entry using `log-view-message-re' and then go back one
+ ;; line when finding it. Modes that derive from `log-view-mode' for
+ ;; which this assumption is not valid will have to provide another
+ ;; implementation of this function.
+
+ ;; Look back and if there is no entry there it means we are before
+ ;; the first log entry, so go forward until finding one.
+ (unless (save-excursion (re-search-backward log-view-message-re nil t))
+ (re-search-forward log-view-message-re nil t))
+
+ ;; In case we are at the end of log entry going forward a line will
+ ;; make us find the next entry when searching. If we are inside of
+ ;; an entry going forward a line will still keep the point inside
+ ;; the same entry.
+ (forward-line 1)
+
+ ;; In case we are at the beginning of an entry, move past it.
+ (when (looking-at log-view-message-re)
+ (goto-char (match-end 0))
+ (forward-line 1))
+
+ ;; Search for the start of the next log entry. Go to the end of the
+ ;; buffer if we could not find a next entry.
+ (when (re-search-forward log-view-message-re nil 'move)
+ (goto-char (match-beginning 0))
+ (forward-line -1)))
+
+(defvar cvs-minor-current-files)
+(defvar cvs-branch-prefix)
+(defvar cvs-secondary-branch-prefix)
+
+(defun log-view-minor-wrap (buf f)
+ (let ((data (with-current-buffer buf
+ (let* ((beg (point))
+ (end (if mark-active (mark) (point)))
+ (fr (log-view-current-tag beg))
+ (to (log-view-current-tag end)))
+ (when (string-equal fr to)
+ (save-excursion
+ (goto-char end)
+ (log-view-msg-next)
+ (setq to (log-view-current-tag))))
+ (cons
+ ;; The first revision has to be the one at point, for
+ ;; operations that only take one revision
+ ;; (e.g. cvs-mode-edit).
+ (cons (log-view-current-file) fr)
+ (cons (log-view-current-file) to))))))
+ (let ((cvs-branch-prefix (cdar data))
+ (cvs-secondary-branch-prefix (and (cdar data) (cddr data)))
+ (cvs-minor-current-files
+ (cons (caar data)
+ (when (and (cadr data) (not (equal (caar data) (cadr data))))
+ (list (cadr data)))))
+ ;; FIXME: I need to force because the fileinfos are UNKNOWN
+ (cvs-force-command "/F"))
+ (funcall f))))
+
+(defun log-view-find-revision (pos)
+ "Visit the version at point."
+ (interactive "d")
+ (unless log-view-per-file-logs
+ (when (> (length log-view-vc-fileset) 1)
+ (error "Multiple files shown in this buffer, cannot use this command here")))
+ (save-excursion
+ (goto-char pos)
+ (switch-to-buffer (vc-find-revision (if log-view-per-file-logs
+ (log-view-current-file)
+ (car log-view-vc-fileset))
+ (log-view-current-tag)))))
+
+
+(defun log-view-extract-comment ()
+ "Parse comment from around the current point in the log."
+ (save-excursion
+ (let (st en (backend (vc-backend (log-view-current-file))))
+ (log-view-end-of-defun)
+ (cond ((eq backend 'SVN)
+ (forward-line -1)))
+ (setq en (point))
+ (log-view-beginning-of-defun)
+ (cond ((memq backend '(SCCS RCS CVS MCVS SVN))
+ (forward-line 2))
+ ((eq backend 'Hg)
+ (forward-line 4)
+ (re-search-forward "summary: *" nil t)))
+ (setq st (point))
+ (buffer-substring st en))))
+
+(declare-function vc-modify-change-comment "vc" (files rev oldcomment))
+
+(defun log-view-modify-change-comment ()
+ "Edit the change comment displayed at point."
+ (interactive)
+ (vc-modify-change-comment (list (if log-view-per-file-logs
+ (log-view-current-file)
+ (car log-view-vc-fileset)))
+ (log-view-current-tag)
+ (log-view-extract-comment)))
+
+(defun log-view-annotate-version (pos)
+ "Annotate the version at point."
+ (interactive "d")
+ (unless log-view-per-file-logs
+ (when (> (length log-view-vc-fileset) 1)
+ (error "Multiple files shown in this buffer, cannot use this command here")))
+ (save-excursion
+ (goto-char pos)
+ (vc-annotate (if log-view-per-file-logs
+ (log-view-current-file)
+ (car log-view-vc-fileset))
+ (log-view-current-tag))))
+
+;;
+;; diff
+;;
+
+(defun log-view-diff (beg end)
+ "Get the diff between two revisions.
+If the mark is not active or the mark is on the revision at point,
+get the diff between the revision at point and its previous revision.
+Otherwise, get the diff between the revisions where the region starts
+and ends.
+Contrary to `log-view-diff-changeset', it will only show the part of the
+changeset that affected the currently considered file(s)."
+ (interactive
+ (list (if mark-active (region-beginning) (point))
+ (if mark-active (region-end) (point))))
+ (let ((fr (log-view-current-tag beg))
+ (to (log-view-current-tag end)))
+ (when (string-equal fr to)
+ (save-excursion
+ (goto-char end)
+ (log-view-msg-next)
+ (setq to (log-view-current-tag))))
+ (vc-diff-internal
+ t (list log-view-vc-backend
+ (if log-view-per-file-logs
+ (list (log-view-current-file))
+ log-view-vc-fileset))
+ to fr)))
+
+(declare-function vc-diff-internal "vc"
+ (async vc-fileset rev1 rev2 &optional verbose))
+
+(defun log-view-diff-changeset (beg end)
+ "Get the diff between two revisions.
+If the mark is not active or the mark is on the revision at point,
+get the diff between the revision at point and its previous revision.
+Otherwise, get the diff between the revisions where the region starts
+and ends.
+Contrary to `log-view-diff', it will show the whole changeset including
+the changes that affected other files than the currently considered file(s)."
+ (interactive
+ (list (if mark-active (region-beginning) (point))
+ (if mark-active (region-end) (point))))
+ (when (eq (vc-call-backend log-view-vc-backend 'revision-granularity) 'file)
+ (error "The %s backend does not support changeset diffs" log-view-vc-backend))
+ (let ((fr (log-view-current-tag beg))
+ (to (log-view-current-tag end)))
+ (when (string-equal fr to)
+ ;; TO and FR are the same, look at the previous revision.
+ (setq to (vc-call-backend log-view-vc-backend 'previous-revision nil fr)))
+ (vc-diff-internal
+ t
+ ;; We want to see the diff for all the files in the changeset, so
+ ;; pass NIL for the file list. The value passed here should
+ ;; follow what `vc-deduce-fileset' returns.
+ (list log-view-vc-backend nil)
+ to fr)))
+
+(provide 'log-view)
+
+;; arch-tag: 0d64220b-ce7e-4f62-9c2a-6b04c2f81f4f
+;;; log-view.el ends here
--- /dev/null
+;;; pcvs-defs.el --- variable definitions for PCL-CVS
+
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: pcl-cvs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'pcvs-util)
+
+;;;; -------------------------------------------------------
+;;;; START OF THINGS TO CHECK WHEN INSTALLING
+
+(defvar cvs-program "cvs"
+ "*Name or full path of the cvs executable.")
+
+(defvar cvs-version
+ ;; With the divergence of the CVSNT codebase and version numbers, this is
+ ;; not really good any more.
+ (ignore-errors
+ (with-temp-buffer
+ (call-process cvs-program nil t nil "-v")
+ (goto-char (point-min))
+ (when (re-search-forward "(CVS\\(NT\\)?) \\([0-9]+\\)\\.\\([0-9]+\\)"
+ nil t)
+ (cons (string-to-number (match-string 1))
+ (string-to-number (match-string 2))))))
+ "*Version of `cvs' installed on your system.
+It must be in the (MAJOR . MINOR) format.")
+
+;; FIXME: this is only used by cvs-mode-diff-backup
+(defvar cvs-diff-program (or (and (boundp 'diff-command) diff-command) "diff")
+ "*Name or full path of the best diff program you've got.
+NOTE: there are some nasty bugs in the context diff variants of some vendor
+versions, such as the one in SunOS-4.")
+
+;;;; END OF THINGS TO CHECK WHEN INSTALLING
+;;;; --------------------------------------------------------
+
+;;;;
+;;;; User configuration variables:
+;;;;
+;;;; NOTE: these should be set in your ~/.emacs (or site-lisp/default.el) file.
+;;;;
+
+(defgroup pcl-cvs nil
+ "Special support for the CVS versioning system."
+ :version "21.1"
+ :group 'tools
+ :prefix "cvs-")
+
+;;
+;; cvsrc options
+;;
+
+(defcustom cvs-cvsrc-file (convert-standard-filename "~/.cvsrc")
+ "Path to your cvsrc file."
+ :group 'pcl-cvs
+ :type '(file))
+
+(defvar cvs-shared-start 4
+ "Index of the first shared flag.
+If set to 4, for instance, a numeric argument smaller than 4 will
+select a non-shared flag, while a numeric argument greater than 3
+will select a shared-flag.")
+
+(defvar cvs-shared-flags (make-list cvs-shared-start nil)
+ "List of flags whose settings is shared among several commands.")
+
+(defvar cvs-cvsroot nil
+ "*Specifies where the (current) cvs master repository is.
+Overrides the environment variable $CVSROOT by sending \" -d dir\" to
+all CVS commands. This switch is useful if you have multiple CVS
+repositories. It can be set interactively with \\[cvs-change-cvsroot.]
+There is no need to set this if $CVSROOT is set to a correct value.")
+
+(defcustom cvs-auto-remove-handled nil
+ "If up-to-date files should be acknowledged automatically.
+If T, they will be removed from the *cvs* buffer after every command.
+If DELAYED, they will be removed from the *cvs* buffer before every command.
+If STATUS, they will only be removed after a `cvs-mode-status' command.
+Else, they will never be automatically removed from the *cvs* buffer."
+ :group 'pcl-cvs
+ :type '(choice (const nil) (const status) (const delayed) (const t)))
+
+(defcustom cvs-auto-remove-directories 'handled
+ "If ALL, directory entries will never be shown.
+If HANDLED, only non-handled directories will be shown.
+If EMPTY, only non-empty directories will be shown."
+ :group 'pcl-cvs
+ :type '(choice (const :tag "No" nil) (const all) (const handled) (const empty)))
+
+(defcustom cvs-auto-revert t
+ "Non-nil if changed files should automatically be reverted."
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defcustom cvs-sort-ignore-file t
+ "Non-nil if `cvs-mode-ignore' should sort the .cvsignore automatically."
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defcustom cvs-force-dir-tag t
+ "If non-nil, tagging can only be applied to directories.
+Tagging should generally be applied a directory at a time, but sometimes it is
+useful to be able to tag a single file. The normal way to do that is to use
+`cvs-mode-force-command' so as to temporarily override the restrictions,"
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defcustom cvs-default-ignore-marks nil
+ "Non-nil if cvs mode commands should ignore any marked files.
+Normally they run on the files that are marked (with `cvs-mode-mark'),
+or the file under the cursor if no files are marked. If this variable
+is set to a non-nil value they will by default run on the file on the
+current line. See also `cvs-invert-ignore-marks'"
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defvar cvs-diff-ignore-marks t)
+(make-obsolete-variable 'cvs-diff-ignore-marks
+ 'cvs-invert-ignore-marks
+ "21.1")
+
+(defcustom cvs-invert-ignore-marks
+ (let ((l ()))
+ (unless (equal cvs-diff-ignore-marks cvs-default-ignore-marks)
+ (push "diff" l))
+ (when (and cvs-force-dir-tag (not cvs-default-ignore-marks))
+ (push "tag" l))
+ l)
+ "List of cvs commands that invert the default ignore-mark behavior.
+Commands in this set will use the opposite default from the one set
+in `cvs-default-ignore-marks'."
+ :group 'pcl-cvs
+ :type '(set (const "diff")
+ (const "tag")
+ (const "ignore")))
+
+(defcustom cvs-confirm-removals t
+ "Ask for confirmation before removing files.
+Non-nil means that PCL-CVS will ask confirmation before removing files
+except for files whose content can readily be recovered from the repository.
+A value of `list' means that the list of files to be deleted will be
+displayed when asking for confirmation."
+ :group 'pcl-cvs
+ :type '(choice (const list)
+ (const t)
+ (const nil)))
+
+(defcustom cvs-add-default-message nil
+ "Default message to use when adding files.
+If set to nil, `cvs-mode-add' will always prompt for a message."
+ :group 'pcl-cvs
+ :type '(choice (const :tag "Prompt" nil)
+ (string)))
+
+(defvar cvs-diff-buffer-name "*cvs-diff*")
+(make-obsolete-variable 'cvs-diff-buffer-name
+ 'cvs-buffer-name-alist
+ "21.1")
+
+(defcustom cvs-find-file-and-jump nil
+ "Jump to the modified area when finding a file.
+If non-nil, `cvs-mode-file-file' will place the cursor at the beginning of
+the modified area. If the file is not locally modified, this will obviously
+have no effect."
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defcustom cvs-buffer-name-alist
+ '(("diff" cvs-diff-buffer-name diff-mode)
+ ("status" "*cvs-info*" cvs-status-mode)
+ ("tree" "*cvs-info*" cvs-status-mode)
+ ("message" "*cvs-commit*" nil log-edit)
+ ("log" "*cvs-info*" log-view-mode))
+ "Buffer name and mode to be used for each command.
+This is a list of elements of the form
+
+ (CMD BUFNAME MODE &optional POSTPROC)
+
+CMD is the name of the command.
+BUFNAME is an expression that should evaluate to a string used as
+ a buffer name. It can use the variable CMD if it wants to.
+MODE is the command to use to setup the buffer.
+POSTPROC is a function that should be executed when the command terminates
+
+The CMD used for `cvs-mode-commit' is \"message\". For that special
+ case, POSTPROC is called just after MODE with special arguments."
+ :group 'pcl-cvs
+ :type '(repeat
+ (list (choice (const "diff")
+ (const "status")
+ (const "tree")
+ (const "message")
+ (const "log")
+ (string))
+ (choice (const "*vc-diff*")
+ (const "*cvs-info*")
+ (const "*cvs-commit*")
+ (const (expand-file-name "*cvs-commit*"))
+ (const (format "*cvs-%s*" cmd))
+ (const (expand-file-name (format "*cvs-%s*" cmd)))
+ (sexp :value "my-cvs-info-buffer")
+ (const nil))
+ (choice (function-item diff-mode)
+ (function-item cvs-edit-mode)
+ (function-item cvs-status-mode)
+ function
+ (const nil))
+ (set :inline t
+ (choice (function-item cvs-status-cvstrees)
+ (function-item cvs-status-trees)
+ function)))))
+
+(defvar cvs-buffer-name '(expand-file-name "*cvs*" dir) ;; "*cvs*"
+ "Name of the cvs buffer.
+This expression will be evaluated in an environment where DIR is set to
+the directory name of the cvs buffer.")
+
+(defvar cvs-temp-buffer-name
+ ;; Was '(expand-file-name " *cvs-tmp*" dir), but that causes them to
+ ;; become non-hidden if uniquification is done `forward'.
+ " *cvs-tmp*"
+ "*Name of the cvs temporary buffer.
+Output from cvs is placed here for asynchronous commands.")
+
+(defcustom cvs-idiff-imerge-handlers
+ (if (fboundp 'ediff)
+ '(cvs-ediff-diff . cvs-ediff-merge)
+ '(cvs-emerge-diff . cvs-emerge-merge))
+ "Pair of functions to be used for resp. diff'ing and merg'ing interactively."
+ :group 'pcl-cvs
+ :type '(choice (const :tag "Ediff" (cvs-ediff-diff . cvs-ediff-merge))
+ (const :tag "Emerge" (cvs-emerge-diff . cvs-emerge-merge))))
+
+(defvar cvs-mode-hook nil
+ "Run after `cvs-mode' was setup.")
+
+\f
+;;;;
+;;;; Internal variables, used in the process buffer.
+;;;;
+
+(defvar cvs-postprocess nil
+ "(Buffer local) what to do once the process exits.")
+
+;;;;
+;;;; Internal variables for the *cvs* buffer.
+;;;;
+
+(defcustom cvs-reuse-cvs-buffer 'subdir
+ "When to reuse an existing cvs buffer.
+Alternatives are:
+ CURRENT: just reuse the current buffer if it is a cvs buffer
+ SAMEDIR: reuse any cvs buffer displaying the same directory
+ SUBDIR: or reuse any cvs buffer displaying any sub- or super- directory
+ ALWAYS: reuse any cvs buffer."
+ :group 'pcl-cvs
+ :type '(choice (const always) (const subdir) (const samedir) (const current)))
+
+(defvar cvs-temp-buffer nil
+ "(Buffer local) The temporary buffer associated with this *cvs* buffer.")
+
+(defvar cvs-lock-file nil
+ "Full path to a lock file that CVS is waiting for (or was waiting for).
+This variable is buffer local and only used in the *cvs* buffer.")
+
+(defvar cvs-lock-file-regexp "^#cvs\\.\\([trw]fl\\.[-.a-z0-9]+\\|lock\\)\\'"
+ "Regexp matching the possible names of locks in the CVS repository.")
+
+(defconst cvs-cursor-column 22
+ "Column to position cursor in in `cvs-mode'.")
+
+;;;;
+;;;; Global internal variables
+;;;;
+
+(defconst cvs-vendor-branch "1.1.1"
+ "The default branch used by CVS for vendor code.")
+
+(easy-mmode-defmap cvs-mode-diff-map
+ '(("E" "imerge" . cvs-mode-imerge)
+ ("=" . cvs-mode-diff)
+ ("e" "idiff" . cvs-mode-idiff)
+ ("2" "other" . cvs-mode-idiff-other)
+ ("d" "diff" . cvs-mode-diff)
+ ("b" "backup" . cvs-mode-diff-backup)
+ ("h" "head" . cvs-mode-diff-head)
+ ("r" "repository" . cvs-mode-diff-repository)
+ ("y" "yesterday" . cvs-mode-diff-yesterday)
+ ("v" "vendor" . cvs-mode-diff-vendor))
+ "Keymap for diff-related operations in `cvs-mode'."
+ :name "Diff")
+;; This is necessary to allow correct handling of \\[cvs-mode-diff-map]
+;; in substitute-command-keys.
+(fset 'cvs-mode-diff-map cvs-mode-diff-map)
+
+(easy-mmode-defmap cvs-mode-map
+ ;;(define-prefix-command 'cvs-mode-map-diff-prefix)
+ ;;(define-prefix-command 'cvs-mode-map-control-c-prefix)
+ '(;; various
+ ;; (undo . cvs-mode-undo)
+ ("?" . cvs-help)
+ ("h" . cvs-help)
+ ("q" . cvs-bury-buffer)
+ ("z" . kill-this-buffer)
+ ("F" . cvs-mode-set-flags)
+ ;; ("\M-f" . cvs-mode-force-command)
+ ("!" . cvs-mode-force-command)
+ ("\C-c\C-c" . cvs-mode-kill-process)
+ ;; marking
+ ("m" . cvs-mode-mark)
+ ("M" . cvs-mode-mark-all-files)
+ ("S" . cvs-mode-mark-on-state)
+ ("u" . cvs-mode-unmark)
+ ("\C-?". cvs-mode-unmark-up)
+ ("%" . cvs-mode-mark-matching-files)
+ ("T" . cvs-mode-toggle-marks)
+ ("\M-\C-?" . cvs-mode-unmark-all-files)
+ ;; navigation keys
+ (" " . cvs-mode-next-line)
+ ("n" . cvs-mode-next-line)
+ ("p" . cvs-mode-previous-line)
+ ("\t" . cvs-mode-next-line)
+ ([backtab] . cvs-mode-previous-line)
+ ;; M- keys are usually those that operate on modules
+ ;;("\M-C". cvs-mode-rcs2log) ; i.e. "Create a ChangeLog"
+ ;;("\M-t". cvs-rtag)
+ ;;("\M-l". cvs-rlog)
+ ("\M-c". cvs-checkout)
+ ("\M-e". cvs-examine)
+ ("g" . cvs-mode-revert-buffer)
+ ("\M-u". cvs-update)
+ ("\M-s". cvs-status)
+ ;; diff commands
+ ("=" . cvs-mode-diff)
+ ("d" . cvs-mode-diff-map)
+ ;; keys that operate on individual files
+ ("\C-k" . cvs-mode-acknowledge)
+ ("A" . cvs-mode-add-change-log-entry-other-window)
+ ;;("B" . cvs-mode-byte-compile-files)
+ ("C" . cvs-mode-commit-setup)
+ ("O" . cvs-mode-update)
+ ("U" . cvs-mode-undo)
+ ("I" . cvs-mode-insert)
+ ("a" . cvs-mode-add)
+ ("b" . cvs-set-branch-prefix)
+ ("B" . cvs-set-secondary-branch-prefix)
+ ("c" . cvs-mode-commit)
+ ("e" . cvs-mode-examine)
+ ("f" . cvs-mode-find-file)
+ ("\C-m" . cvs-mode-find-file)
+ ("i" . cvs-mode-ignore)
+ ("l" . cvs-mode-log)
+ ("o" . cvs-mode-find-file-other-window)
+ ("r" . cvs-mode-remove)
+ ("s" . cvs-mode-status)
+ ("t" . cvs-mode-tag)
+ ("v" . cvs-mode-view-file)
+ ("x" . cvs-mode-remove-handled)
+ ;; cvstree bindings
+ ("+" . cvs-mode-tree)
+ ;; mouse bindings
+ ([mouse-2] . cvs-mode-find-file)
+ ([follow-link] . (lambda (pos)
+ (if (eq (get-char-property pos 'face) 'cvs-filename) t)))
+ ([(down-mouse-3)] . cvs-menu)
+ ;; dired-like bindings
+ ("\C-o" . cvs-mode-display-file)
+ ;; Emacs-21 toolbar
+ ;;([tool-bar item1] . (menu-item "Examine" cvs-examine :image (image :file "/usr/share/icons/xpaint.xpm" :type xpm)))
+ ;;([tool-bar item2] . (menu-item "Update" cvs-update :image (image :file "/usr/share/icons/mail1.xpm" :type xpm)))
+ )
+ "Keymap for `cvs-mode'."
+ :dense t
+ :suppress t)
+
+(fset 'cvs-mode-map cvs-mode-map)
+
+(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'."
+ '("CVS"
+ ["Open file" cvs-mode-find-file t]
+ ["Open in other window" cvs-mode-find-file-other-window t]
+ ["Display in other window" cvs-mode-display-file t]
+ ["Interactive merge" cvs-mode-imerge t]
+ ("View diff"
+ ["Interactive diff" cvs-mode-idiff t]
+ ["Current diff" cvs-mode-diff t]
+ ["Diff with head" cvs-mode-diff-head t]
+ ["Diff with vendor" cvs-mode-diff-vendor t]
+ ["Diff against yesterday" cvs-mode-diff-yesterday t]
+ ["Diff with backup" cvs-mode-diff-backup t])
+ ["View log" cvs-mode-log t]
+ ["View status" cvs-mode-status t]
+ ["View tag tree" cvs-mode-tree t]
+ "----"
+ ["Insert" cvs-mode-insert]
+ ["Update" cvs-mode-update (cvs-enabledp 'update)]
+ ["Re-examine" cvs-mode-examine t]
+ ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)]
+ ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))]
+ ["Undo changes" cvs-mode-undo (cvs-enabledp 'undo)]
+ ["Add" cvs-mode-add (cvs-enabledp 'add)]
+ ["Remove" cvs-mode-remove (cvs-enabledp 'remove)]
+ ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)]
+ ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t]
+ "----"
+ ["Mark" cvs-mode-mark t]
+ ["Mark all" cvs-mode-mark-all-files t]
+ ["Mark by regexp..." cvs-mode-mark-matching-files t]
+ ["Mark by state..." cvs-mode-mark-on-state t]
+ ["Unmark" cvs-mode-unmark t]
+ ["Unmark all" cvs-mode-unmark-all-files t]
+ ["Hide handled" cvs-mode-remove-handled t]
+ "----"
+ ["PCL-CVS Manual" (lambda () (interactive)
+ (info "(pcl-cvs)Top")) t]
+ "----"
+ ["Quit" cvs-mode-quit t]))
+
+;;;;
+;;;; CVS-Minor mode
+;;;;
+
+(defcustom cvs-minor-mode-prefix "\C-xc"
+ "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'."
+ :group 'pcl-cvs)
+
+(easy-mmode-defmap cvs-minor-mode-map
+ `((,cvs-minor-mode-prefix . cvs-mode-map)
+ ("e" . (menu-item nil cvs-mode-edit-log
+ :filter (lambda (x) (if (derived-mode-p 'log-view-mode) x)))))
+ "Keymap for `cvs-minor-mode', used in buffers related to PCL-CVS.")
+
+(defvar cvs-buffer nil
+ "(Buffer local) The *cvs* buffer associated with this buffer.")
+(put 'cvs-buffer 'permanent-local t)
+;;(make-variable-buffer-local 'cvs-buffer)
+
+(defvar cvs-minor-wrap-function nil
+ "Function to call when switching to the *cvs* buffer.
+Takes two arguments:
+- a *cvs* buffer.
+- a zero-arg function which is guaranteed not to switch buffer.
+It is expected to call the function.")
+;;(make-variable-buffer-local 'cvs-minor-wrap-function)
+
+(defvar cvs-minor-current-files)
+;;"Current files in a `cvs-minor-mode' buffer."
+;; This should stay `void' because we want to be able to tell the difference
+;; between an empty list and no list at all.
+
+(defconst cvs-pcl-cvs-dirchange-re "^pcl-cvs: descending directory \\(.*\\)$")
+
+;;;;
+;;;; autoload the global menu
+;;;;
+
+;;;###autoload
+(defvar cvs-global-menu
+ (let ((m (make-sparse-keymap "PCL-CVS")))
+ (define-key m [status]
+ `(menu-item ,(purecopy "Directory Status") cvs-status
+ :help ,(purecopy "A more verbose status of a workarea")))
+ (define-key m [checkout]
+ `(menu-item ,(purecopy "Checkout Module") cvs-checkout
+ :help ,(purecopy "Check out a module from the repository")))
+ (define-key m [update]
+ `(menu-item ,(purecopy "Update Directory") cvs-update
+ :help ,(purecopy "Fetch updates from the repository")))
+ (define-key m [examine]
+ `(menu-item ,(purecopy "Examine Directory") cvs-examine
+ :help ,(purecopy "Examine the current state of a workarea")))
+ (fset 'cvs-global-menu m)))
+
+
+;; cvs-1.10 and above can take file arguments in other directories
+;; while others need to be executed once per directory
+(defvar cvs-execute-single-dir
+ (if (or (null cvs-version)
+ (or (>= (cdr cvs-version) 10) (> (car cvs-version) 1)))
+ ;; Supposedly some recent versions of CVS output some directory info
+ ;; as they recurse downthe tree, but it's not good enough in the case
+ ;; where we run "cvs status foo bar/foo".
+ '("status")
+ t)
+ "Whether cvs commands should be executed a directory at a time.
+If a list, specifies for which commands the single-dir mode should be used.
+If T, single-dir mode should be used for all operations.
+
+CVS versions before 1.10 did not allow passing them arguments in different
+directories, so pcl-cvs checks what version you're using to determine
+whether to use the new feature or not.
+Sadly, even with a new cvs executable, if you connect to an older cvs server
+\(typically a cvs-1.9 on the server), the old restriction applies. In such
+a case the sanity check made by pcl-cvs fails and you will have to manually
+set this variable to t (until the cvs server is upgraded).
+When the above problem occurs, pcl-cvs should (hopefully) catch cvs' error
+message and replace it with a message telling you to change this variable.")
+
+;;
+(provide 'pcvs-defs)
+
+;; arch-tag: c7c701d0-d1d4-4aa9-a302-007bb03aca5e
+;;; pcvs-defs.el ends here
--- /dev/null
+;;; pcvs-info.el --- internal representation of a fileinfo entry
+
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: pcl-cvs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The cvs-fileinfo data structure:
+;;
+;; When the `cvs update' is ready we parse the output. Every file
+;; that is affected in some way is added to the cookie collection as
+;; a "fileinfo" (as defined below in cvs-create-fileinfo).
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'pcvs-util)
+;;(require 'pcvs-defs)
+
+;;;;
+;;;; config variables
+;;;;
+
+(define-obsolete-variable-alias 'cvs-display-full-path
+ 'cvs-display-full-name "22.1")
+
+(defcustom cvs-display-full-name t
+ "Specifies how the filenames should be displayed in the listing.
+If non-nil, their full filename name will be displayed, else only the
+non-directory part."
+ :group 'pcl-cvs
+ :type '(boolean))
+
+(defcustom cvs-allow-dir-commit nil
+ "Allow `cvs-mode-commit' on directories.
+If you commit without any marked file and with the cursor positioned
+on a directory entry, cvs would commit the whole directory. This seems
+to confuse some users sometimes."
+ :group 'pcl-cvs
+ :type '(boolean))
+
+;;;;
+;;;; Faces for fontification
+;;;;
+
+(defface cvs-header
+ '((((class color) (background dark))
+ (:foreground "lightyellow" :weight bold))
+ (((class color) (background light))
+ (:foreground "blue4" :weight bold))
+ (t (:weight bold)))
+ "PCL-CVS face used to highlight directory changes."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-header-face 'cvs-header "22.1")
+
+(defface cvs-filename
+ '((((class color) (background dark))
+ (:foreground "lightblue"))
+ (((class color) (background light))
+ (:foreground "blue4"))
+ (t ()))
+ "PCL-CVS face used to highlight file names."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-filename-face 'cvs-filename "22.1")
+
+(defface cvs-unknown
+ '((((class color) (background dark))
+ (:foreground "red1"))
+ (((class color) (background light))
+ (:foreground "red1"))
+ (t (:slant italic)))
+ "PCL-CVS face used to highlight unknown file status."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-unknown-face 'cvs-unknown "22.1")
+
+(defface cvs-handled
+ '((((class color) (background dark))
+ (:foreground "pink"))
+ (((class color) (background light))
+ (:foreground "pink"))
+ (t ()))
+ "PCL-CVS face used to highlight handled file status."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-handled-face 'cvs-handled "22.1")
+
+(defface cvs-need-action
+ '((((class color) (background dark))
+ (:foreground "orange"))
+ (((class color) (background light))
+ (:foreground "orange"))
+ (t (:slant italic)))
+ "PCL-CVS face used to highlight status of files needing action."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-need-action-face 'cvs-need-action "22.1")
+
+(defface cvs-marked
+ '((((min-colors 88) (class color) (background dark))
+ (:foreground "green1" :weight bold))
+ (((class color) (background dark))
+ (:foreground "green" :weight bold))
+ (((class color) (background light))
+ (:foreground "green3" :weight bold))
+ (t (:weight bold)))
+ "PCL-CVS face used to highlight marked file indicator."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-marked-face 'cvs-marked "22.1")
+
+(defface cvs-msg
+ '((t (:slant italic)))
+ "PCL-CVS face used to highlight CVS messages."
+ :group 'pcl-cvs)
+(define-obsolete-face-alias 'cvs-msg-face 'cvs-msg "22.1")
+
+(defvar cvs-fi-up-to-date-face 'cvs-handled)
+(defvar cvs-fi-unknown-face 'cvs-unknown)
+(defvar cvs-fi-conflict-face 'font-lock-warning-face)
+
+;; There is normally no need to alter the following variable, but if
+;; your site has installed CVS in a non-standard way you might have
+;; to change it.
+
+(defvar cvs-bakprefix ".#"
+ "The prefix that CVS prepends to files when rcsmerge'ing.")
+
+(easy-mmode-defmap cvs-status-map
+ '(([(mouse-2)] . cvs-mode-toggle-mark))
+ "Local keymap for text properties of status")
+
+;; Constructor:
+
+(defstruct (cvs-fileinfo
+ (:constructor nil)
+ (:copier nil)
+ (:constructor -cvs-create-fileinfo (type dir file full-log
+ &key marked subtype
+ merge
+ base-rev
+ head-rev))
+ (:conc-name cvs-fileinfo->))
+ marked ;; t/nil.
+ type ;; See below
+ subtype ;; See below
+ dir ;; Relative directory the file resides in.
+ ;; (concat dir file) should give a valid path.
+ file ;; The file name sans the directory.
+ base-rev ;; During status: This is the revision that the
+ ;; working file is based on.
+ head-rev ;; During status: This is the highest revision in
+ ;; the repository.
+ merge ;; A cons cell containing the (ancestor . head) revisions
+ ;; of the merge that resulted in the current file.
+ ;;removed ;; t if the file no longer exists.
+ full-log ;; The output from cvs, unparsed.
+ ;;mod-time ;; Not used.
+
+ ;; In addition to the above, the following values can be extracted:
+
+ ;; handled ;; t if this file doesn't require further action.
+ ;; full-name ;; The complete relative filename.
+ ;; pp-name ;; The printed file name
+ ;; backup-file;; For MERGED and CONFLICT files after a \"cvs update\",
+ ;; this is a full path to the backup file where the
+ ;; untouched version resides.
+
+ ;; The meaning of the type field:
+
+ ;; Value ---Used by--- Explanation
+ ;; update status
+ ;; NEED-UPDATE x file needs update
+ ;; MODIFIED x x modified by you, unchanged in repository
+ ;; MERGED x x successful merge
+ ;; ADDED x x added by you, not yet committed
+ ;; MISSING x rm'd, but not yet `cvs remove'd
+ ;; REMOVED x x removed by you, not yet committed
+ ;; NEED-MERGE x need merge
+ ;; CONFLICT x conflict when merging
+ ;; ;;MOD-CONFLICT x removed locally, changed in repository.
+ ;; DIRCHANGE x x A change of directory.
+ ;; UNKNOWN x An unknown file.
+ ;; UP-TO-DATE x The file is up-to-date.
+ ;; UPDATED x x file copied from repository
+ ;; PATCHED x x diff applied from repository
+ ;; COMMITTED x x cvs commit'd
+ ;; DEAD An entry that should be removed
+ ;; MESSAGE x x This is a special fileinfo that is used
+ ;; to display a text that should be in
+ ;; full-log."
+ ;; TEMP A temporary message that should be removed
+ )
+(defun cvs-create-fileinfo (type dir file msg &rest keys)
+ (cvs-check-fileinfo (apply #'-cvs-create-fileinfo type dir file msg keys)))
+
+;; Fake selectors:
+
+(defun cvs-fileinfo->full-name (fileinfo)
+ "Return the full path for the file that is described in FILEINFO."
+ (let ((dir (cvs-fileinfo->dir fileinfo)))
+ (if (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE)
+ (if (string= dir "") "." (directory-file-name dir))
+ ;; Here, I use `concat' rather than `expand-file-name' because I want
+ ;; the resulting path to stay relative if `dir' is relative.
+ (concat dir (cvs-fileinfo->file fileinfo)))))
+(define-obsolete-function-alias 'cvs-fileinfo->full-path
+ 'cvs-fileinfo->full-name "22.1")
+
+(defun cvs-fileinfo->pp-name (fi)
+ "Return the filename of FI as it should be displayed."
+ (if cvs-display-full-name
+ (cvs-fileinfo->full-name fi)
+ (cvs-fileinfo->file fi)))
+
+(defun cvs-fileinfo->backup-file (fileinfo)
+ "Construct the file name of the backup file for FILEINFO."
+ (let* ((dir (cvs-fileinfo->dir fileinfo))
+ (file (cvs-fileinfo->file fileinfo))
+ (default-directory (file-name-as-directory (expand-file-name dir)))
+ (files (directory-files "." nil
+ (concat "\\`" (regexp-quote cvs-bakprefix)
+ (regexp-quote file) "\\(\\.[0-9]+\\.[0-9]+\\)+\\'")))
+ bf)
+ (dolist (f files)
+ (when (and (file-readable-p f)
+ (or (null bf) (file-newer-than-file-p f bf)))
+ (setq bf f)))
+ (concat dir bf)))
+
+;; (defun cvs-fileinfo->handled (fileinfo)
+;; "Tell if this requires further action"
+;; (memq (cvs-fileinfo->type fileinfo) '(UP-TO-DATE DEAD)))
+
+\f
+;; Predicate:
+
+(defun cvs-check-fileinfo (fi)
+ "Check FI's conformance to some conventions."
+ (let ((check 'none)
+ (type (cvs-fileinfo->type fi))
+ (subtype (cvs-fileinfo->subtype fi))
+ (marked (cvs-fileinfo->marked fi))
+ (dir (cvs-fileinfo->dir fi))
+ (file (cvs-fileinfo->file fi))
+ (base-rev (cvs-fileinfo->base-rev fi))
+ (head-rev (cvs-fileinfo->head-rev fi))
+ (full-log (cvs-fileinfo->full-log fi)))
+ (if (and (setq check 'marked) (memq marked '(t nil))
+ (setq check 'base-rev) (or (null base-rev) (stringp base-rev))
+ (setq check 'head-rev) (or (null head-rev) (stringp head-rev))
+ (setq check 'full-log) (stringp full-log)
+ (setq check 'dir)
+ (and (stringp dir)
+ (not (file-name-absolute-p dir))
+ (or (string= dir "")
+ (string= dir (file-name-as-directory dir))))
+ (setq check 'file)
+ (and (stringp file)
+ (string= file (file-name-nondirectory file)))
+ (setq check 'type) (symbolp type)
+ (setq check 'consistency)
+ (case type
+ (DIRCHANGE (and (null subtype) (string= "." file)))
+ ((NEED-UPDATE ADDED MISSING DEAD MODIFIED MESSAGE UP-TO-DATE
+ REMOVED NEED-MERGE CONFLICT UNKNOWN MESSAGE)
+ t)))
+ fi
+ (error "Invalid :%s in cvs-fileinfo %s" check fi))))
+
+\f
+;;;;
+;;;; State table to indicate what you can do when.
+;;;;
+
+(defconst cvs-states
+ `((NEED-UPDATE update diff ignore)
+ (UP-TO-DATE update nil remove diff safe-rm revert)
+ (MODIFIED update commit undo remove diff merge diff-base)
+ (ADDED update commit remove)
+ (MISSING remove undo update safe-rm revert)
+ (REMOVED commit add undo safe-rm)
+ (NEED-MERGE update undo diff diff-base)
+ (CONFLICT merge remove undo commit diff diff-base)
+ (DIRCHANGE remove update diff ,(if cvs-allow-dir-commit 'commit) tag)
+ (UNKNOWN ignore add remove)
+ (DEAD )
+ (MESSAGE))
+ "Fileinfo state descriptions for pcl-cvs.
+This is an assoc list. Each element consists of (STATE . FUNS)
+- STATE (described in `cvs-create-fileinfo') is the key
+- FUNS is the list of applicable operations.
+ The first one (if any) should be the \"default\" action.
+Most of the actions have the obvious meaning.
+`safe-rm' indicates that the file can be removed without losing
+ any information.")
+
+;;;;
+;;;; Utility functions
+;;;;
+
+(defun cvs-applicable-p (fi-or-type func)
+ "Check if FUNC is applicable to FI-OR-TYPE.
+If FUNC is nil, always return t.
+FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo."
+ (let ((type (if (symbolp fi-or-type) fi-or-type
+ (cvs-fileinfo->type fi-or-type))))
+ (and (not (eq type 'MESSAGE))
+ (eq (car (memq func (cdr (assq type cvs-states)))) func))))
+
+(defun cvs-add-face (str face &optional keymap &rest props)
+ (when keymap
+ (when (keymapp keymap)
+ (setq props (list* 'keymap keymap props)))
+ (setq props (list* 'mouse-face 'highlight props)))
+ (add-text-properties 0 (length str) (list* 'font-lock-face face props) str)
+ str)
+
+(defun cvs-fileinfo-pp (fileinfo)
+ "Pretty print FILEINFO. Insert a printed representation in current buffer.
+For use by the cookie package."
+ (cvs-check-fileinfo fileinfo)
+ (let ((type (cvs-fileinfo->type fileinfo))
+ (subtype (cvs-fileinfo->subtype fileinfo)))
+ (insert
+ (case type
+ (DIRCHANGE (concat "In directory "
+ (cvs-add-face (cvs-fileinfo->full-name fileinfo)
+ 'cvs-header t 'cvs-goal-column t)
+ ":"))
+ (MESSAGE
+ (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo))
+ 'cvs-msg))
+ (t
+ (let* ((status (if (cvs-fileinfo->marked fileinfo)
+ (cvs-add-face "*" 'cvs-marked)
+ " "))
+ (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo)
+ 'cvs-filename t 'cvs-goal-column t))
+ (base (or (cvs-fileinfo->base-rev fileinfo) ""))
+ (head (cvs-fileinfo->head-rev fileinfo))
+ (type
+ (let ((str (case type
+ ;;(MOD-CONFLICT "Not Removed")
+ (DEAD "")
+ (t (capitalize (symbol-name type)))))
+ (face (let ((sym (intern
+ (concat "cvs-fi-"
+ (downcase (symbol-name type))
+ "-face"))))
+ (or (and (boundp sym) (symbol-value sym))
+ 'cvs-need-action))))
+ (cvs-add-face str face cvs-status-map)))
+ (side (or
+ ;; maybe a subtype
+ (when subtype (downcase (symbol-name subtype)))
+ ;; or the head-rev
+ (when (and head (not (string= head base))) head)
+ ;; or nothing
+ "")))
+ (format "%-11s %s %-11s %-11s %s"
+ side status type base file))))
+ "\n")))
+
+
+(defun cvs-fileinfo-update (fi fi-new)
+ "Update FI with the information provided in FI-NEW."
+ (let ((type (cvs-fileinfo->type fi-new))
+ (merge (cvs-fileinfo->merge fi-new)))
+ (setf (cvs-fileinfo->type fi) type)
+ (setf (cvs-fileinfo->subtype fi) (cvs-fileinfo->subtype fi-new))
+ (setf (cvs-fileinfo->full-log fi) (cvs-fileinfo->full-log fi-new))
+ (setf (cvs-fileinfo->base-rev fi) (cvs-fileinfo->base-rev fi-new))
+ (setf (cvs-fileinfo->head-rev fi) (cvs-fileinfo->head-rev fi-new))
+ (cond
+ (merge (setf (cvs-fileinfo->merge fi) merge))
+ ((memq type '(UP-TO-DATE NEED-UPDATE))
+ (setf (cvs-fileinfo->merge fi) nil)))))
+
+(defun cvs-fileinfo< (a b)
+ "Compare fileinfo A with fileinfo B and return t if A is `less'.
+The ordering defined by this function is such that directories are
+sorted alphabetically, and inside every directory the DIRCHANGE
+fileinfo will appear first, followed by all files (alphabetically)."
+ (let ((subtypea (cvs-fileinfo->subtype a))
+ (subtypeb (cvs-fileinfo->subtype b)))
+ (cond
+ ;; Sort according to directories.
+ ((string< (cvs-fileinfo->dir a) (cvs-fileinfo->dir b)) t)
+ ((not (string= (cvs-fileinfo->dir a) (cvs-fileinfo->dir b))) nil)
+
+ ;; The DIRCHANGE entry is always first within the directory.
+ ((eq (cvs-fileinfo->type b) 'DIRCHANGE) nil)
+ ((eq (cvs-fileinfo->type a) 'DIRCHANGE) t)
+
+ ;; All files are sorted by file name.
+ ((string< (cvs-fileinfo->file a) (cvs-fileinfo->file b))))))
+
+;;;
+;;; Look at CVS/Entries to quickly find a first approximation of the status
+;;;
+
+(defun cvs-fileinfo-from-entries (dir &optional all)
+ "List of fileinfos for DIR, extracted from CVS/Entries.
+Unless ALL is optional, returns only the files that are not up-to-date.
+DIR can also be a file."
+ (let* ((singlefile
+ (cond
+ ((equal dir "") nil)
+ ((file-directory-p dir) (setq dir (file-name-as-directory dir)) nil)
+ (t (prog1 (file-name-nondirectory dir)
+ (setq dir (or (file-name-directory dir) ""))))))
+ (file (expand-file-name "CVS/Entries" dir))
+ (fis nil))
+ (if (not (file-readable-p file))
+ (push (cvs-create-fileinfo (if singlefile 'UNKNOWN 'DIRCHANGE)
+ dir (or singlefile ".") "") fis)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char (point-min))
+ ;; Select the single file entry in case we're only interested in a file.
+ (cond
+ ((not singlefile)
+ (push (cvs-create-fileinfo 'DIRCHANGE dir "." "") fis))
+ ((re-search-forward
+ (concat "^[^/]*/" (regexp-quote singlefile) "/.*") nil t)
+ (setq all t)
+ (goto-char (match-beginning 0))
+ (narrow-to-region (point) (match-end 0)))
+ (t
+ (push (cvs-create-fileinfo 'UNKNOWN dir singlefile "") fis)
+ (narrow-to-region (point-min) (point-min))))
+ (while (looking-at "\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/")
+ (if (/= (match-beginning 1) (match-end 1))
+ (setq fis (append (cvs-fileinfo-from-entries
+ (concat dir (file-name-as-directory
+ (match-string 2)))
+ all)
+ fis))
+ (let ((f (match-string 2))
+ (rev (match-string 3))
+ (date (match-string 4))
+ timestamp
+ (type 'MODIFIED)
+ (subtype nil))
+ (cond
+ ((equal (substring rev 0 1) "-")
+ (setq type 'REMOVED rev (substring rev 1)))
+ ((not (file-exists-p (concat dir f))) (setq type 'MISSING))
+ ((equal rev "0") (setq type 'ADDED rev nil))
+ ((equal date "Result of merge") (setq subtype 'MERGED))
+ ((let ((mtime (nth 5 (file-attributes (concat dir f))))
+ (system-time-locale "C"))
+ (setq timestamp (format-time-string "%c" mtime 'utc))
+ ;; Solaris sometimes uses "Wed Sep 05", not "Wed Sep 5".
+ ;; See "grep '[^a-z_]ctime' cvs/src/*.c" for reference.
+ (if (= (aref timestamp 8) ?0)
+ (setq timestamp (concat (substring timestamp 0 8)
+ " " (substring timestamp 9))))
+ (equal timestamp date))
+ (setq type (if all 'UP-TO-DATE)))
+ ((equal date (concat "Result of merge+" timestamp))
+ (setq type 'CONFLICT)))
+ (when type
+ (push (cvs-create-fileinfo type dir f ""
+ :base-rev rev :subtype subtype)
+ fis))))
+ (forward-line 1))))
+ fis))
+
+(provide 'pcvs-info)
+
+;; arch-tag: d85dde07-bdc2-400a-882f-92f398c7b0ba
+;;; pcvs-info.el ends here
--- /dev/null
+;;; pcvs-parse.el --- the CVS output parser
+
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: pcl-cvs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Bugs:
+
+;; - when merging a modified file, if the merge says that the file already
+;; contained in the changes, it marks the file as `up-to-date' although
+;; it might still contain further changes.
+;; Example: merging a zero-change commit.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'pcvs-util)
+(require 'pcvs-info)
+
+;; imported from pcvs.el
+(defvar cvs-execute-single-dir)
+
+;; parse vars
+
+(defcustom cvs-update-prog-output-skip-regexp "$"
+ "A regexp that matches the end of the output from all cvs update programs.
+That is, output from any programs that are run by CVS (by the flag -u
+in the `modules' file - see cvs(5)) when `cvs update' is performed should
+terminate with a line that this regexp matches. It is enough that
+some part of the line is matched.
+
+The default (a single $) fits programs without output."
+ :group 'pcl-cvs
+ :type '(regexp :value "$"))
+
+(defcustom cvs-parse-ignored-messages
+ '("Executing ssh-askpass to query the password.*$"
+ ".*Remote host denied X11 forwarding.*$")
+ "A list of regexps matching messages that should be ignored by the parser.
+Each regexp should match a whole set of lines and should hence be terminated
+by `$'."
+ :group 'pcl-cvs
+ :type '(repeat regexp))
+
+;; a few more defvars just to shut up the compiler
+(defvar cvs-start)
+(defvar cvs-current-dir)
+(defvar cvs-current-subdir)
+(defvar dont-change-disc)
+
+;;;; The parser
+
+(defconst cvs-parse-known-commands
+ '("status" "add" "commit" "update" "remove" "checkout" "ci")
+ "List of CVS commands whose output is understood by the parser.")
+
+(defun cvs-parse-buffer (parse-spec dont-change-disc &optional subdir)
+ "Parse current buffer according to PARSE-SPEC.
+PARSE-SPEC is a function of no argument advancing the point and returning
+ either a fileinfo or t (if the matched text should be ignored) or
+ nil if it didn't match anything.
+DONT-CHANGE-DISC just indicates whether the command was changing the disc
+ or not (useful to tell the difference between `cvs-examine' and `cvs-update'
+ output.
+The path names should be interpreted as relative to SUBDIR (defaults
+ to the `default-directory').
+Return a list of collected entries, or t if an error occurred."
+ (goto-char (point-min))
+ (let ((fileinfos ())
+ (cvs-current-dir "")
+ (case-fold-search nil)
+ (cvs-current-subdir (or subdir "")))
+ (while (not (or (eobp) (eq fileinfos t)))
+ (let ((ret (cvs-parse-run-table parse-spec)))
+ (cond
+ ;; it matched a known information message
+ ((cvs-fileinfo-p ret) (push ret fileinfos))
+ ;; it didn't match anything at all (impossible)
+ ((and (consp ret) (cvs-fileinfo-p (car ret)))
+ (setq fileinfos (append ret fileinfos)))
+ ((null ret) (setq fileinfos t))
+ ;; it matched something that should be ignored
+ (t nil))))
+ (nreverse fileinfos)))
+
+
+;; All those parsing macros/functions should return a success indicator
+(defsubst cvs-parse-msg () (buffer-substring cvs-start (1- (point))))
+
+;;(defsubst COLLECT (exp) (push exp *result*))
+;;(defsubst PROG (e) t)
+;;(defmacro SEQ (&rest seqs) (cons 'and seqs))
+
+(defmacro cvs-match (re &rest matches)
+ "Try to match RE and extract submatches.
+If RE matches, advance the point until the line after the match and
+then assign the variables as specified in MATCHES (via `setq')."
+ (cons 'cvs-do-match
+ (cons re (mapcar (lambda (match)
+ `(cons ',(first match) ,(second match)))
+ matches))))
+
+(defun cvs-do-match (re &rest matches)
+ "Internal function for the `cvs-match' macro.
+Match RE and if successful, execute MATCHES."
+ ;; Is it a match?
+ (when (looking-at re)
+ (goto-char (match-end 0))
+ ;; Skip the newline (unless we already are at the end of the buffer).
+ (when (and (eolp) (< (point) (point-max))) (forward-char))
+ ;; assign the matches
+ (dolist (match matches t)
+ (let ((val (cdr match)))
+ (set (car match) (if (integerp val) (match-string val) val))))))
+
+(defmacro cvs-or (&rest alts)
+ "Try each one of the ALTS alternatives until one matches."
+ `(let ((-cvs-parse-point (point)))
+ ,(cons 'or
+ (mapcar (lambda (es)
+ `(or ,es (ignore (goto-char -cvs-parse-point))))
+ alts))))
+(def-edebug-spec cvs-or t)
+
+;; This is how parser tables should be executed
+(defun cvs-parse-run-table (parse-spec)
+ "Run PARSE-SPEC and provide sensible default behavior."
+ (unless (bolp) (forward-line 1)) ;this should never be needed
+ (let ((cvs-start (point)))
+ (cvs-or
+ (funcall parse-spec)
+
+ (dolist (re cvs-parse-ignored-messages)
+ (when (cvs-match re) (return t)))
+
+ ;; This is a parse error. Create a message-type fileinfo.
+ (and
+ (cvs-match ".*$")
+ (cvs-create-fileinfo 'MESSAGE cvs-current-dir " "
+ ;; (concat " Unknown msg: '"
+ (cvs-parse-msg) ;; "'")
+ :subtype 'ERROR)))))
+
+\f
+(defun cvs-parsed-fileinfo (type path &optional directory &rest keys)
+ "Create a fileinfo.
+TYPE can either be a type symbol or a cons of the form (TYPE . SUBTYPE).
+PATH is the filename.
+DIRECTORY influences the way PATH is interpreted:
+- if it's a string, it denotes the directory in which PATH (which should then be
+ a plain file name with no directory component) resides.
+- if it's nil, the PATH should not be trusted: if it has a directory
+ component, use it, else, assume it is relative to the current directory.
+- else, the PATH should be trusted to be relative to the root
+ directory (i.e. if there is no directory component, it means the file
+ is inside the main directory).
+The remaining KEYS are passed directly to `cvs-create-fileinfo'."
+ (let ((dir directory)
+ (file path))
+ ;; only trust the directory if it's a string
+ (unless (stringp directory)
+ ;; else, if the directory is true, the path should be trusted
+ (setq dir (or (file-name-directory path) (if directory "")))
+ (setq file (file-name-nondirectory path)))
+
+ (let ((type (if (consp type) (car type) type))
+ (subtype (if (consp type) (cdr type))))
+ (when dir (setq cvs-current-dir dir))
+ (apply 'cvs-create-fileinfo type
+ (concat cvs-current-subdir (or dir cvs-current-dir))
+ file (cvs-parse-msg) :subtype subtype keys))))
+\f
+;;;; CVS Process Parser Tables:
+;;;;
+;;;; The table for status and update could actually be merged since they
+;;;; don't conflict. But they don't overlap much either.
+
+(defun cvs-parse-table ()
+ "Table of message objects for `cvs-parse-process'."
+ (let (c file dir path base-rev subtype)
+ (cvs-or
+
+ (cvs-parse-status)
+ (cvs-parse-merge)
+ (cvs-parse-commit)
+
+ ;; this is not necessary because the fileinfo merging will remove
+ ;; such duplicate info and luckily the second info is the one we want.
+ ;; (and (cvs-match "M \\(.*\\)$" (path 1))
+ ;; (cvs-parse-merge path))
+
+ ;; Normal file state indicator.
+ (and
+ (cvs-match "\\([MARCUPNJ?]\\) \\(.*\\)$" (c 1) (path 2))
+ ;; M: The file is modified by the user, and untouched in the repository.
+ ;; A: The file is "cvs add"ed, but not "cvs ci"ed.
+ ;; R: The file is "cvs remove"ed, but not "cvs ci"ed.
+ ;; C: Conflict
+ ;; U: The file is copied from the repository.
+ ;; P: The file was patched from the repository.
+ ;; ?: Unknown file.
+ (let ((code (aref c 0)))
+ (cvs-parsed-fileinfo
+ (case code
+ (?M 'MODIFIED)
+ (?A 'ADDED)
+ (?R 'REMOVED)
+ (?? 'UNKNOWN)
+ (?C
+ (if (not dont-change-disc) 'CONFLICT
+ ;; This is ambiguous. We should look for conflict markers in the
+ ;; file to decide between CONFLICT and NEED-MERGE. With CVS-1.10
+ ;; servers, this should not be necessary, because they return
+ ;; a complete merge output.
+ (with-temp-buffer
+ (ignore-errors (insert-file-contents path))
+ (goto-char (point-min))
+ (if (re-search-forward "^<<<<<<< " nil t)
+ 'CONFLICT 'NEED-MERGE))))
+ (?J 'NEED-MERGE) ;not supported by standard CVS
+ ((?U ?P)
+ (if dont-change-disc 'NEED-UPDATE
+ (cons 'UP-TO-DATE (if (eq code ?U) 'UPDATED 'PATCHED)))))
+ path 'trust)))
+
+ (and
+ (cvs-match "pcl-cvs: descending directory \\(.*\\)$" (dir 1))
+ (setq cvs-current-subdir dir))
+
+ ;; A special cvs message
+ (and
+ (let ((case-fold-search t))
+ (cvs-match "cvs[.a-z]* [a-z]+: "))
+ (cvs-or
+
+ ;; CVS is descending a subdirectory
+ ;; (status says `examining' while update says `updating')
+ (and
+ (cvs-match "\\(Examining\\|Updating\\) \\(.*\\)$" (dir 2))
+ (let ((dir (if (string= "." dir) "" (file-name-as-directory dir))))
+ (cvs-parsed-fileinfo 'DIRCHANGE "." dir)))
+
+ ;; [-n update] A new (or pruned) directory appeared but isn't traversed
+ (and
+ (cvs-match "New directory `\\(.*\\)' -- ignored$" (dir 1))
+ ;; (cvs-parsed-fileinfo 'MESSAGE " " (file-name-as-directory dir))
+ ;; These messages either correspond to a true new directory
+ ;; that an update will bring in, or to a directory that's empty
+ ;; on the current branch (either because it only exists in other
+ ;; branches, or because it's been removed).
+ (if (ignore-errors
+ (with-temp-buffer
+ (ignore-errors
+ (insert-file-contents
+ (expand-file-name ".cvsignore" (file-name-directory dir))))
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote (file-name-nondirectory dir)) "/$")
+ nil t)))
+ t ;The user requested to ignore those messages.
+ (cvs-parsed-fileinfo '(NEED-UPDATE . NEW-DIR) dir t)))
+
+ ;; File removed, since it is removed (by third party) in repository.
+ (and
+ (cvs-or
+ ;; some cvs versions output quotes around these files
+ (cvs-match "warning: `\\(.*\\)' is not (any longer) pertinent$" (file 1))
+ (cvs-match "warning: \\(.*\\) is not (any longer) pertinent$" (file 1))
+ (cvs-match "`\\(.*\\)' is no longer in the repository$" (file 1))
+ (cvs-match "\\(.*\\) is no longer in the repository$" (file 1)))
+ (cvs-parsed-fileinfo
+ (if dont-change-disc '(NEED-UPDATE . REMOVED) 'DEAD) file))
+
+ ;; [add]
+ (and
+ (cvs-or
+ (cvs-match "scheduling file `\\(.*\\)' for addition.*$" (path 1))
+ (cvs-match "re-adding file \\(.*\\) (in place of .*)$" (path 1)))
+ (cvs-parsed-fileinfo 'ADDED path))
+
+ ;; [add] this will also show up as a `U <file>'
+ (and
+ (cvs-match "`?\\(.*?\\)'?, version \\(.*\\), resurrected$"
+ (path 1) (base-rev 2))
+ ;; FIXME: resurrection only brings back the original version,
+ ;; not the latest on the branch, so `up-to-date' is not always
+ ;; what we want.
+ (cvs-parsed-fileinfo '(UP-TO-DATE . RESURRECTED) path nil
+ :base-rev base-rev))
+
+ ;; [remove]
+ (and
+ (cvs-match "removed `\\(.*\\)'$" (path 1))
+ (cvs-parsed-fileinfo 'DEAD path))
+
+ ;; [remove,merge]
+ (and
+ (cvs-match "scheduling `\\(.*\\)' for removal$" (file 1))
+ (cvs-parsed-fileinfo 'REMOVED file))
+
+ ;; [update] File removed by you, but not cvs rm'd
+ (and
+ (cvs-match "warning: \\(.*\\) was lost$" (path 1))
+ (cvs-match (concat "U " (regexp-quote path) "$"))
+ (cvs-parsed-fileinfo (if dont-change-disc
+ 'MISSING
+ '(UP-TO-DATE . UPDATED))
+ path))
+
+ ;; Mode conflicts (rather than contents)
+ (and
+ (cvs-match "conflict: ")
+ (cvs-or
+ (cvs-match "removed \\(.*\\) was modified by second party$"
+ (path 1) (subtype 'REMOVED))
+ (cvs-match "\\(.*\\) created independently by second party$"
+ (path 1) (subtype 'ADDED))
+ (cvs-match "\\(.*\\) is modified but no longer in the repository$"
+ (path 1) (subtype 'MODIFIED)))
+ (cvs-match (concat "C " (regexp-quote path)))
+ (cvs-parsed-fileinfo (cons 'CONFLICT subtype) path))
+
+ ;; Messages that should be shown to the user
+ (and
+ (cvs-or
+ (cvs-match "move away \\(.*\\); it is in the way$" (file 1))
+ (cvs-match "warning: new-born \\(.*\\) has disappeared$" (file 1))
+ (cvs-match "sticky tag .* for file `\\(.*\\)' is not a branch$"
+ (file 1)))
+ (cvs-parsed-fileinfo 'MESSAGE file))
+
+ ;; File unknown.
+ (and (cvs-match "use `.+ add' to create an entry for \\(.*\\)$" (path 1))
+ (cvs-parsed-fileinfo 'UNKNOWN path))
+
+ ;; [commit]
+ (and (cvs-match "Up-to-date check failed for `\\(.+\\)'$" (file 1))
+ (cvs-parsed-fileinfo 'NEED-MERGE file))
+
+ ;; We use cvs-execute-multi-dir but cvs can't handle it
+ ;; Probably because the cvs-client can but the cvs-server can't
+ (and (cvs-match ".* files with '?/'? in their name.*$")
+ (not cvs-execute-single-dir)
+ (setq cvs-execute-single-dir t)
+ (cvs-create-fileinfo
+ 'MESSAGE "" " "
+ "*** Add (setq cvs-execute-single-dir t) to your .emacs ***
+ See the FAQ file or the variable's documentation for more info."))
+
+ ;; Cvs waits for a lock. Ignored: already handled by the process filter
+ (cvs-match "\\[..:..:..\\] \\(waiting for\\|obtained\\) .*lock in .*$")
+ ;; File you removed still exists. Ignore (will be noted as removed).
+ (cvs-match ".* should be removed and is still there$")
+ ;; just a note
+ (cvs-match "use ['`].+ commit' to \\sw+ th\\sw+ files? permanently$")
+ ;; [add,status] followed by a more complete status description anyway
+ (and (cvs-match "nothing known about \\(.*\\)$" (path 1))
+ (cvs-parsed-fileinfo 'DEAD path 'trust))
+ ;; [update] problem with patch
+ (cvs-match "checksum failure after patch to .*; will refetch$")
+ (cvs-match "refetching unpatchable files$")
+ ;; [commit]
+ (cvs-match "Rebuilding administrative file database$")
+ ;; ???
+ (cvs-match "--> Using per-directory sticky tag `.*'")
+
+ ;; CVS is running a *info program.
+ (and
+ (cvs-match "Executing.*$")
+ ;; Skip by any output the program may generate to stdout.
+ ;; Note that pcl-cvs will get seriously confused if the
+ ;; program prints anything to stderr.
+ (re-search-forward cvs-update-prog-output-skip-regexp))))
+
+ (and
+ (cvs-match "cvs[.ex]* \\[[a-z]+ aborted\\]:.*$")
+ (cvs-parsed-fileinfo 'MESSAGE ""))
+
+ ;; sadly you can't do much with these since the path is in the repository
+ (cvs-match "Directory .* added to the repository$")
+ )))
+
+
+(defun cvs-parse-merge ()
+ (let (path base-rev head-rev type)
+ ;; A merge (maybe with a conflict).
+ (and
+ (cvs-match "RCS file: .*$")
+ ;; Squirrel away info about the files that were retrieved for merging
+ (cvs-match "retrieving revision \\([0-9.]+\\)$" (base-rev 1))
+ (cvs-match "retrieving revision \\([0-9.]+\\)$" (head-rev 1))
+ (cvs-match "Merging differences between [0-9.]+ and [0-9.]+ into \\(.*\\)$"
+ (path 1))
+
+ ;; eat up potential conflict warnings
+ (cvs-or (cvs-match "\\(rcs\\)?merge:?\\( warning\\)?: \\(overlaps\\|conflicts\\) \\(or other problems \\)?during merge$" (type 'CONFLICT)) t)
+ (cvs-or
+ (and
+ (cvs-match "cvs[.ex]* [a-z]+: ")
+ (cvs-or
+ (cvs-match "conflicts found in \\(.*\\)$" (path 1) (type 'CONFLICT))
+ (cvs-match "could not merge .*$")
+ (cvs-match "restoring \\(.*\\) from backup file .*$" (path 1))))
+ t)
+
+ ;; Is it a succesful merge?
+ ;; Figure out result of merging (ie, was there a conflict?)
+ (let ((qfile (regexp-quote path)))
+ (cvs-or
+ ;; Conflict
+ (and
+ (cvs-match (concat "C \\(.*" qfile "\\)$") (path 1) (type 'CONFLICT))
+ ;; C might be followed by a "suprious" U for non-mergeable files
+ (cvs-or (cvs-match (concat "U \\(.*" qfile "\\)$")) t))
+ ;; Successful merge
+ (cvs-match (concat "M \\(.*" qfile "\\)$") (path 1))
+ ;; The file already contained the modifications
+ (cvs-match (concat "^\\(.*" qfile
+ "\\) already contains the differences between .*$")
+ (path 1) (type '(UP-TO-DATE . MERGED)))
+ t)
+ ;; FIXME: PATH might not be set yet. Sometimes the only path
+ ;; information is in `RCS file: ...' (yuck!!).
+ (cvs-parsed-fileinfo (if dont-change-disc 'NEED-MERGE
+ (or type '(MODIFIED . MERGED))) path nil
+ :merge (cons base-rev head-rev))))))
+
+(defun cvs-parse-status ()
+ (let (nofile path base-rev head-rev type)
+ (and
+ (cvs-match
+ "===================================================================$")
+ (cvs-match "File: \\(no file \\)?\\(.*[^ \t]\\)[ \t]+Status: "
+ (nofile 1) (path 2))
+ (cvs-or
+ (cvs-match "Needs \\(Checkout\\|Patch\\)$"
+ (type (if nofile 'MISSING 'NEED-UPDATE)))
+ (cvs-match "Up-to-date$"
+ (type (if nofile '(UP-TO-DATE . REMOVED) 'UP-TO-DATE)))
+ (cvs-match "File had conflicts on merge$" (type 'MODIFIED))
+ (cvs-match ".*[Cc]onflict.*$" (type 'CONFLICT))
+ (cvs-match "Locally Added$" (type 'ADDED))
+ (cvs-match "Locally Removed$" (type 'REMOVED))
+ (cvs-match "Locally Modified$" (type 'MODIFIED))
+ (cvs-match "Needs Merge$" (type 'NEED-MERGE))
+ (cvs-match "Entry Invalid" (type '(NEED-MERGE . REMOVED)))
+ (cvs-match ".*$" (type 'UNKNOWN)))
+ (cvs-match "$")
+ (cvs-or
+ (cvs-match " *Version:[ \t]*\\([0-9.]+\\).*$" (base-rev 1))
+ ;; NOTE: there's no date on the end of the following for server mode...
+ (cvs-match " *Working revision:[ \t]*-?\\([0-9.]+\\).*$" (base-rev 1))
+ ;; Let's not get all worked up if the format changes a bit
+ (cvs-match " *Working revision:.*$"))
+ (cvs-or
+ (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\)[ \t]*.*$" (head-rev 1))
+ (cvs-match " *Repository revision:[ \t]*\\([0-9.]+\\)[ \t]*\\(.*\\)$"
+ (head-rev 1))
+ (cvs-match " *Repository revision:.*"))
+ (cvs-or (cvs-match " *Expansion option:.*") t) ;Optional CVSNT thingie.
+ (cvs-or (cvs-match " *Commit Identifier:.*") t) ;Optional CVSNT thingie.
+ (cvs-or
+ (and ;; Sometimes those fields are missing.
+ (cvs-match " *Sticky Tag:[ \t]*\\(.*\\)$") ; FIXME: use it.
+ (cvs-match " *Sticky Date:[ \t]*\\(.*\\)$") ; FIXME: use it.
+ (cvs-match " *Sticky Options:[ \t]*\\(.*\\)$")) ; FIXME: use it.
+ t)
+ (cvs-or (cvs-match " *Merge From:.*") t) ;Optional CVSNT thingie.
+ (cvs-match "$")
+ ;; ignore the tags-listing in the case of `status -v'
+ (cvs-or (cvs-match " *Existing Tags:\n\\(\t.*\n\\)*$") t)
+ (cvs-parsed-fileinfo type path nil
+ :base-rev base-rev
+ :head-rev head-rev))))
+
+(defun cvs-parse-commit ()
+ (let (path file base-rev subtype)
+ (cvs-or
+
+ (and
+ (cvs-or
+ (cvs-match "\\(Checking in\\|Removing\\) \\(.*\\);$" (path 2))
+ t)
+ (cvs-match ".*,v <-- \\(.*\\)$" (file 1))
+ (cvs-or
+ ;; deletion
+ (cvs-match "new revision: delete; previous revision: \\([0-9.]*\\)$"
+ (subtype 'REMOVED) (base-rev 1))
+ ;; addition
+ (cvs-match "initial revision: \\([0-9.]*\\)$"
+ (subtype 'ADDED) (base-rev 1))
+ ;; update
+ (cvs-match "new revision: \\([0-9.]*\\); previous revision: .*$"
+ (subtype 'COMMITTED) (base-rev 1)))
+ (cvs-or (cvs-match "done$") t)
+ ;; In cvs-1.12.9 commit messages have been changed and became
+ ;; ambiguous. More specifically, the `path' above is not given.
+ ;; We assume here that in future releases the corresponding info will
+ ;; be put into `file'.
+ (progn
+ ;; Try to remove the temp files used by VC.
+ (vc-delete-automatic-version-backups (expand-file-name (or path file)))
+ ;; it's important here not to rely on the default directory management
+ ;; because `cvs commit' might begin by a series of Examining messages
+ ;; so the processing of the actual checkin messages might begin with
+ ;; a `current-dir' set to something different from ""
+ (cvs-parsed-fileinfo (cons 'UP-TO-DATE subtype)
+ (or path file) 'trust
+ :base-rev base-rev)))
+
+ ;; useless message added before the actual addition: ignored
+ (cvs-match "RCS file: .*\ndone$"))))
+
+
+(provide 'pcvs-parse)
+
+;; arch-tag: 35418375-1a23-40a0-957d-96b0262f91d6
+;;; pcvs-parse.el ends here
--- /dev/null
+;;; pcvs-util.el --- utility functions for PCL-CVS -*- byte-compile-dynamic: t -*-
+
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: pcl-cvs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+;;;;
+;;;; list processing
+;;;;
+
+(defsubst cvs-car (x) (if (consp x) (car x) x))
+(defalias 'cvs-cdr 'cdr-safe)
+(defsubst cvs-append (&rest xs)
+ (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
+
+(defsubst cvs-every (-cvs-every-f -cvs-every-l)
+ (while (consp -cvs-every-l)
+ (unless (funcall -cvs-every-f (pop -cvs-every-l))
+ (setq -cvs-every-l t)))
+ (not -cvs-every-l))
+
+(defun cvs-union (xs ys)
+ (let ((zs ys))
+ (dolist (x xs zs)
+ (unless (member x ys) (push x zs)))))
+
+(defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
+ (let ((accum ()))
+ (while (not (cvs-every 'null -cvs-map-ls))
+ (push (apply -cvs-map-f (mapcar 'car -cvs-map-ls)) accum)
+ (setq -cvs-map-ls (mapcar 'cdr -cvs-map-ls)))
+ (nreverse accum)))
+
+(defun cvs-first (l &optional n)
+ (if (null n) (car l)
+ (when l
+ (let* ((nl (list (pop l)))
+ (ret nl))
+ (while (and l (> n 1))
+ (setcdr nl (list (pop l)))
+ (setq nl (cdr nl))
+ (decf n))
+ ret))))
+
+(defun cvs-partition (p l)
+ "Partition a list L into two lists based on predicate P.
+The function returns a `cons' cell where the `car' contains
+elements of L for which P is true while the `cdr' contains
+the other elements. The ordering among elements is maintained."
+ (let (car cdr)
+ (dolist (x l)
+ (if (funcall p x) (push x car) (push x cdr)))
+ (cons (nreverse car) (nreverse cdr))))
+
+;;;
+;;; frame, window, buffer handling
+;;;
+
+(defun cvs-pop-to-buffer-same-frame (buf)
+ "Pop to BUF like `pop-to-buffer' but staying on the same frame.
+If `pop-to-buffer' would have opened a new frame, this function would
+try to split a new window instead."
+ (let ((pop-up-windows (or pop-up-windows pop-up-frames))
+ (pop-up-frames nil))
+ (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf)))
+ (and pop-up-windows
+ (ignore-errors (select-window (split-window-vertically)))
+ (switch-to-buffer buf))
+ (pop-to-buffer (current-buffer)))))
+
+(defun cvs-bury-buffer (buf &optional mainbuf)
+ "Hide the buffer BUF that was temporarily popped up.
+BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
+ (interactive (list (current-buffer)))
+ (save-current-buffer
+ (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
+ (get-buffer-window buf t))))
+ (when win
+ (if (window-dedicated-p win)
+ (condition-case ()
+ (delete-window win)
+ (error (iconify-frame (window-frame win))))
+;;; (if (and mainbuf (get-buffer-window mainbuf))
+;;; ;; FIXME: if the buffer popped into a pre-existing window,
+;;; ;; we don't want to delete that window.
+;;; t ;;(delete-window win)
+;;; )
+ )))
+ (with-current-buffer buf
+ (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
+ (not (window-dedicated-p (selected-window))))
+ buf)))
+ (when mainbuf
+ (let ((mainwin (or (get-buffer-window mainbuf)
+ (get-buffer-window mainbuf 'visible))))
+ (when mainwin (select-window mainwin))))))
+
+(defun cvs-get-buffer-create (name &optional noreuse)
+ "Create a buffer NAME unless such a buffer already exists.
+If the NAME looks like an absolute file name, the buffer will be created
+with `create-file-buffer' and will probably get another name than NAME.
+In such a case, the search for another buffer with the same name doesn't
+use the buffer name but the buffer's `list-buffers-directory' variable.
+If NOREUSE is non-nil, always return a new buffer."
+ (or (and (not (file-name-absolute-p name))
+ (if noreuse (generate-new-buffer name)
+ (get-buffer-create name)))
+ (unless noreuse
+ (dolist (buf (buffer-list))
+ (with-current-buffer buf
+ (when (equal name list-buffers-directory)
+ (return buf)))))
+ (with-current-buffer (create-file-buffer name)
+ (setq list-buffers-directory name)
+ (current-buffer))))
+
+;;;;
+;;;; string processing
+;;;;
+
+(defun cvs-insert-strings (strings)
+ "Insert a list of STRINGS into the current buffer.
+Uses columns to keep the listing readable but compact."
+ (when (consp strings)
+ (let* ((length (apply 'max (mapcar 'length strings)))
+ (wwidth (1- (window-width)))
+ (columns (min
+ ;; At least 2 columns; at least 2 spaces between columns.
+ (max 2 (/ wwidth (+ 2 length)))
+ ;; Don't allocate more columns than we can fill.
+ ;; Windows can't show less than 3 lines anyway.
+ (max 1 (/ (length strings) 2))))
+ (colwidth (/ wwidth columns)))
+ ;; Use tab-width rather than indent-to.
+ (setq tab-width colwidth)
+ ;; The insertion should be "sensible" no matter what choices were made.
+ (dolist (str strings)
+ (unless (bolp)
+ (insert " \t")
+ (when (< wwidth (+ (max colwidth (length str)) (current-column)))
+ (delete-char -2) (insert "\n")))
+ (insert str)))))
+
+
+(defun cvs-file-to-string (file &optional oneline args)
+ "Read the content of FILE and return it as a string.
+If ONELINE is t, only the first line (no \\n) will be returned.
+If ARGS is non-nil, the file will be executed with ARGS as its
+arguments. If ARGS is not a list, no argument will be passed."
+ (condition-case nil
+ (with-temp-buffer
+ (if args
+ (apply 'call-process
+ file nil t nil (when (listp args) args))
+ (insert-file-contents file))
+ (goto-char (point-min))
+ (buffer-substring (point)
+ (if oneline (line-end-position) (point-max))))
+ (file-error nil)))
+
+(defun cvs-string-prefix-p (str1 str2)
+ "Tell whether STR1 is a prefix of STR2."
+ (eq t (compare-strings str2 nil (length str1) str1 nil nil)))
+
+;;;;
+;;;; file names
+;;;;
+
+(defsubst cvs-expand-dir-name (d)
+ (file-name-as-directory (expand-file-name d)))
+
+;;;;
+;;;; (interactive <foo>) support function
+;;;;
+
+(defstruct (cvs-qtypedesc
+ (:constructor nil) (:copier nil)
+ (:constructor cvs-qtypedesc-create
+ (str2obj obj2str &optional complete hist-sym require)))
+ str2obj
+ obj2str
+ hist-sym
+ complete
+ require)
+
+
+(defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
+(defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
+(defconst cvs-qtypedesc-strings
+ (cvs-qtypedesc-create 'split-string-and-unquote
+ 'combine-and-quote-strings nil))
+
+(defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
+ (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
+ (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
+ (complete (cvs-qtypedesc-complete qtypedesc))
+ (completions (and (functionp complete) (funcall complete)))
+ (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
+ (funcall (cvs-qtypedesc-str2obj qtypedesc)
+ (cond
+ ((null complete) (read-string prompt initval hist-sym))
+ ((functionp complete)
+ (completing-read prompt completions
+ nil (cvs-qtypedesc-require qtypedesc)
+ initval hist-sym))
+ (t initval)))))
+
+;;;;
+;;;; Flags handling
+;;;;
+
+(defstruct (cvs-flags
+ (:constructor nil)
+ (:constructor -cvs-flags-make
+ (desc defaults &optional qtypedesc hist-sym)))
+ defaults persist desc qtypedesc hist-sym)
+
+(defmacro cvs-flags-define (sym defaults
+ &optional desc qtypedesc hist-sym docstring)
+ `(defconst ,sym
+ (let ((bound (boundp ',sym)))
+ (if (and bound (cvs-flags-p ,sym)) ,sym
+ (let ((defaults ,defaults))
+ (-cvs-flags-make ,desc
+ (if bound (cons ,sym (cdr defaults)) defaults)
+ ,qtypedesc ,hist-sym))))
+ ,docstring))
+
+(defun cvs-flags-query (sym &optional desc arg)
+ "Query flags based on SYM.
+Optional argument DESC will be used for the prompt.
+If ARG (or a prefix argument) is nil, just use the 0th default.
+If it is a non-negative integer, use the corresponding default.
+If it is a negative integer query for a new value of the corresponding
+ default and return that new value.
+If it is \\[universal-argument], just query and return a value without
+ altering the defaults.
+If it is \\[universal-argument] \\[universal-argument], behave just
+ as if a negative zero was provided."
+ (let* ((flags (symbol-value sym))
+ (desc (or desc (cvs-flags-desc flags)))
+ (qtypedesc (cvs-flags-qtypedesc flags))
+ (hist-sym (cvs-flags-hist-sym flags))
+ (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
+ (numarg (prefix-numeric-value arg))
+ (defaults (cvs-flags-defaults flags))
+ (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
+ ;; special case for universal-argument
+ (when (consp arg)
+ (setq permstr (if (> numarg 4) " (permanent)" ""))
+ (setq numarg 0))
+
+ ;; sanity check
+ (unless (< (abs numarg) (length defaults))
+ (error "There is no %sth default" (abs numarg)))
+
+ (if permstr
+ (let* ((prompt (format "%s%s: " desc permstr))
+ (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
+ prompt qtypedesc hist-sym)))
+ (when (not (equal permstr ""))
+ (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
+ fs)
+ (nth numarg defaults))))
+
+(defsubst cvs-flags-set (sym index value)
+ "Set SYM's INDEX'th setting to VALUE."
+ (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
+
+;;;;
+;;;; Prefix keys
+;;;;
+
+(defconst cvs-prefix-number 10)
+
+(defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
+
+(defmacro cvs-prefix-define (sym docstring desc defaults
+ &optional qtypedesc hist-sym)
+ (let ((cps (cvs-prefix-sym sym)))
+ `(progn
+ (defvar ,sym nil ,(concat (or docstring "") "
+See `cvs-prefix-set' for further description of the behavior."))
+ (defvar ,cps
+ (let ((defaults ,defaults))
+ ;; sanity ensurance
+ (unless (>= (length defaults) cvs-prefix-number)
+ (setq defaults (append defaults
+ (make-list (1- cvs-prefix-number)
+ (nth 0 defaults)))))
+ (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
+
+(defun cvs-prefix-make-local (sym)
+ (let ((cps (cvs-prefix-sym sym)))
+ (make-local-variable sym)
+ (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
+
+(defun cvs-prefix-set (sym arg)
+ ;; we could distinguish between numeric and non-numeric prefix args instead of
+ ;; relying on that magic `4'.
+ "Set the cvs-prefix contained in SYM.
+If ARG is between 0 and 9, it selects the corresponding default.
+If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
+ it queries the user and sets the -ARG'th default.
+If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
+ the (ARG mod 10)'th prefix is made persistent.
+If ARG is nil toggle the PREFIX's value between its 0th default and nil
+ and reset the persistence."
+ (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
+ (numarg (if (integerp arg) arg 0))
+ ;; (defs (cvs-flags-defaults prefix))
+ )
+
+ ;; set persistence if requested
+ (when (> (prefix-numeric-value arg) 9)
+ (setf (cvs-flags-persist prefix) t)
+ (setq numarg (mod numarg 10)))
+
+ ;; set the value
+ (set sym
+ (cond
+ ((null arg)
+ (setf (cvs-flags-persist prefix) nil)
+ (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
+
+ ((or (consp arg) (< numarg 0))
+ (setf (nth (- numarg) (cvs-flags-defaults prefix))
+ (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
+ (format "%s: " (cvs-flags-desc prefix))
+ (cvs-flags-qtypedesc prefix)
+ (cvs-flags-hist-sym prefix))))
+ (t (nth numarg (cvs-flags-defaults prefix)))))
+ (force-mode-line-update)))
+
+(defun cvs-prefix-get (sym &optional read-only)
+ "Return the current value of the prefix SYM.
+And reset it unless READ-ONLY is non-nil."
+ (prog1 (symbol-value sym)
+ (unless (or read-only
+ (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
+ (set sym nil)
+ (force-mode-line-update))))
+
+(provide 'pcvs-util)
+
+;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59
+;;; pcvs-util.el ends here
--- /dev/null
+;;; pcvs.el --- a front-end to CVS
+
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: (The PCL-CVS Trust) pcl-cvs@cyclic.com
+;; (Per Cederqvist) ceder@lysator.liu.se
+;; (Greg A. Woods) woods@weird.com
+;; (Jim Blandy) jimb@cyclic.com
+;; (Karl Fogel) kfogel@floss.red-bean.com
+;; (Jim Kingdon) kingdon@cyclic.com
+;; (Stefan Monnier) monnier@cs.yale.edu
+;; (Greg Klanderman) greg@alphatech.com
+;; (Jari Aalto+mail.emacs) jari.aalto@poboxes.com
+;; Maintainer: (Stefan Monnier) monnier@gnu.org
+;; Keywords: CVS, version control, release management
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; PCL-CVS is a front-end to the CVS version control system. For people
+;; familiar with VC, it is somewhat like VC-dired: it presents the status of
+;; all the files in your working area and allows you to commit/update several
+;; of them at a time. Compared to VC-dired, it is considerably better and
+;; faster (but only for CVS).
+
+;; PCL-CVS was originally written by Per Cederqvist many years ago. This
+;; version derives from the XEmacs-21 version, itself based on the 2.0b2
+;; version (last release from Per). It is a thorough rework.
+
+;; Contrary to what you'd expect, PCL-CVS is not a replacement for VC but only
+;; for VC-dired. As such, I've tried to make PCL-CVS and VC interoperate
+;; seamlessly (I also use VC).
+
+;; To use PCL-CVS just use `M-x cvs-examine RET <dir> RET'.
+;; There is a TeXinfo manual, which can be helpful to get started.
+
+;;; Bugs:
+
+;; - Extracting an old version seems not to recognize encoding correctly.
+;; That's probably because it's done via a process rather than a file.
+
+;;; Todo:
+
+;; ******** FIX THE DOCUMENTATION *********
+;;
+;; - rework the displaying of error messages.
+;; - allow to flush messages only
+;; - allow to protect files like ChangeLog from flushing
+;; - automatically cvs-mode-insert files from find-file-hook
+;; (and don't flush them as long as they are visited)
+;; - query the user for cvs-get-marked (for some cmds or if nothing's selected)
+;; - don't return the first (resp last) FI if the cursor is before
+;; (resp after) it.
+;; - allow cvs-confirm-removals to force always confirmation.
+;; - cvs-checkout should ask for a revision (with completion).
+;; - removal confirmation should allow specifying another file name.
+;;
+;; - hide fileinfos without getting rid of them (will require ewok work).
+;; - add toolbar entries
+;; - marking
+;; marking directories should jump to just after the dir.
+;; allow (un)marking directories at a time with the mouse.
+;; allow cvs-cmd-do to either clear the marks or not.
+;; add a "marks active" notion, like transient-mark-mode does.
+;; - liveness indicator
+;; - indicate in docstring if the cmd understands the `b' prefix(es).
+;; - call smerge-mode when opening CONFLICT files.
+;; - have vc-checkin delegate to cvs-mode-commit when applicable
+;; - higher-level CVS operations
+;; cvs-mode-rename
+;; cvs-mode-branch
+;; - module-level commands
+;; add support for parsing 'modules' file ("cvs co -c")
+;; cvs-mode-rcs2log
+;; cvs-rdiff
+;; cvs-release
+;; cvs-import
+;; C-u M-x cvs-checkout should ask for a cvsroot
+;; cvs-mode-handle-new-vendor-version
+;; - checks out module, or alternately does update join
+;; - does "cvs -n tag LAST_VENDOR" to find old files into *cvs*
+;; cvs-export
+;; (with completion on tag names and hooks to help generate full releases)
+;; - display stickiness information. And current CVS/Tag as well.
+;; - write 'cvs-mode-admin' to do arbitrary 'cvs admin' commands
+;; Most interesting would be version removal and log message replacement.
+;; The last one would be neat when called from log-view-mode.
+;; - cvs-mode-incorporate
+;; It would merge in the status from one *cvs* buffer into another.
+;; This would be used to populate such a buffer that had been created with
+;; a `cvs {update,status,checkout} -l'.
+;; - cvs-mode-(i)diff-other-{file,buffer,cvs-buffer}
+;; - offer the choice to kill the process when the user kills the cvs buffer.
+;; right now, it's killed without further ado.
+;; - make `cvs-mode-ignore' allow manually entering a pattern.
+;; to which dir should it apply ?
+;; - cvs-mode-ignore should try to remove duplicate entries.
+;; - maybe poll/check CVS/Entries files to react to external `cvs' commands ?
+;; - some kind of `cvs annotate' support ?
+;; but vc-annotate can be used instead.
+;; - proper `g' that passes safe args and uses either cvs-status or cvs-examine
+;; maybe also use cvs-update depending on I-don't-know-what.
+;; - add message-levels so that we can hide some levels of messages
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'ewoc) ;Ewoc was once cookie
+(require 'pcvs-defs)
+(require 'pcvs-util)
+(require 'pcvs-parse)
+(require 'pcvs-info)
+
+\f
+;;;;
+;;;; global vars
+;;;;
+
+(defvar cvs-cookies) ;;nil
+ ;;"Handle for the cookie structure that is displayed in the *cvs* buffer.")
+;;(make-variable-buffer-local 'cvs-cookies)
+
+;;;;
+;;;; Dynamically scoped variables
+;;;;
+
+(defvar cvs-from-vc nil "Bound to t inside VC advice.")
+
+;;;;
+;;;; flags variables
+;;;;
+
+(defun cvs-defaults (&rest defs)
+ (let ((defs (cvs-first defs cvs-shared-start)))
+ (append defs
+ (make-list (- cvs-shared-start (length defs)) (car defs))
+ cvs-shared-flags)))
+
+;; For cvs flags, we need to add "-f" to override the cvsrc settings
+;; we also want to evict the annoying -q and -Q options that hide useful
+;; information from pcl-cvs.
+(cvs-flags-define cvs-cvs-flags '(("-f")))
+
+(cvs-flags-define cvs-checkout-flags (cvs-defaults '("-P")))
+(cvs-flags-define cvs-status-flags (cvs-defaults '("-v") nil))
+(cvs-flags-define cvs-log-flags (cvs-defaults nil))
+(cvs-flags-define cvs-diff-flags (cvs-defaults '("-u" "-N") '("-c" "-N") '("-u" "-b")))
+(cvs-flags-define cvs-tag-flags (cvs-defaults nil))
+(cvs-flags-define cvs-add-flags (cvs-defaults nil))
+(cvs-flags-define cvs-commit-flags (cvs-defaults nil))
+(cvs-flags-define cvs-remove-flags (cvs-defaults nil))
+;;(cvs-flags-define cvs-undo-flags (cvs-defaults nil))
+(cvs-flags-define cvs-update-flags (cvs-defaults '("-d" "-P")))
+
+(defun cvs-reread-cvsrc ()
+ "Reset the default arguments to those in the `cvs-cvsrc-file'."
+ (interactive)
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents cvs-cvsrc-file)
+ ;; fetch the values
+ (dolist (cmd '("cvs" "checkout" "status" "log" "diff" "tag"
+ "add" "commit" "remove" "update"))
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^" cmd "\\(\\s-+\\(.*\\)\\)?$") nil t)
+ (let* ((sym (intern (concat "cvs-" cmd "-flags")))
+ (val (split-string-and-unquote (or (match-string 2) ""))))
+ (cvs-flags-set sym 0 val))))
+ ;; ensure that cvs doesn't have -q or -Q
+ (cvs-flags-set 'cvs-cvs-flags 0
+ (cons "-f"
+ (cdr (cvs-partition
+ (lambda (x) (member x '("-q" "-Q" "-f")))
+ (cvs-flags-query 'cvs-cvs-flags
+ nil 'noquery))))))
+ (file-error nil)))
+
+;; initialize to cvsrc's default values
+(cvs-reread-cvsrc)
+
+\f
+;;;;
+;;;; Mouse bindings and mode motion
+;;;;
+
+(defvar cvs-minor-current-files)
+
+(defun cvs-menu (e)
+ "Popup the CVS menu."
+ (interactive "e")
+ (let ((cvs-minor-current-files
+ (list (ewoc-data (ewoc-locate
+ cvs-cookies (posn-point (event-end e)))))))
+ (popup-menu cvs-menu e)))
+
+(defvar cvs-mode-line-process nil
+ "Mode-line control for displaying info on cvs process status.")
+
+
+;;;;
+;;;; Query-Type-Descriptor for Tags
+;;;;
+
+(autoload 'cvs-status-get-tags "cvs-status")
+(defun cvs-tags-list ()
+ "Return a list of acceptable tags, ready for completions."
+ (assert (cvs-buffer-p))
+ (let ((marked (cvs-get-marked)))
+ (list* '("BASE") '("HEAD")
+ (when marked
+ (with-temp-buffer
+ (process-file cvs-program
+ nil ;no input
+ t ;output to current-buffer
+ nil ;don't update display while running
+ "status"
+ "-v"
+ (cvs-fileinfo->full-name (car marked)))
+ (goto-char (point-min))
+ (let ((tags (cvs-status-get-tags)))
+ (when (listp tags) tags)))))))
+
+(defvar cvs-tag-history nil)
+(defconst cvs-qtypedesc-tag
+ (cvs-qtypedesc-create 'identity 'identity 'cvs-tags-list 'cvs-tag-history))
+
+;;;;
+
+(defun cvs-mode! (&optional -cvs-mode!-fun)
+ "Switch to the *cvs* buffer.
+If -CVS-MODE!-FUN is provided, it is executed *cvs* being the current buffer
+ and with its window selected. Else, the *cvs* buffer is simply selected.
+-CVS-MODE!-FUN is called interactively if applicable and else with no argument."
+ (let* ((-cvs-mode!-buf (current-buffer))
+ (cvsbuf (cond ((cvs-buffer-p) (current-buffer))
+ ((and cvs-buffer (cvs-buffer-p cvs-buffer)) cvs-buffer)
+ (t (error "can't find the *cvs* buffer"))))
+ (-cvs-mode!-wrapper cvs-minor-wrap-function)
+ (-cvs-mode!-cont (lambda ()
+ (save-current-buffer
+ (if (commandp -cvs-mode!-fun)
+ (call-interactively -cvs-mode!-fun)
+ (funcall -cvs-mode!-fun))))))
+ (if (not -cvs-mode!-fun) (set-buffer cvsbuf)
+ (let ((cvs-mode!-buf (current-buffer))
+ (cvs-mode!-owin (selected-window))
+ (cvs-mode!-nwin (get-buffer-window cvsbuf 'visible)))
+ (unwind-protect
+ (progn
+ (set-buffer cvsbuf)
+ (when cvs-mode!-nwin (select-window cvs-mode!-nwin))
+ (if -cvs-mode!-wrapper
+ (funcall -cvs-mode!-wrapper -cvs-mode!-buf -cvs-mode!-cont)
+ (funcall -cvs-mode!-cont)))
+ (set-buffer cvs-mode!-buf)
+ (when (and cvs-mode!-nwin (eq cvs-mode!-nwin (selected-window)))
+ ;; the selected window has not been changed by FUN
+ (select-window cvs-mode!-owin)))))))
+
+;;;;
+;;;; Prefixes
+;;;;
+
+(defvar cvs-branches (list cvs-vendor-branch "HEAD" "HEAD"))
+(cvs-prefix-define cvs-branch-prefix
+ "Current selected branch."
+ "version"
+ (cons cvs-vendor-branch cvs-branches)
+ cvs-qtypedesc-tag)
+
+(defun cvs-set-branch-prefix (arg)
+ "Set the branch prefix to take action at the next command.
+See `cvs-prefix-set' for a further the description of the behavior.
+\\[universal-argument] 1 selects the vendor branch
+and \\[universal-argument] 2 selects the HEAD."
+ (interactive "P")
+ (cvs-mode!)
+ (cvs-prefix-set 'cvs-branch-prefix arg))
+
+(defun cvs-add-branch-prefix (flags &optional arg)
+ "Add branch selection argument if the branch prefix was set.
+The argument is added (or not) to the list of FLAGS and is constructed
+by appending the branch to ARG which defaults to \"-r\"."
+ (let ((branch (cvs-prefix-get 'cvs-branch-prefix)))
+ ;; deactivate the secondary prefix, even if not used.
+ (cvs-prefix-get 'cvs-secondary-branch-prefix)
+ (if branch (cons (concat (or arg "-r") branch) flags) flags)))
+
+(cvs-prefix-define cvs-secondary-branch-prefix
+ "Current secondary selected branch."
+ "version"
+ (cons cvs-vendor-branch cvs-branches)
+ cvs-qtypedesc-tag)
+
+(defun cvs-set-secondary-branch-prefix (arg)
+ "Set the branch prefix to take action at the next command.
+See `cvs-prefix-set' for a further the description of the behavior.
+\\[universal-argument] 1 selects the vendor branch
+and \\[universal-argument] 2 selects the HEAD."
+ (interactive "P")
+ (cvs-mode!)
+ (cvs-prefix-set 'cvs-secondary-branch-prefix arg))
+
+(defun cvs-add-secondary-branch-prefix (flags &optional arg)
+ "Add branch selection argument if the secondary branch prefix was set.
+The argument is added (or not) to the list of FLAGS and is constructed
+by appending the branch to ARG which defaults to \"-r\".
+Since the `cvs-secondary-branch-prefix' is only active if the primary
+prefix is active, it is important to read the secondary prefix before
+the primay since reading the primary can deactivate it."
+ (let ((branch (and (cvs-prefix-get 'cvs-branch-prefix 'read-only)
+ (cvs-prefix-get 'cvs-secondary-branch-prefix))))
+ (if branch (cons (concat (or arg "-r") branch) flags) flags)))
+
+;;;;
+
+(define-minor-mode cvs-minor-mode
+ "This mode is used for buffers related to a main *cvs* buffer.
+All the `cvs-mode' buffer operations are simply rebound under
+the \\[cvs-mode-map] prefix."
+ nil " CVS"
+ :group 'pcl-cvs)
+(put 'cvs-minor-mode 'permanent-local t)
+
+
+(defvar cvs-temp-buffers nil)
+(defun cvs-temp-buffer (&optional cmd normal nosetup)
+ "Create a temporary buffer to run CMD in.
+If CMD is a string, use it to lookup `cvs-buffer-name-alist' to find
+the buffer name to be used and its `major-mode'.
+
+The selected window will not be changed. The new buffer will not maintain undo
+information and will be read-only unless NORMAL is non-nil. It will be emptied
+\(unless NOSETUP is non-nil\) and its `default-directory' will be inherited
+from the current buffer."
+ (let* ((cvs-buf (current-buffer))
+ (info (cdr (assoc cmd cvs-buffer-name-alist)))
+ (name (eval (nth 0 info)))
+ (mode (nth 1 info))
+ (dir default-directory)
+ (buf (cond
+ (name (cvs-get-buffer-create name))
+ ((and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer))
+ cvs-temp-buffer)
+ (t
+ (set (make-local-variable 'cvs-temp-buffer)
+ (cvs-get-buffer-create
+ (eval cvs-temp-buffer-name) 'noreuse))))))
+
+ ;; handle the potential pre-existing process
+ (let ((proc (get-buffer-process buf)))
+ (when (and (not normal) (processp proc)
+ (memq (process-status proc) '(run stop)))
+ (if cmd
+ ;; When CMD is specified, the buffer is normally shown to the
+ ;; user, so interrupting the process is not harmful.
+ ;; Use `delete-process' rather than `kill-process' otherwise
+ ;; the pending output of the process will still get inserted
+ ;; after we erase the buffer.
+ (delete-process proc)
+ (error "Can not run two cvs processes simultaneously"))))
+
+ (if (not name) (kill-local-variable 'other-window-scroll-buffer)
+ ;; Strangely, if no window is created, `display-buffer' ends up
+ ;; doing a `switch-to-buffer' which does a `set-buffer', hence
+ ;; the need for `save-excursion'.
+ (unless nosetup (save-excursion (display-buffer buf)))
+ ;; FIXME: this doesn't do the right thing if the user later on
+ ;; does a `find-file-other-window' and `scroll-other-window'
+ (set (make-local-variable 'other-window-scroll-buffer) buf))
+
+ (add-to-list 'cvs-temp-buffers buf)
+
+ (with-current-buffer buf
+ (setq buffer-read-only nil)
+ (setq default-directory dir)
+ (unless nosetup
+ ;; Disable undo before calling erase-buffer since it may generate
+ ;; a very large and unwanted undo record.
+ (buffer-disable-undo)
+ (erase-buffer))
+ (set (make-local-variable 'cvs-buffer) cvs-buf)
+ ;;(cvs-minor-mode 1)
+ (let ((lbd list-buffers-directory))
+ (if (fboundp mode) (funcall mode) (fundamental-mode))
+ (when lbd (setq list-buffers-directory lbd)))
+ (cvs-minor-mode 1)
+ ;;(set (make-local-variable 'cvs-buffer) cvs-buf)
+ (if normal
+ (buffer-enable-undo)
+ (setq buffer-read-only t)
+ (buffer-disable-undo))
+ buf)))
+
+(defun cvs-mode-kill-buffers ()
+ "Kill all the \"temporary\" buffers created by the *cvs* buffer."
+ (interactive)
+ (dolist (buf cvs-temp-buffers) (ignore-errors (kill-buffer buf))))
+
+(defun cvs-make-cvs-buffer (dir &optional new)
+ "Create the *cvs* buffer for directory DIR.
+If non-nil, NEW means to create a new buffer no matter what."
+ ;; the real cvs-buffer creation
+ (setq dir (cvs-expand-dir-name dir))
+ (let* ((buffer-name (eval cvs-buffer-name))
+ (buffer
+ (or (and (not new)
+ (eq cvs-reuse-cvs-buffer 'current)
+ (cvs-buffer-p) ;reuse the current buffer if possible
+ (current-buffer))
+ ;; look for another cvs buffer visiting the same directory
+ (save-excursion
+ (unless new
+ (dolist (buffer (cons (current-buffer) (buffer-list)))
+ (set-buffer buffer)
+ (and (cvs-buffer-p)
+ (case cvs-reuse-cvs-buffer
+ (always t)
+ (subdir
+ (or (cvs-string-prefix-p default-directory dir)
+ (cvs-string-prefix-p dir default-directory)))
+ (samedir (string= default-directory dir)))
+ (return buffer)))))
+ ;; we really have to create a new buffer:
+ ;; we temporarily bind cwd to "" to prevent
+ ;; create-file-buffer from using directory info
+ ;; unless it is explicitly in the cvs-buffer-name.
+ (cvs-get-buffer-create buffer-name new))))
+ (with-current-buffer buffer
+ (or
+ (and (string= dir default-directory) (cvs-buffer-p)
+ ;; just a refresh
+ (ignore-errors
+ (cvs-cleanup-collection cvs-cookies nil nil t)
+ (current-buffer)))
+ ;; setup from scratch
+ (progn
+ (setq default-directory dir)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (insert "Repository : " (directory-file-name (cvs-get-cvsroot))
+ "\nModule : " (cvs-get-module)
+ "\nWorking dir: " (abbreviate-file-name dir)
+ (if (not (file-readable-p "CVS/Tag")) "\n"
+ (let ((tag (cvs-file-to-string "CVS/Tag")))
+ (cond
+ ((string-match "\\`T" tag)
+ (concat "\nTag : " (substring tag 1)))
+ ((string-match "\\`D" tag)
+ (concat "\nDate : " (substring tag 1)))
+ ("\n"))))
+ "\n")
+ (setq buffer-read-only t)
+ (cvs-mode)
+ (set (make-local-variable 'list-buffers-directory) buffer-name)
+ ;;(set (make-local-variable 'cvs-temp-buffer) (cvs-temp-buffer))
+ (let ((cookies (ewoc-create 'cvs-fileinfo-pp "\n\n" "\n" t)))
+ (set (make-local-variable 'cvs-cookies) cookies)
+ (add-hook 'kill-buffer-hook
+ (lambda ()
+ (ignore-errors (kill-buffer cvs-temp-buffer)))
+ nil t)
+ ;;(set-buffer buf)
+ buffer))))))
+
+(defun* cvs-cmd-do (cmd dir flags fis new
+ &key cvsargs noexist dont-change-disc noshow)
+ (let* ((dir (file-name-as-directory
+ (abbreviate-file-name (expand-file-name dir))))
+ (cvsbuf (cvs-make-cvs-buffer dir new)))
+ ;; Check that dir is under CVS control.
+ (unless (file-directory-p dir)
+ (error "%s is not a directory" dir))
+ (unless (or noexist (file-directory-p (expand-file-name "CVS" dir))
+ (file-expand-wildcards (expand-file-name "*/CVS" dir)))
+ (error "%s does not contain CVS controlled files" dir))
+
+ (set-buffer cvsbuf)
+ (cvs-mode-run cmd flags fis
+ :cvsargs cvsargs :dont-change-disc dont-change-disc)
+
+ (if noshow cvsbuf
+ (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf)))))
+;; (funcall (if (and (boundp 'pop-up-frames) pop-up-frames)
+;; 'pop-to-buffer 'switch-to-buffer)
+;; cvsbuf))))
+
+(defun cvs-run-process (args fis postprocess &optional single-dir)
+ (assert (cvs-buffer-p cvs-buffer))
+ (save-current-buffer
+ (let ((procbuf (current-buffer))
+ (cvsbuf cvs-buffer)
+ (single-dir (or single-dir (eq cvs-execute-single-dir t))))
+
+ (set-buffer procbuf)
+ (goto-char (point-max))
+ (unless (bolp) (let ((inhibit-read-only t)) (insert "\n")))
+ ;; find the set of files we'll process in this round
+ (let* ((dir+files+rest
+ (if (or (null fis) (not single-dir))
+ ;; not single-dir mode: just process the whole thing
+ (list "" (mapcar 'cvs-fileinfo->full-name fis) nil)
+ ;; single-dir mode: extract the same-dir-elements
+ (let ((dir (cvs-fileinfo->dir (car fis))))
+ ;; output the concerned dir so the parser can translate paths
+ (let ((inhibit-read-only t))
+ (insert "pcl-cvs: descending directory " dir "\n"))
+ ;; loop to find the same-dir-elems
+ (do* ((files () (cons (cvs-fileinfo->file fi) files))
+ (fis fis (cdr fis))
+ (fi (car fis) (car fis)))
+ ((not (and fis (string= dir (cvs-fileinfo->dir fi))))
+ (list dir files fis))))))
+ (dir (nth 0 dir+files+rest))
+ (files (nth 1 dir+files+rest))
+ (rest (nth 2 dir+files+rest)))
+
+ (add-hook 'kill-buffer-hook
+ (lambda ()
+ (let ((proc (get-buffer-process (current-buffer))))
+ (when (processp proc)
+ (set-process-filter proc nil)
+ ;; Abort postprocessing but leave the sentinel so it
+ ;; will update the list of running procs.
+ (process-put proc 'cvs-postprocess nil)
+ (interrupt-process proc))))
+ nil t)
+
+ ;; create the new process and setup the procbuffer correspondingly
+ (let* ((msg (cvs-header-msg args fis))
+ (args (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery)
+ (if cvs-cvsroot (list "-d" cvs-cvsroot))
+ args
+ files))
+ ;; If process-connection-type is nil and the repository
+ ;; is accessed via SSH, a bad interaction between libc,
+ ;; CVS and SSH can lead to garbled output.
+ ;; It might be a glibc-specific problem (but it can also happens
+ ;; under Mac OS X, it seems).
+ ;; It seems that using a pty can help circumvent the problem,
+ ;; but at the cost of screwing up when the process thinks it
+ ;; can ask for user input (such as password or host-key
+ ;; confirmation). A better workaround is to set CVS_RSH to
+ ;; an appropriate script, or to use a later version of CVS.
+ (process-connection-type nil) ; Use a pipe, not a pty.
+ (process
+ ;; the process will be run in the selected dir
+ (let ((default-directory (cvs-expand-dir-name dir)))
+ (apply 'start-file-process "cvs" procbuf cvs-program args))))
+ ;; setup the process.
+ (process-put process 'cvs-buffer cvs-buffer)
+ (with-current-buffer cvs-buffer (cvs-update-header msg 'add))
+ (process-put process 'cvs-header msg)
+ (process-put
+ process 'cvs-postprocess
+ (if (null rest)
+ ;; this is the last invocation
+ postprocess
+ ;; else, we have to register ourselves to be rerun on the rest
+ `(cvs-run-process ',args ',rest ',postprocess ',single-dir)))
+ (set-process-sentinel process 'cvs-sentinel)
+ (set-process-filter process 'cvs-update-filter)
+ (set-marker (process-mark process) (point-max))
+ (ignore-errors (process-send-eof process)) ;close its stdin to avoid hangs
+
+ ;; now finish setting up the cvs-buffer
+ (set-buffer cvsbuf)
+ (setq cvs-mode-line-process (symbol-name (process-status process)))
+ (force-mode-line-update)))))
+
+ ;; The following line is said to improve display updates on some
+ ;; emacsen. It shouldn't be needed, but it does no harm.
+ (sit-for 0))
+
+(defun cvs-header-msg (args fis)
+ (let* ((lastarg nil)
+ (args (mapcar (lambda (arg)
+ (cond
+ ;; filter out the largish commit message
+ ((and (eq lastarg nil) (string= arg "commit"))
+ (setq lastarg 'commit) arg)
+ ((and (eq lastarg 'commit) (string= arg "-m"))
+ (setq lastarg '-m) arg)
+ ((eq lastarg '-m)
+ (setq lastarg 'done) "<log message>")
+ ;; filter out the largish `admin -mrev:msg' message
+ ((and (eq lastarg nil) (string= arg "admin"))
+ (setq lastarg 'admin) arg)
+ ((and (eq lastarg 'admin)
+ (string-match "\\`-m[^:]*:" arg))
+ (setq lastarg 'done)
+ (concat (match-string 0 arg) "<log message>"))
+ ;; Keep the rest as is.
+ (t arg)))
+ args)))
+ (concat cvs-program " "
+ (combine-and-quote-strings
+ (append (cvs-flags-query 'cvs-cvs-flags nil 'noquery)
+ (if cvs-cvsroot (list "-d" cvs-cvsroot))
+ args
+ (mapcar 'cvs-fileinfo->full-name fis))))))
+
+(defun cvs-update-header (cmd add)
+ (let* ((hf (ewoc-get-hf cvs-cookies))
+ (str (car hf))
+ (done "")
+ (tin (ewoc-nth cvs-cookies 0)))
+ ;; look for the first *real* fileinfo (to determine emptyness)
+ (while
+ (and tin
+ (memq (cvs-fileinfo->type (ewoc-data tin))
+ '(MESSAGE DIRCHANGE)))
+ (setq tin (ewoc-next cvs-cookies tin)))
+ (if add
+ (progn
+ ;; Remove the default empty line, if applicable.
+ (if (not (string-match "." str)) (setq str "\n"))
+ (setq str (concat "-- Running " cmd " ...\n" str)))
+ (if (not (string-match
+ ;; FIXME: If `cmd' is large, this will bump into the
+ ;; compiled-regexp size limit. We could drop the "^" anchor
+ ;; and use search-forward to circumvent the problem.
+ (concat "^-- Running " (regexp-quote cmd) " \\.\\.\\.\n") str))
+ (error "Internal PCL-CVS error while removing message")
+ (setq str (replace-match "" t t str))
+ ;; Re-add the default empty line, if applicable.
+ (if (not (string-match "." str)) (setq str "\n\n"))
+ (setq done (concat "-- last cmd: " cmd " --\n"))))
+ ;; set the new header and footer
+ (ewoc-set-hf cvs-cookies
+ str (concat "\n--------------------- "
+ (if tin "End" "Empty")
+ " ---------------------\n"
+ done))))
+
+
+(defun cvs-sentinel (proc msg)
+ "Sentinel for the cvs update process.
+This is responsible for parsing the output from the cvs update when
+it is finished."
+ (when (memq (process-status proc) '(signal exit))
+ (let ((cvs-postproc (process-get proc 'cvs-postprocess))
+ (cvs-buf (process-get proc 'cvs-buffer))
+ (procbuf (process-buffer proc)))
+ (unless (buffer-live-p cvs-buf) (setq cvs-buf nil))
+ (unless (buffer-live-p procbuf) (setq procbuf nil))
+ ;; Since the buffer and mode line will show that the
+ ;; process is dead, we can delete it now. Otherwise it
+ ;; will stay around until M-x list-processes.
+ (process-put proc 'postprocess nil)
+ (delete-process proc)
+ ;; Don't do anything if the main buffer doesn't exist any more.
+ (when cvs-buf
+ (with-current-buffer cvs-buf
+ (cvs-update-header (process-get proc 'cvs-header) nil)
+ (setq cvs-mode-line-process (symbol-name (process-status proc)))
+ (force-mode-line-update)
+ (when cvs-postproc
+ (if (null procbuf)
+ ;;(set-process-buffer proc nil)
+ (error "cvs' process buffer was killed")
+ (with-current-buffer procbuf
+ ;; Do the postprocessing like parsing and such.
+ (save-excursion (eval cvs-postproc)))))))
+ ;; Check whether something is left.
+ (when (and procbuf (not (get-buffer-process procbuf)))
+ (with-current-buffer procbuf
+ ;; IIRC, we enable undo again once the process is finished
+ ;; for cases where the output was inserted in *vc-diff* or
+ ;; in a file-like buffer. --Stef
+ (buffer-enable-undo)
+ (with-current-buffer (or cvs-buf (current-buffer))
+ (message "CVS process has completed in %s"
+ (buffer-name))))))))
+
+(defun cvs-parse-process (dcd &optional subdir old-fis)
+ "Parse the output of a cvs process.
+DCD is the `dont-change-disc' flag to use when parsing that output.
+SUBDIR is the subdirectory (if any) where this command was run.
+OLD-FIS is the list of fileinfos on which the cvs command was applied and
+ which should be considered up-to-date if they are missing from the output."
+ (when (eq system-type 'darwin)
+ ;; Fixup the ^D^H^H inserted at beginning of buffer sometimes on MacOSX
+ ;; because of the call to `process-send-eof'.
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^\\^D\b+" nil t)
+ (let ((inhibit-read-only t))
+ (delete-region (match-beginning 0) (match-end 0))))))
+ (let* ((fileinfos (cvs-parse-buffer 'cvs-parse-table dcd subdir))
+ last)
+ (with-current-buffer cvs-buffer
+ ;; Expand OLD-FIS to actual files.
+ (let ((fis nil))
+ (dolist (fi old-fis)
+ (setq fis (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
+ (nconc (ewoc-collect cvs-cookies 'cvs-dir-member-p
+ (cvs-fileinfo->dir fi))
+ fis)
+ (cons fi fis))))
+ (setq old-fis fis))
+ ;; Drop OLD-FIS which were already up-to-date.
+ (let ((fis nil))
+ (dolist (fi old-fis)
+ (unless (eq (cvs-fileinfo->type fi) 'UP-TO-DATE) (push fi fis)))
+ (setq old-fis fis))
+ ;; Add the new fileinfos to the ewoc.
+ (dolist (fi fileinfos)
+ (setq last (cvs-addto-collection cvs-cookies fi last))
+ ;; This FI was in the output, so remove it from OLD-FIS.
+ (setq old-fis (delq (ewoc-data last) old-fis)))
+ ;; Process the "silent output" (i.e. absence means up-to-date).
+ (dolist (fi old-fis)
+ (setf (cvs-fileinfo->type fi) 'UP-TO-DATE)
+ (setq last (cvs-addto-collection cvs-cookies fi last)))
+ (setq fileinfos (nconc old-fis fileinfos))
+ ;; Clean up the ewoc as requested by the user.
+ (cvs-cleanup-collection cvs-cookies
+ (eq cvs-auto-remove-handled t)
+ cvs-auto-remove-directories
+ nil)
+ ;; Revert buffers if necessary.
+ (when (and cvs-auto-revert (not dcd) (not cvs-from-vc))
+ (cvs-revert-if-needed fileinfos)))))
+
+(defmacro defun-cvs-mode (fun args docstring interact &rest body)
+ "Define a function to be used in a *cvs* buffer.
+This will look for a *cvs* buffer and execute BODY in it.
+Since the interactive arguments might need to be queried after
+switching to the *cvs* buffer, the generic code is rather ugly,
+but luckily we can often use simpler alternatives.
+
+FUN can be either a symbol (i.e. STYLE is nil) or a cons (FUN . STYLE).
+ARGS and DOCSTRING are the normal argument list.
+INTERACT is the interactive specification or nil for non-commands.
+
+STYLE can be either SIMPLE, NOARGS or DOUBLE. It's an error for it
+to have any other value, unless other details of the function make it
+clear what alternative to use.
+- SIMPLE will get all the interactive arguments from the original buffer.
+- NOARGS will get all the arguments from the *cvs* buffer and will
+ always behave as if called interactively.
+- DOUBLE is the generic case."
+ (declare (debug (&define sexp lambda-list stringp ("interactive" interactive) def-body))
+ (doc-string 3))
+ (let ((style (cvs-cdr fun))
+ (fun (cvs-car fun)))
+ (cond
+ ;; a trivial interaction, no need to move it
+ ((or (eq style 'SIMPLE)
+ (null (nth 1 interact))
+ (stringp (nth 1 interact)))
+ `(defun ,fun ,args ,docstring ,interact
+ (cvs-mode! (lambda () ,@body))))
+
+ ;; fun is only called interactively: move all the args to the inner fun
+ ((eq style 'NOARGS)
+ `(defun ,fun () ,docstring (interactive)
+ (cvs-mode! (lambda ,args ,interact ,@body))))
+
+ ;; bad case
+ ((eq style 'DOUBLE)
+ (string-match ".*" docstring)
+ (let ((line1 (match-string 0 docstring))
+ (fun-1 (intern (concat (symbol-name fun) "-1"))))
+ `(progn
+ (defun ,fun-1 ,args
+ ,(concat docstring "\nThis function only works within a *cvs* buffer.
+For interactive use, use `" (symbol-name fun) "' instead.")
+ ,interact
+ ,@body)
+ (put ',fun-1 'definition-name ',fun)
+ (defun ,fun ()
+ ,(concat line1 "\nWrapper function that switches to a *cvs* buffer
+before calling the real function `" (symbol-name fun-1) "'.\n")
+ (interactive)
+ (cvs-mode! ',fun-1)))))
+
+ (t (error "Unknown style %s in `defun-cvs-mode'" style)))))
+
+(defun-cvs-mode cvs-mode-kill-process ()
+ "Kill the temporary buffer and associated process."
+ (interactive)
+ (when (and (bufferp cvs-temp-buffer) (buffer-live-p cvs-temp-buffer))
+ (let ((proc (get-buffer-process cvs-temp-buffer)))
+ (when proc (delete-process proc)))))
+
+;;
+;; Maintaining the collection in the face of updates
+;;
+
+(defun cvs-addto-collection (c fi &optional tin)
+ "Add FI to C and return FI's corresponding tin.
+FI is inserted in its proper place or maybe even merged with a preexisting
+ fileinfo if applicable.
+TIN specifies an optional starting point."
+ (unless tin (setq tin (ewoc-nth c 0)))
+ (while (and tin (cvs-fileinfo< fi (ewoc-data tin)))
+ (setq tin (ewoc-prev c tin)))
+ (if (null tin) (ewoc-enter-first c fi) ;empty collection
+ (assert (not (cvs-fileinfo< fi (ewoc-data tin))))
+ (let ((next-tin (ewoc-next c tin)))
+ (while (not (or (null next-tin)
+ (cvs-fileinfo< fi (ewoc-data next-tin))))
+ (setq tin next-tin next-tin (ewoc-next c next-tin)))
+ (if (or (cvs-fileinfo< (ewoc-data tin) fi)
+ (eq (cvs-fileinfo->type fi) 'MESSAGE))
+ ;; tin < fi < next-tin
+ (ewoc-enter-after c tin fi)
+ ;; fi == tin
+ (cvs-fileinfo-update (ewoc-data tin) fi)
+ (ewoc-invalidate c tin)
+ ;; Move cursor back to where it belongs.
+ (when (bolp) (cvs-move-to-goal-column))
+ tin))))
+
+(defcustom cvs-cleanup-functions nil
+ "Functions to tweak the cleanup process.
+The functions are called with a single argument (a FILEINFO) and should
+return a non-nil value if that fileinfo should be removed."
+ :group 'pcl-cvs
+ :type '(hook :options (cvs-cleanup-removed)))
+
+(defun cvs-cleanup-removed (fi)
+ "Non-nil if FI has been cvs-removed but still exists.
+This is intended for use on `cvs-cleanup-functions' when you have cvs-removed
+automatically generated files (which should hence not be under CVS control)
+but can't commit the removal because the repository's owner doesn't understand
+the problem."
+ (and (or (eq (cvs-fileinfo->type fi) 'REMOVED)
+ (and (eq (cvs-fileinfo->type fi) 'CONFLICT)
+ (eq (cvs-fileinfo->subtype fi) 'REMOVED)))
+ (file-exists-p (cvs-fileinfo->full-name fi))))
+
+;; called at the following times:
+;; - postparse ((eq cvs-auto-remove-handled t) cvs-auto-remove-directories nil)
+;; - pre-run ((eq cvs-auto-remove-handled 'delayed) nil t)
+;; - remove-handled (t (or cvs-auto-remove-directories 'handled) t)
+;; - cvs-cmd-do (nil nil t)
+;; - post-ignore (nil nil nil)
+;; - acknowledge (nil nil nil)
+;; - remove (nil nil nil)
+(defun cvs-cleanup-collection (c rm-handled rm-dirs rm-msgs)
+ "Remove undesired entries.
+C is the collection
+RM-HANDLED if non-nil means remove handled entries.
+RM-DIRS behaves like `cvs-auto-remove-directories'.
+RM-MSGS if non-nil means remove messages."
+ (let (last-fi first-dir (rerun t))
+ (while rerun
+ (setq rerun nil)
+ (setq first-dir t)
+ (setq last-fi (cvs-create-fileinfo 'DEAD "../" "" "")) ;place-holder
+ (ewoc-filter
+ c (lambda (fi)
+ (let* ((type (cvs-fileinfo->type fi))
+ (subtype (cvs-fileinfo->subtype fi))
+ (keep
+ (case type
+ ;; remove temp messages and keep the others
+ (MESSAGE (not (or rm-msgs (eq subtype 'TEMP))))
+ ;; remove entries
+ (DEAD nil)
+ ;; handled also?
+ (UP-TO-DATE (not rm-handled))
+ ;; keep the rest
+ (t (not (run-hook-with-args-until-success
+ 'cvs-cleanup-functions fi))))))
+
+ ;; mark dirs for removal
+ (when (and keep rm-dirs
+ (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE)
+ (not (when first-dir (setq first-dir nil) t))
+ (or (eq rm-dirs 'all)
+ (not (cvs-string-prefix-p
+ (cvs-fileinfo->dir last-fi)
+ (cvs-fileinfo->dir fi)))
+ (and (eq type 'DIRCHANGE) (eq rm-dirs 'empty))
+ (eq subtype 'FOOTER)))
+ (setf (cvs-fileinfo->type last-fi) 'DEAD)
+ (setq rerun t))
+ (when keep (setq last-fi fi)))))
+ ;; remove empty last dir
+ (when (and rm-dirs
+ (not first-dir)
+ (eq (cvs-fileinfo->type last-fi) 'DIRCHANGE))
+ (setf (cvs-fileinfo->type last-fi) 'DEAD)
+ (setq rerun t)))))
+
+(defun cvs-get-cvsroot ()
+ "Gets the CVSROOT for DIR."
+ (let ((cvs-cvsroot-file (expand-file-name "Root" "CVS")))
+ (or (cvs-file-to-string cvs-cvsroot-file t)
+ cvs-cvsroot
+ (getenv "CVSROOT")
+ "?????")))
+
+(defun cvs-get-module ()
+ "Return the current CVS module.
+This usually doesn't really work but is a handy initval in a prompt."
+ (let* ((repfile (expand-file-name "Repository" "CVS"))
+ (rep (cvs-file-to-string repfile t)))
+ (cond
+ ((null rep) "")
+ ((not (file-name-absolute-p rep)) rep)
+ (t
+ (let* ((root (cvs-get-cvsroot))
+ (str (concat (file-name-as-directory (or root "/")) " || " rep)))
+ (if (and root (string-match "\\(.*\\) || \\1\\(.*\\)\\'" str))
+ (match-string 2 str)
+ (file-name-nondirectory rep)))))))
+
+
+\f
+;;;;
+;;;; running a "cvs checkout".
+;;;;
+
+;;;###autoload
+(defun cvs-checkout (modules dir flags &optional root)
+ "Run a 'cvs checkout MODULES' in DIR.
+Feed the output to a *cvs* buffer, display it in the current window,
+and run `cvs-mode' on it.
+
+With a prefix argument, prompt for cvs FLAGS to use."
+ (interactive
+ (let ((root (cvs-get-cvsroot)))
+ (if (or (null root) current-prefix-arg)
+ (setq root (read-string "CVS Root: ")))
+ (list (split-string-and-unquote
+ (read-string "Module(s): " (cvs-get-module)))
+ (read-directory-name "CVS Checkout Directory: "
+ nil default-directory nil)
+ (cvs-add-branch-prefix
+ (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags"))
+ root)))
+ (when (eq flags t)
+ (setf flags (cvs-flags-query 'cvs-checkout-flags nil 'noquery)))
+ (let ((cvs-cvsroot root))
+ (cvs-cmd-do "checkout" (or dir default-directory)
+ (append flags modules) nil 'new
+ :noexist t)))
+
+(defun-cvs-mode (cvs-mode-checkout . NOARGS) (dir)
+ "Run cvs checkout against the current branch.
+The files are stored to DIR."
+ (interactive
+ (let* ((branch (cvs-prefix-get 'cvs-branch-prefix))
+ (prompt (format "CVS Checkout Directory for `%s%s': "
+ (cvs-get-module)
+ (if branch (format " (branch: %s)" branch)
+ ""))))
+ (list (read-directory-name prompt nil default-directory nil))))
+ (let ((modules (split-string-and-unquote (cvs-get-module)))
+ (flags (cvs-add-branch-prefix
+ (cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")))
+ (cvs-cvsroot (cvs-get-cvsroot)))
+ (cvs-checkout modules dir flags)))
+\f
+;;;;
+;;;; The code for running a "cvs update" and friends in various ways.
+;;;;
+
+(defun-cvs-mode (cvs-mode-revert-buffer . SIMPLE)
+ (&optional ignore-auto noconfirm)
+ "Rerun `cvs-examine' on the current directory with the default flags."
+ (interactive)
+ (cvs-examine default-directory t))
+
+(defun cvs-query-directory (prompt)
+ "Read directory name, prompting with PROMPT.
+If in a *cvs* buffer, don't prompt unless a prefix argument is given."
+ (if (and (cvs-buffer-p)
+ (not current-prefix-arg))
+ default-directory
+ (read-directory-name prompt nil default-directory nil)))
+
+;;;###autoload
+(defun cvs-quickdir (dir &optional flags noshow)
+ "Open a *cvs* buffer on DIR without running cvs.
+With a prefix argument, prompt for a directory to use.
+A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
+ prevents reuse of an existing *cvs* buffer.
+Optional argument NOSHOW if non-nil means not to display the buffer.
+FLAGS is ignored."
+ (interactive (list (cvs-query-directory "CVS quickdir (directory): ")))
+ ;; FIXME: code duplication with cvs-cmd-do and cvs-parse-process
+ (let* ((dir (file-name-as-directory
+ (abbreviate-file-name (expand-file-name dir))))
+ (new (> (prefix-numeric-value current-prefix-arg) 8))
+ (cvsbuf (cvs-make-cvs-buffer dir new))
+ last)
+ ;; Check that dir is under CVS control.
+ (unless (file-directory-p dir)
+ (error "%s is not a directory" dir))
+ (unless (file-directory-p (expand-file-name "CVS" dir))
+ (error "%s does not contain CVS controlled files" dir))
+ (set-buffer cvsbuf)
+ (dolist (fi (cvs-fileinfo-from-entries ""))
+ (setq last (cvs-addto-collection cvs-cookies fi last)))
+ (cvs-cleanup-collection cvs-cookies
+ (eq cvs-auto-remove-handled t)
+ cvs-auto-remove-directories
+ nil)
+ (if noshow cvsbuf
+ (let ((pop-up-windows nil)) (pop-to-buffer cvsbuf)))))
+
+;;;###autoload
+(defun cvs-examine (directory flags &optional noshow)
+ "Run a `cvs -n update' in the specified DIRECTORY.
+That is, check what needs to be done, but don't change the disc.
+Feed the output to a *cvs* buffer and run `cvs-mode' on it.
+With a prefix argument, prompt for a directory and cvs FLAGS to use.
+A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
+ prevents reuse of an existing *cvs* buffer.
+Optional argument NOSHOW if non-nil means not to display the buffer."
+ (interactive (list (cvs-query-directory "CVS Examine (directory): ")
+ (cvs-flags-query 'cvs-update-flags "cvs -n update flags")))
+ (when (eq flags t)
+ (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery)))
+ (when find-file-visit-truename (setq directory (file-truename directory)))
+ (cvs-cmd-do "update" directory flags nil
+ (> (prefix-numeric-value current-prefix-arg) 8)
+ :cvsargs '("-n")
+ :noshow noshow
+ :dont-change-disc t))
+
+
+;;;###autoload
+(defun cvs-update (directory flags)
+ "Run a `cvs update' in the current working DIRECTORY.
+Feed the output to a *cvs* buffer and run `cvs-mode' on it.
+With a \\[universal-argument] prefix argument, prompt for a directory to use.
+A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
+ prevents reuse of an existing *cvs* buffer.
+The prefix is also passed to `cvs-flags-query' to select the FLAGS
+ passed to cvs."
+ (interactive (list (cvs-query-directory "CVS Update (directory): ")
+ (cvs-flags-query 'cvs-update-flags "cvs update flags")))
+ (when (eq flags t)
+ (setf flags (cvs-flags-query 'cvs-update-flags nil 'noquery)))
+ (cvs-cmd-do "update" directory flags nil
+ (> (prefix-numeric-value current-prefix-arg) 8)))
+
+
+;;;###autoload
+(defun cvs-status (directory flags &optional noshow)
+ "Run a `cvs status' in the current working DIRECTORY.
+Feed the output to a *cvs* buffer and run `cvs-mode' on it.
+With a prefix argument, prompt for a directory and cvs FLAGS to use.
+A prefix arg >8 (ex: \\[universal-argument] \\[universal-argument]),
+ prevents reuse of an existing *cvs* buffer.
+Optional argument NOSHOW if non-nil means not to display the buffer."
+ (interactive (list (cvs-query-directory "CVS Status (directory): ")
+ (cvs-flags-query 'cvs-status-flags "cvs status flags")))
+ (when (eq flags t)
+ (setf flags (cvs-flags-query 'cvs-status-flags nil 'noquery)))
+ (cvs-cmd-do "status" directory flags nil
+ (> (prefix-numeric-value current-prefix-arg) 8)
+ :noshow noshow :dont-change-disc t))
+
+(defun cvs-update-filter (proc string)
+ "Filter function for pcl-cvs.
+This function gets the output that CVS sends to stdout. It inserts
+the STRING into (process-buffer PROC) but it also checks if CVS is waiting
+for a lock file. If so, it inserts a message cookie in the *cvs* buffer."
+ (save-match-data
+ (with-current-buffer (process-buffer proc)
+ (let ((inhibit-read-only t))
+ (save-excursion
+ ;; Insert the text, moving the process-marker.
+ (goto-char (process-mark proc))
+ (insert string)
+ (set-marker (process-mark proc) (point))
+ ;; FIXME: Delete any old lock message
+ ;;(if (tin-nth cookies 1)
+ ;; (tin-delete cookies
+ ;; (tin-nth cookies 1)))
+ ;; Check if CVS is waiting for a lock.
+ (beginning-of-line 0) ;Move to beginning of last complete line.
+ (when (looking-at "^[ a-z]+: \\(.*waiting for .*lock in \\(.*\\)\\)$")
+ (let ((msg (match-string 1))
+ (lock (match-string 2)))
+ (with-current-buffer cvs-buffer
+ (set (make-local-variable 'cvs-lock-file) lock)
+ ;; display the lock situation in the *cvs* buffer:
+ (ewoc-enter-last
+ cvs-cookies
+ (cvs-create-fileinfo
+ 'MESSAGE "" " "
+ (concat msg
+ (when (file-exists-p lock)
+ (substitute-command-keys
+ "\n\t(type \\[cvs-mode-delete-lock] to delete it)")))
+ :subtype 'TEMP))
+ (pop-to-buffer (current-buffer))
+ (goto-char (point-max))
+ (beep)))))))))
+
+\f
+;;;;
+;;;; The cvs-mode and its associated commands.
+;;;;
+
+(cvs-prefix-define cvs-force-command "" "" '("/F") cvs-qtypedesc-string1)
+(defun-cvs-mode cvs-mode-force-command (arg)
+ "Force the next cvs command to operate on all the selected files.
+By default, cvs commands only operate on files on which the command
+\"makes sense\". This overrides the safety feature on the next cvs command.
+It actually behaves as a toggle. If prefixed by \\[universal-argument] \\[universal-argument],
+the override will persist until the next toggle."
+ (interactive "P")
+ (cvs-prefix-set 'cvs-force-command arg))
+
+(put 'cvs-mode 'mode-class 'special)
+(define-derived-mode cvs-mode nil "CVS"
+ "Mode used for PCL-CVS, a frontend to CVS.
+Full documentation is in the Texinfo file."
+ (setq mode-line-process
+ '("" cvs-force-command cvs-ignore-marks-modif
+ ":" (cvs-branch-prefix
+ ("" cvs-branch-prefix (cvs-secondary-branch-prefix
+ ("->" cvs-secondary-branch-prefix))))
+ " " cvs-mode-line-process))
+ (if buffer-file-name
+ (error "Use M-x cvs-quickdir to get a *cvs* buffer"))
+ (buffer-disable-undo)
+ ;;(set (make-local-variable 'goal-column) cvs-cursor-column)
+ (set (make-local-variable 'revert-buffer-function) 'cvs-mode-revert-buffer)
+ (setq truncate-lines t)
+ (cvs-prefix-make-local 'cvs-branch-prefix)
+ (cvs-prefix-make-local 'cvs-secondary-branch-prefix)
+ (cvs-prefix-make-local 'cvs-force-command)
+ (cvs-prefix-make-local 'cvs-ignore-marks-modif)
+ (make-local-variable 'cvs-mode-line-process)
+ (make-local-variable 'cvs-temp-buffers))
+
+
+(defun cvs-buffer-p (&optional buffer)
+ "Return whether the (by default current) BUFFER is a `cvs-mode' buffer."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (and (eq major-mode 'cvs-mode))))
+
+(defun cvs-buffer-check ()
+ "Check that the current buffer follows cvs-buffer's conventions."
+ (let ((buf (current-buffer))
+ (check 'none))
+ (or (and (setq check 'collection)
+ (eq (ewoc-buffer cvs-cookies) buf)
+ (setq check 'cvs-temp-buffer)
+ (or (null cvs-temp-buffer)
+ (null (buffer-live-p cvs-temp-buffer))
+ (and (eq (with-current-buffer cvs-temp-buffer cvs-buffer) buf)
+ (equal (with-current-buffer cvs-temp-buffer
+ default-directory)
+ default-directory)))
+ t)
+ (error "Inconsistent %s in buffer %s" check (buffer-name buf)))))
+
+
+(defun cvs-mode-quit ()
+ "Quit PCL-CVS, killing the *cvs* buffer."
+ (interactive)
+ (and (y-or-n-p "Quit pcl-cvs? ") (kill-buffer (current-buffer))))
+
+;; Give help....
+
+(defun cvs-help ()
+ "Display help for various PCL-CVS commands."
+ (interactive)
+ (if (eq last-command 'cvs-help)
+ (describe-function 'cvs-mode) ; would need minor-mode for log-edit-mode
+ (message "%s"
+ (substitute-command-keys
+ "`\\[cvs-help]':help `\\[cvs-mode-add]':add `\\[cvs-mode-commit]':commit \
+`\\[cvs-mode-diff-map]':diff* `\\[cvs-mode-log]':log \
+`\\[cvs-mode-remove]':remove `\\[cvs-mode-status]':status \
+`\\[cvs-mode-undo]':undo"))))
+
+;; Move around in the buffer
+
+(defun cvs-move-to-goal-column ()
+ (let* ((eol (line-end-position))
+ (fpos (next-single-property-change (point) 'cvs-goal-column nil eol)))
+ (when (< fpos eol)
+ (goto-char fpos))))
+
+(defun-cvs-mode cvs-mode-previous-line (arg)
+ "Go to the previous line.
+If a prefix argument is given, move by that many lines."
+ (interactive "p")
+ (ewoc-goto-prev cvs-cookies arg)
+ (cvs-move-to-goal-column))
+
+(defun-cvs-mode cvs-mode-next-line (arg)
+ "Go to the next line.
+If a prefix argument is given, move by that many lines."
+ (interactive "p")
+ (ewoc-goto-next cvs-cookies arg)
+ (cvs-move-to-goal-column))
+
+;;;;
+;;;; Mark handling
+;;;;
+
+(defun-cvs-mode cvs-mode-mark (&optional arg)
+ "Mark the fileinfo on the current line.
+If the fileinfo is a directory, all the contents of that directory are
+marked instead. A directory can never be marked."
+ (interactive)
+ (let* ((tin (ewoc-locate cvs-cookies))
+ (fi (ewoc-data tin)))
+ (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
+ ;; it's a directory: let's mark all files inside
+ (ewoc-map
+ (lambda (f dir)
+ (when (cvs-dir-member-p f dir)
+ (setf (cvs-fileinfo->marked f)
+ (not (if (eq arg 'toggle) (cvs-fileinfo->marked f) arg)))
+ t)) ;Tell cookie to redisplay this cookie.
+ cvs-cookies
+ (cvs-fileinfo->dir fi))
+ ;; not a directory: just do the obvious
+ (setf (cvs-fileinfo->marked fi)
+ (not (if (eq arg 'toggle) (cvs-fileinfo->marked fi) arg)))
+ (ewoc-invalidate cvs-cookies tin)
+ (cvs-mode-next-line 1))))
+
+(defalias 'cvs-mouse-toggle-mark 'cvs-mode-toggle-mark)
+(defun cvs-mode-toggle-mark (e)
+ "Toggle the mark of the entry at point."
+ (interactive (list last-input-event))
+ (save-excursion
+ (posn-set-point (event-end e))
+ (cvs-mode-mark 'toggle)))
+
+(defun-cvs-mode cvs-mode-unmark ()
+ "Unmark the fileinfo on the current line."
+ (interactive)
+ (cvs-mode-mark t))
+
+(defun-cvs-mode cvs-mode-mark-all-files ()
+ "Mark all files."
+ (interactive)
+ (ewoc-map (lambda (cookie)
+ (unless (eq (cvs-fileinfo->type cookie) 'DIRCHANGE)
+ (setf (cvs-fileinfo->marked cookie) t)))
+ cvs-cookies))
+
+(defun-cvs-mode (cvs-mode-mark-on-state . SIMPLE) (state)
+ "Mark all files in state STATE."
+ (interactive
+ (list
+ (let ((default
+ (condition-case nil
+ (downcase
+ (symbol-name
+ (cvs-fileinfo->type
+ (cvs-mode-marked nil nil :read-only t :one t :noquery t))))
+ (error nil))))
+ (intern
+ (upcase
+ (completing-read
+ (concat
+ "Mark files in state" (if default (concat " [" default "]")) ": ")
+ (mapcar (lambda (x)
+ (list (downcase (symbol-name (car x)))))
+ cvs-states)
+ nil t nil nil default))))))
+ (ewoc-map (lambda (fi)
+ (when (eq (cvs-fileinfo->type fi) state)
+ (setf (cvs-fileinfo->marked fi) t)))
+ cvs-cookies))
+
+(defun-cvs-mode cvs-mode-mark-matching-files (regex)
+ "Mark all files matching REGEX."
+ (interactive "sMark files matching: ")
+ (ewoc-map (lambda (cookie)
+ (when (and (not (eq (cvs-fileinfo->type cookie) 'DIRCHANGE))
+ (string-match regex (cvs-fileinfo->file cookie)))
+ (setf (cvs-fileinfo->marked cookie) t)))
+ cvs-cookies))
+
+(defun-cvs-mode cvs-mode-unmark-all-files ()
+ "Unmark all files.
+Directories are also unmarked, but that doesn't matter, since
+they should always be unmarked."
+ (interactive)
+ (ewoc-map (lambda (cookie)
+ (setf (cvs-fileinfo->marked cookie) nil)
+ t)
+ cvs-cookies))
+
+(defun-cvs-mode cvs-mode-unmark-up ()
+ "Unmark the file on the previous line."
+ (interactive)
+ (let ((tin (ewoc-goto-prev cvs-cookies 1)))
+ (when tin
+ (setf (cvs-fileinfo->marked (ewoc-data tin)) nil)
+ (ewoc-invalidate cvs-cookies tin)))
+ (cvs-move-to-goal-column))
+
+(defconst cvs-ignore-marks-alternatives
+ '(("toggle-marks" . "/TM")
+ ("force-marks" . "/FM")
+ ("ignore-marks" . "/IM")))
+
+(cvs-prefix-define cvs-ignore-marks-modif
+ "Prefix to decide whether to ignore marks or not."
+ "active"
+ (mapcar 'cdr cvs-ignore-marks-alternatives)
+ (cvs-qtypedesc-create
+ (lambda (str) (cdr (assoc str cvs-ignore-marks-alternatives)))
+ (lambda (obj) (car (rassoc obj cvs-ignore-marks-alternatives)))
+ (lambda () cvs-ignore-marks-alternatives)
+ nil t))
+
+(defun-cvs-mode cvs-mode-toggle-marks (arg)
+ "Toggle whether the next CVS command uses marks.
+See `cvs-prefix-set' for further description of the behavior.
+\\[universal-argument] 1 selects `force-marks',
+\\[universal-argument] 2 selects `ignore-marks',
+\\[universal-argument] 3 selects `toggle-marks'."
+ (interactive "P")
+ (cvs-prefix-set 'cvs-ignore-marks-modif arg))
+
+(defun cvs-ignore-marks-p (cmd &optional read-only)
+ (let ((default (if (member cmd cvs-invert-ignore-marks)
+ (not cvs-default-ignore-marks)
+ cvs-default-ignore-marks))
+ (modif (cvs-prefix-get 'cvs-ignore-marks-modif read-only)))
+ (cond
+ ((equal modif "/IM") t)
+ ((equal modif "/TM") (not default))
+ ((equal modif "/FM") nil)
+ (t default))))
+
+(defun cvs-mode-mark-get-modif (cmd)
+ (if (cvs-ignore-marks-p cmd 'read-only) "/IM" "/FM"))
+
+(defun cvs-get-marked (&optional ignore-marks ignore-contents)
+ "Return a list of all selected fileinfos.
+If there are any marked tins, and IGNORE-MARKS is nil, return them.
+Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is
+nil, return all files in it, else return just the directory.
+Otherwise return (a list containing) the file the cursor points to, or
+an empty list if it doesn't point to a file at all."
+ (let ((fis nil))
+ (dolist (fi (if (and (boundp 'cvs-minor-current-files)
+ (consp cvs-minor-current-files))
+ (mapcar
+ (lambda (f)
+ (if (cvs-fileinfo-p f) f
+ (let ((f (file-relative-name f)))
+ (if (file-directory-p f)
+ (cvs-create-fileinfo
+ 'DIRCHANGE (file-name-as-directory f) "." "")
+ (let ((dir (file-name-directory f))
+ (file (file-name-nondirectory f)))
+ (cvs-create-fileinfo
+ 'UNKNOWN (or dir "") file ""))))))
+ cvs-minor-current-files)
+ (or (and (not ignore-marks)
+ (ewoc-collect cvs-cookies 'cvs-fileinfo->marked))
+ (list (ewoc-data (ewoc-locate cvs-cookies))))))
+
+ (if (or ignore-contents (not (eq (cvs-fileinfo->type fi) 'DIRCHANGE)))
+ (push fi fis)
+ ;; If a directory is selected, return members, if any.
+ (setq fis
+ (append (ewoc-collect
+ cvs-cookies 'cvs-dir-member-p (cvs-fileinfo->dir fi))
+ fis))))
+ (nreverse fis)))
+
+(defun* cvs-mode-marked (filter &optional cmd
+ &key read-only one file noquery)
+ "Get the list of marked FIS.
+CMD is used to determine whether to use the marks or not.
+Only files for which FILTER is applicable are returned.
+If READ-ONLY is non-nil, the current toggling is left intact.
+If ONE is non-nil, marks are ignored and a single FI is returned.
+If FILE is non-nil, directory entries won't be selected."
+ (unless cmd (setq cmd (symbol-name filter)))
+ (let* ((fis (cvs-get-marked (or one (cvs-ignore-marks-p cmd read-only))
+ (and (not file)
+ (cvs-applicable-p 'DIRCHANGE filter))))
+ (force (cvs-prefix-get 'cvs-force-command))
+ (fis (car (cvs-partition
+ (lambda (fi) (cvs-applicable-p fi (and (not force) filter)))
+ fis))))
+ (when (and (or (null fis) (and one (cdr fis))) (not noquery))
+ (message (if (null fis)
+ "`%s' is not applicable to any of the selected files."
+ "`%s' is only applicable to a single file.") cmd)
+ (sit-for 1)
+ (setq fis (list (cvs-insert-file
+ (read-file-name (format "File to %s: " cmd))))))
+ (if one (car fis) fis)))
+
+(defun cvs-enabledp (filter)
+ "Determine whether FILTER applies to at least one of the selected files."
+ (ignore-errors (cvs-mode-marked filter nil :read-only t :noquery t)))
+
+(defun cvs-mode-files (&rest -cvs-mode-files-args)
+ (cvs-mode!
+ (lambda ()
+ (mapcar 'cvs-fileinfo->full-name
+ (apply 'cvs-mode-marked -cvs-mode-files-args)))))
+
+;;
+;; Interface between Log-Edit and PCL-CVS
+;;
+
+(defun cvs-mode-commit-setup ()
+ "Run `cvs-mode-commit' with setup."
+ (interactive)
+ (cvs-mode-commit 'force))
+
+(defcustom cvs-mode-commit-hook nil
+ "Hook run after setting up the commit buffer."
+ :type 'hook
+ :options '(cvs-mode-diff)
+ :group 'pcl-cvs)
+
+(defun cvs-mode-commit (setup)
+ "Check in all marked files, or the current file.
+The user will be asked for a log message in a buffer.
+The buffer's mode and name is determined by the \"message\" setting
+ of `cvs-buffer-name-alist'.
+The POSTPROC specified there (typically `log-edit') is then called,
+ passing it the SETUP argument."
+ (interactive "P")
+ ;; It seems that the save-excursion that happens if I use the better
+ ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which
+ ;; end up being rather annoying (like log-edit-mode's message being
+ ;; displayed in the wrong minibuffer).
+ (cvs-mode!)
+ (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup))
+ (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist)))
+ 'log-edit)))
+ (funcall setupfun 'cvs-do-commit setup
+ '((log-edit-listfun . cvs-commit-filelist)
+ (log-edit-diff-function . cvs-mode-diff)) buf)
+ (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap)
+ (run-hooks 'cvs-mode-commit-hook)))
+
+(defun cvs-commit-minor-wrap (buf f)
+ (let ((cvs-ignore-marks-modif (cvs-mode-mark-get-modif "commit")))
+ (funcall f)))
+
+(defun cvs-commit-filelist ()
+ (cvs-mode-files 'commit nil :read-only t :file t :noquery t))
+
+(defun cvs-do-commit (flags)
+ "Do the actual commit, using the current buffer as the log message."
+ (interactive (list (cvs-flags-query 'cvs-commit-flags "cvs commit flags")))
+ (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
+ (cvs-mode!)
+ ;;(pop-to-buffer cvs-buffer)
+ (cvs-mode-do "commit" (list* "-m" msg flags) 'commit)))
+
+
+;;;; Editing existing commit log messages.
+
+(defun cvs-edit-log-text-at-point ()
+ (save-excursion
+ (end-of-line)
+ (when (re-search-backward "^revision " nil t)
+ (forward-line 1)
+ (if (looking-at "date:") (forward-line 1))
+ (if (looking-at "branches:") (forward-line 1))
+ (buffer-substring
+ (point)
+ (if (re-search-forward
+ "^\\(-\\{28\\}\\|=\\{77\\}\\|revision [.0-9]+\\)$"
+ nil t)
+ (match-beginning 0)
+ (point))))))
+
+(defvar cvs-edit-log-revision)
+(defvar cvs-edit-log-files) (put 'cvs-edit-log-files 'permanent-local t)
+(defun cvs-mode-edit-log (file rev &optional text)
+ "Edit the log message at point.
+This is best called from a `log-view-mode' buffer."
+ (interactive
+ (list
+ (or (cvs-mode! (lambda ()
+ (car (cvs-mode-files nil nil
+ :read-only t :file t :noquery t))))
+ (read-string "File name: "))
+ (or (cvs-mode! (lambda () (cvs-prefix-get 'cvs-branch-prefix)))
+ (read-string "Revision to edit: "))
+ (cvs-edit-log-text-at-point)))
+ ;; It seems that the save-excursion that happens if I use the better
+ ;; form of `(cvs-mode! (lambda ...))' screws up a couple things which
+ ;; end up being rather annoying (like log-edit-mode's message being
+ ;; displayed in the wrong minibuffer).
+ (cvs-mode!)
+ (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup))
+ (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist)))
+ 'log-edit)))
+ (with-current-buffer buf
+ ;; Set the filename before, so log-edit can correctly setup its
+ ;; log-edit-initial-files variable.
+ (set (make-local-variable 'cvs-edit-log-files) (list file)))
+ (funcall setupfun 'cvs-do-edit-log nil
+ '((log-edit-listfun . cvs-edit-log-filelist)
+ (log-edit-diff-function . cvs-mode-diff))
+ buf)
+ (when text (erase-buffer) (insert text))
+ (set (make-local-variable 'cvs-edit-log-revision) rev)
+ (set (make-local-variable 'cvs-minor-wrap-function)
+ 'cvs-edit-log-minor-wrap)
+ ;; (run-hooks 'cvs-mode-commit-hook)
+ ))
+
+(defun cvs-edit-log-minor-wrap (buf f)
+ (let ((cvs-branch-prefix (with-current-buffer buf cvs-edit-log-revision))
+ (cvs-minor-current-files
+ (with-current-buffer buf cvs-edit-log-files))
+ ;; FIXME: I need to force because the fileinfos are UNKNOWN
+ (cvs-force-command "/F"))
+ (funcall f)))
+
+(defun cvs-edit-log-filelist ()
+ (if cvs-minor-wrap-function
+ (cvs-mode-files nil nil :read-only t :file t :noquery t)
+ cvs-edit-log-files))
+
+(defun cvs-do-edit-log (rev)
+ "Do the actual commit, using the current buffer as the log message."
+ (interactive (list cvs-edit-log-revision))
+ (let ((msg (buffer-substring-no-properties (point-min) (point-max))))
+ (cvs-mode!
+ (lambda ()
+ (cvs-mode-do "admin" (list (concat "-m" rev ":" msg)) nil)))))
+
+
+;;;;
+;;;; CVS Mode commands
+;;;;
+
+(defun-cvs-mode (cvs-mode-insert . NOARGS) (file)
+ "Insert an entry for a specific file into the current listing.
+This is typically used if the file is up-to-date (or has been added
+outside of PCL-CVS) and one wants to do some operation on it."
+ (interactive
+ (list (read-file-name
+ "File to insert: "
+ ;; Can't use ignore-errors here because interactive
+ ;; specs aren't byte-compiled.
+ (condition-case nil
+ (file-name-as-directory
+ (expand-file-name
+ (cvs-fileinfo->dir
+ (cvs-mode-marked nil nil :read-only t :one t :noquery t))))
+ (error nil)))))
+ (cvs-insert-file file))
+
+(defun cvs-insert-file (file)
+ "Insert FILE (and its contents if it's a dir) and return its FI."
+ (let ((file (file-relative-name (directory-file-name file))) last)
+ (dolist (fi (cvs-fileinfo-from-entries file))
+ (setq last (cvs-addto-collection cvs-cookies fi last)))
+ ;; There should have been at least one entry.
+ (goto-char (ewoc-location last))
+ (ewoc-data last)))
+
+(defun cvs-mark-fis-dead (fis)
+ ;; Helper function, introduced because of the need for macro-expansion.
+ (dolist (fi fis)
+ (setf (cvs-fileinfo->type fi) 'DEAD)))
+
+(defun-cvs-mode (cvs-mode-add . SIMPLE) (flags)
+ "Add marked files to the cvs repository.
+With prefix argument, prompt for cvs flags."
+ (interactive (list (cvs-flags-query 'cvs-add-flags "cvs add flags")))
+ (let ((fis (cvs-mode-marked 'add))
+ (needdesc nil) (dirs nil))
+ ;; find directories and look for fis needing a description
+ (dolist (fi fis)
+ (cond
+ ((file-directory-p (cvs-fileinfo->full-name fi)) (push fi dirs))
+ ((eq (cvs-fileinfo->type fi) 'UNKNOWN) (setq needdesc t))))
+ ;; prompt for description if necessary
+ (let* ((msg (if (and needdesc
+ (or current-prefix-arg (not cvs-add-default-message)))
+ (read-from-minibuffer "Enter description: ")
+ (or cvs-add-default-message "")))
+ (flags (list* "-m" msg flags))
+ (postproc
+ ;; setup postprocessing for the directory entries
+ (when dirs
+ `((cvs-run-process (list "-n" "update")
+ ',dirs
+ '(cvs-parse-process t))
+ (cvs-mark-fis-dead ',dirs)))))
+ (cvs-mode-run "add" flags fis :postproc postproc))))
+
+(defun-cvs-mode (cvs-mode-diff . DOUBLE) (flags)
+ "Diff the selected files against the repository.
+This command compares the files in your working area against the
+revision which they are based upon."
+ (interactive
+ (list (cvs-add-branch-prefix
+ (cvs-add-secondary-branch-prefix
+ (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))))
+ (cvs-mode-do "diff" flags 'diff
+ :show t)) ;; :ignore-exit t
+
+(defun-cvs-mode (cvs-mode-diff-head . SIMPLE) (flags)
+ "Diff the selected files against the head of the current branch.
+See ``cvs-mode-diff'' for more info."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
+ (cvs-mode-diff-1 (cons "-rHEAD" flags)))
+
+(defun-cvs-mode (cvs-mode-diff-repository . SIMPLE) (flags)
+ "Diff the files for changes in the repository since last co/update/commit.
+See ``cvs-mode-diff'' for more info."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
+ (cvs-mode-diff-1 (cons "-rBASE" (cons "-rHEAD" flags))))
+
+(defun-cvs-mode (cvs-mode-diff-yesterday . SIMPLE) (flags)
+ "Diff the selected files against yesterday's head of the current branch.
+See ``cvs-mode-diff'' for more info."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
+ (cvs-mode-diff-1 (cons "-Dyesterday" flags)))
+
+(defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE) (flags)
+ "Diff the selected files against the head of the vendor branch.
+See ``cvs-mode-diff'' for more info."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
+ (cvs-mode-diff-1 (cons (concat "-r" cvs-vendor-branch) flags)))
+
+;; sadly, this is not provided by cvs, so we have to roll our own
+(defun-cvs-mode (cvs-mode-diff-backup . SIMPLE) (flags)
+ "Diff the files against the backup file.
+This command can be used on files that are marked with \"Merged\"
+or \"Conflict\" in the *cvs* buffer."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "diff flags")))
+ (unless (listp flags) (error "flags should be a list of strings"))
+ (save-some-buffers)
+ (let* ((marked (cvs-get-marked (cvs-ignore-marks-p "diff")))
+ (fis (car (cvs-partition 'cvs-fileinfo->backup-file marked))))
+ (unless (consp fis)
+ (error "No files with a backup file selected!"))
+ ;; let's extract some info into the environment for `buffer-name'
+ (let* ((dir (cvs-fileinfo->dir (car fis)))
+ (file (cvs-fileinfo->file (car fis))))
+ (set-buffer (cvs-temp-buffer "diff")))
+ (message "cvs diff backup...")
+ (cvs-execute-single-file-list fis 'cvs-diff-backup-extractor
+ cvs-diff-program flags))
+ (message "cvs diff backup... Done."))
+
+(defun cvs-diff-backup-extractor (fileinfo)
+ "Return the filename and the name of the backup file as a list.
+Signal an error if there is no backup file."
+ (let ((backup-file (cvs-fileinfo->backup-file fileinfo)))
+ (unless backup-file
+ (error "%s has no backup file" (cvs-fileinfo->full-name fileinfo)))
+ (list backup-file (cvs-fileinfo->full-name fileinfo))))
+
+;;
+;; Emerge support
+;;
+(defun cvs-emerge-diff (b1 b2) (emerge-buffers b1 b2 b1))
+(defun cvs-emerge-merge (b1 b2 base out)
+ (emerge-buffers-with-ancestor b1 b2 base (find-file-noselect out)))
+
+;;
+;; Ediff support
+;;
+
+(defvar ediff-after-quit-destination-buffer)
+(defvar ediff-after-quit-hook-internal)
+(defvar cvs-transient-buffers)
+(defun cvs-ediff-startup-hook ()
+ (add-hook 'ediff-after-quit-hook-internal
+ `(lambda ()
+ (cvs-ediff-exit-hook
+ ',ediff-after-quit-destination-buffer ',cvs-transient-buffers))
+ nil 'local))
+
+(defun cvs-ediff-exit-hook (cvs-buf tmp-bufs)
+ ;; kill the temp buffers (and their associated windows)
+ (dolist (tb tmp-bufs)
+ (when (and tb (buffer-live-p tb) (not (buffer-modified-p tb)))
+ (let ((win (get-buffer-window tb t)))
+ (kill-buffer tb)
+ (when (window-live-p win) (ignore-errors (delete-window win))))))
+ ;; switch back to the *cvs* buffer
+ (when (and cvs-buf (buffer-live-p cvs-buf)
+ (not (get-buffer-window cvs-buf t)))
+ (ignore-errors (switch-to-buffer cvs-buf))))
+
+(defun cvs-ediff-diff (b1 b2)
+ (let ((ediff-after-quit-destination-buffer (current-buffer))
+ (startup-hook '(cvs-ediff-startup-hook)))
+ (ediff-buffers b1 b2 startup-hook 'ediff-revision)))
+
+(defun cvs-ediff-merge (b1 b2 base out)
+ (let ((ediff-after-quit-destination-buffer (current-buffer))
+ (startup-hook '(cvs-ediff-startup-hook)))
+ (ediff-merge-buffers-with-ancestor
+ b1 b2 base startup-hook
+ 'ediff-merge-revisions-with-ancestor
+ out)))
+
+;;
+;; Interactive merge/diff support.
+;;
+
+(defun cvs-retrieve-revision (fileinfo rev)
+ "Retrieve the given REVision of the file in FILEINFO into a new buffer."
+ (let* ((file (cvs-fileinfo->full-name fileinfo))
+ (buffile (concat file "." rev)))
+ (or (find-buffer-visiting buffile)
+ (with-current-buffer (create-file-buffer buffile)
+ (message "Retrieving revision %s..." rev)
+ ;; Discard stderr output to work around the CVS+SSH+libc
+ ;; problem when stdout and stderr are the same.
+ (let ((res
+ (let ((coding-system-for-read 'binary))
+ (apply 'process-file cvs-program nil '(t nil) nil
+ "-q" "update" "-p"
+ ;; If `rev' is HEAD, don't pass it at all:
+ ;; the default behavior is to get the head
+ ;; of the current branch whereas "-r HEAD"
+ ;; stupidly gives you the head of the trunk.
+ (append (unless (equal rev "HEAD") (list "-r" rev))
+ (list file))))))
+ (when (and res (not (and (equal 0 res))))
+ (error "Something went wrong retrieving revision %s: %s" rev res))
+ ;; Figure out the encoding used and decode the byte-sequence
+ ;; into a sequence of chars.
+ (decode-coding-inserted-region
+ (point-min) (point-max) file t nil nil t)
+ ;; Set buffer-file-coding-system.
+ (after-insert-file-set-coding (buffer-size) t)
+ (set-buffer-modified-p nil)
+ (let ((buffer-file-name (expand-file-name file)))
+ (after-find-file))
+ (toggle-read-only 1)
+ (message "Retrieving revision %s... Done" rev)
+ (current-buffer))))))
+
+;; FIXME: The user should be able to specify ancestor/head/backup and we should
+;; provide sensible defaults when merge info is unavailable (rather than rely
+;; on smerge-ediff). Also provide sane defaults for need-merge files.
+(defun-cvs-mode cvs-mode-imerge ()
+ "Merge interactively appropriate revisions of the selected file."
+ (interactive)
+ (let ((fi (cvs-mode-marked 'merge nil :one t :file t)))
+ (let ((merge (cvs-fileinfo->merge fi))
+ (file (cvs-fileinfo->full-name fi))
+ (backup-file (cvs-fileinfo->backup-file fi)))
+ (if (not (and merge backup-file))
+ (let ((buf (find-file-noselect file)))
+ (message "Missing merge info or backup file, using VC.")
+ (with-current-buffer buf
+ (smerge-ediff)))
+ (let* ((ancestor-buf (cvs-retrieve-revision fi (car merge)))
+ (head-buf (cvs-retrieve-revision fi (cdr merge)))
+ (backup-buf (let ((auto-mode-alist nil))
+ (find-file-noselect backup-file)))
+ ;; this binding is used by cvs-ediff-startup-hook
+ (cvs-transient-buffers (list ancestor-buf backup-buf head-buf)))
+ (with-current-buffer backup-buf
+ (let ((buffer-file-name (expand-file-name file)))
+ (after-find-file)))
+ (funcall (cdr cvs-idiff-imerge-handlers)
+ backup-buf head-buf ancestor-buf file))))))
+
+(cvs-flags-define cvs-idiff-version
+ (list "BASE" cvs-vendor-branch cvs-vendor-branch "BASE" "BASE")
+ "version: " cvs-qtypedesc-tag)
+
+(defun-cvs-mode (cvs-mode-idiff . NOARGS) (&optional rev1 rev2)
+ "Diff interactively current file to revisions."
+ (interactive
+ (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix))
+ (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix))))
+ (list (or rev1 (cvs-flags-query 'cvs-idiff-version))
+ rev2)))
+ (let ((fi (cvs-mode-marked 'diff "idiff" :one t :file t)))
+ (let* ((file (cvs-fileinfo->full-name fi))
+ (rev1-buf (cvs-retrieve-revision fi (or rev1 "BASE")))
+ (rev2-buf (if rev2 (cvs-retrieve-revision fi rev2)))
+ ;; this binding is used by cvs-ediff-startup-hook
+ (cvs-transient-buffers (list rev1-buf rev2-buf)))
+ (funcall (car cvs-idiff-imerge-handlers)
+ rev1-buf (or rev2-buf (find-file-noselect file))))))
+
+(defun-cvs-mode (cvs-mode-idiff-other . NOARGS) ()
+ "Diff interactively current file to revisions."
+ (interactive)
+ (let* ((rev1 (cvs-prefix-get 'cvs-branch-prefix))
+ (rev2 (and rev1 (cvs-prefix-get 'cvs-secondary-branch-prefix)))
+ (fis (cvs-mode-marked 'diff "idiff" :file t)))
+ (when (> (length fis) 2)
+ (error "idiff-other cannot be applied to more than 2 files at a time"))
+ (let* ((fi1 (car fis))
+ (rev1-buf (if rev1 (cvs-retrieve-revision fi1 rev1)
+ (find-file-noselect (cvs-fileinfo->full-name fi1))))
+ rev2-buf)
+ (if (cdr fis)
+ (let ((fi2 (nth 1 fis)))
+ (setq rev2-buf
+ (if rev2 (cvs-retrieve-revision fi2 rev2)
+ (find-file-noselect (cvs-fileinfo->full-name fi2)))))
+ (error "idiff-other doesn't know what other file/buffer to use"))
+ (let* (;; this binding is used by cvs-ediff-startup-hook
+ (cvs-transient-buffers (list rev1-buf rev2-buf)))
+ (funcall (car cvs-idiff-imerge-handlers)
+ rev1-buf rev2-buf)))))
+
+
+(defun cvs-is-within-p (fis dir)
+ "Non-nil if buffer is inside one of FIS (in DIR)."
+ (when (stringp buffer-file-name)
+ (setq buffer-file-name (expand-file-name buffer-file-name))
+ (let (ret)
+ (dolist (fi (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." ""))))
+ (when (cvs-string-prefix-p
+ (expand-file-name (cvs-fileinfo->full-name fi) dir)
+ buffer-file-name)
+ (setq ret t)))
+ ret)))
+
+(defun* cvs-mode-run (cmd flags fis
+ &key (buf (cvs-temp-buffer))
+ dont-change-disc cvsargs postproc)
+ "Generic cvs-mode-<foo> function.
+Executes `cvs CVSARGS CMD FLAGS FIS'.
+BUF is the buffer to be used for cvs' output.
+DONT-CHANGE-DISC non-nil indicates that the command will not change the
+ contents of files. This is only used by the parser.
+POSTPROC is a list of expressions to be evaluated at the very end (after
+ parsing if applicable). It will be prepended with `progn' if necessary."
+ (let ((def-dir default-directory))
+ ;; Save the relevant buffers
+ (save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir))))
+ (unless (listp flags) (error "flags should be a list of strings"))
+ ;; Some w32 versions of CVS don't like an explicit . too much.
+ (when (and (car fis) (null (cdr fis))
+ (eq (cvs-fileinfo->type (car fis)) 'DIRCHANGE)
+ ;; (equal (cvs-fileinfo->file (car fis)) ".")
+ (equal (cvs-fileinfo->dir (car fis)) ""))
+ (setq fis nil))
+ (let* ((single-dir (or (not (listp cvs-execute-single-dir))
+ (member cmd cvs-execute-single-dir)))
+ (parse (member cmd cvs-parse-known-commands))
+ (args (append cvsargs (list cmd) flags))
+ (after-mode (nth 2 (cdr (assoc cmd cvs-buffer-name-alist)))))
+ (cvs-cleanup-collection cvs-cookies ;cleanup remaining messages
+ (eq cvs-auto-remove-handled 'delayed) nil t)
+ (when (fboundp after-mode)
+ (setq postproc (append postproc `((,after-mode)))))
+ (when parse
+ (let ((old-fis
+ (when (member cmd '("status" "update")) ;FIXME: Yuck!!
+ ;; absence of `cvs update' output has a specific meaning.
+ (or fis (list (cvs-create-fileinfo 'DIRCHANGE "" "." ""))))))
+ (push `(cvs-parse-process ',dont-change-disc nil ',old-fis) postproc)))
+ (setq postproc (if (cdr postproc) (cons 'progn postproc) (car postproc)))
+ (with-current-buffer buf
+ (let ((inhibit-read-only t)) (erase-buffer))
+ (message "Running cvs %s ..." cmd)
+ (cvs-run-process args fis postproc single-dir))))
+
+
+(defun* cvs-mode-do (cmd flags filter
+ &key show dont-change-disc cvsargs postproc)
+ "Generic cvs-mode-<foo> function.
+Executes `cvs CVSARGS CMD FLAGS' on the selected files.
+FILTER is passed to `cvs-applicable-p' to only apply the command to
+ files for which it makes sense.
+SHOW indicates that CMD should be not be run in the default temp buffer and
+ should be shown to the user. The buffer and mode to be used is determined
+ by `cvs-buffer-name-alist'.
+DONT-CHANGE-DISC non-nil indicates that the command will not change the
+ contents of files. This is only used by the parser."
+ (cvs-mode-run cmd flags (cvs-mode-marked filter cmd)
+ :buf (cvs-temp-buffer (when show cmd))
+ :dont-change-disc dont-change-disc
+ :cvsargs cvsargs
+ :postproc postproc))
+
+(defun-cvs-mode (cvs-mode-status . SIMPLE) (flags)
+ "Show cvs status for all marked files.
+With prefix argument, prompt for cvs flags."
+ (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags")))
+ (cvs-mode-do "status" flags nil :dont-change-disc t :show t
+ :postproc (when (eq cvs-auto-remove-handled 'status)
+ `((with-current-buffer ,(current-buffer)
+ (cvs-mode-remove-handled))))))
+
+(defun-cvs-mode (cvs-mode-tree . SIMPLE) (flags)
+ "Call cvstree using the file under the point as a keyfile."
+ (interactive (list (cvs-flags-query 'cvs-status-flags "cvs status flags")))
+ (cvs-mode-run "status" (cons "-v" flags) (cvs-mode-marked nil "status")
+ :buf (cvs-temp-buffer "tree")
+ :dont-change-disc t
+ :postproc '((cvs-status-cvstrees))))
+
+;; cvs log
+
+(defun-cvs-mode (cvs-mode-log . NOARGS) (flags)
+ "Display the cvs log of all selected files.
+With prefix argument, prompt for cvs flags."
+ (interactive (list (cvs-add-branch-prefix
+ (cvs-flags-query 'cvs-log-flags "cvs log flags"))))
+ (cvs-mode-do "log" flags nil :show t))
+
+
+(defun-cvs-mode (cvs-mode-update . NOARGS) (flags)
+ "Update all marked files.
+With a prefix argument, prompt for cvs flags."
+ (interactive
+ (list (cvs-add-branch-prefix
+ (cvs-add-secondary-branch-prefix
+ (cvs-flags-query 'cvs-update-flags "cvs update flags")
+ "-j") "-j")))
+ (cvs-mode-do "update" flags 'update))
+
+
+(defun-cvs-mode (cvs-mode-examine . NOARGS) (flags)
+ "Re-examine all marked files.
+With a prefix argument, prompt for cvs flags."
+ (interactive
+ (list (cvs-add-branch-prefix
+ (cvs-add-secondary-branch-prefix
+ (cvs-flags-query 'cvs-update-flags "cvs -n update flags")
+ "-j") "-j")))
+ (cvs-mode-do "update" flags nil :cvsargs '("-n") :dont-change-disc t))
+
+
+(defun-cvs-mode cvs-mode-ignore (&optional pattern)
+ "Arrange so that CVS ignores the selected files.
+This command ignores files that are not flagged as `Unknown'."
+ (interactive)
+ (dolist (fi (cvs-mode-marked 'ignore))
+ (cvs-append-to-ignore (cvs-fileinfo->dir fi) (cvs-fileinfo->file fi)
+ (eq (cvs-fileinfo->subtype fi) 'NEW-DIR))
+ (setf (cvs-fileinfo->type fi) 'DEAD))
+ (cvs-cleanup-collection cvs-cookies nil nil nil))
+
+(declare-function vc-editable-p "vc" (file))
+(declare-function vc-checkout "vc" (file &optional writable rev))
+
+(defun cvs-append-to-ignore (dir str &optional old-dir)
+ "Add STR to the .cvsignore file in DIR.
+If OLD-DIR is non-nil, then this is a directory that we don't want
+to hear about anymore."
+ (with-current-buffer
+ (find-file-noselect (expand-file-name ".cvsignore" dir))
+ (when (ignore-errors
+ (and buffer-read-only
+ (eq 'CVS (vc-backend buffer-file-name))
+ (not (vc-editable-p buffer-file-name))))
+ ;; CVSREAD=on special case
+ (vc-checkout buffer-file-name t))
+ (goto-char (point-max))
+ (unless (bolp) (insert "\n"))
+ (insert str (if old-dir "/\n" "\n"))
+ (if cvs-sort-ignore-file (sort-lines nil (point-min) (point-max)))
+ (save-buffer)))
+
+
+(defun cvs-mode-find-file-other-window (e)
+ "Select a buffer containing the file in another window."
+ (interactive (list last-input-event))
+ (cvs-mode-find-file e t))
+
+
+(defun cvs-mode-display-file (e)
+ "Show a buffer containing the file in another window."
+ (interactive (list last-input-event))
+ (cvs-mode-find-file e 'dont-select))
+
+
+(defun cvs-mode-view-file (e)
+ "View the file."
+ (interactive (list last-input-event))
+ (cvs-mode-find-file e nil t))
+
+
+(defun cvs-mode-view-file-other-window (e)
+ "View the file."
+ (interactive (list last-input-event))
+ (cvs-mode-find-file e t t))
+
+
+(defun cvs-find-modif (fi)
+ (with-temp-buffer
+ (process-file cvs-program nil (current-buffer) nil
+ "-f" "diff" (cvs-fileinfo->file fi))
+ (goto-char (point-min))
+ (if (re-search-forward "^\\([0-9]+\\)" nil t)
+ (string-to-number (match-string 1))
+ 1)))
+
+
+(defun cvs-mode-find-file (e &optional other view)
+ "Select a buffer containing the file.
+With a prefix, opens the buffer in an OTHER window."
+ (interactive (list last-input-event current-prefix-arg))
+ ;; If the event moves point, check that it moves it to a valid location.
+ (when (and (/= (point) (progn (posn-set-point (event-end e)) (point)))
+ (not (memq (get-text-property (1- (line-end-position))
+ 'font-lock-face)
+ '(cvs-header cvs-filename))))
+ (error "Not a file name"))
+ (cvs-mode!
+ (lambda (&optional rev)
+ (interactive (list (cvs-prefix-get 'cvs-branch-prefix)))
+ (let* ((cvs-buf (current-buffer))
+ (fi (cvs-mode-marked nil nil :one t)))
+ (if (eq (cvs-fileinfo->type fi) 'DIRCHANGE)
+ (let ((odir default-directory))
+ (setq default-directory
+ (cvs-expand-dir-name (cvs-fileinfo->dir fi)))
+ (cond ((eq other 'dont-select)
+ (display-buffer (find-file-noselect default-directory)))
+ (other (dired-other-window default-directory))
+ (t (dired default-directory)))
+ (set-buffer cvs-buf)
+ (setq default-directory odir))
+ (let ((buf (if rev (cvs-retrieve-revision fi rev)
+ (find-file-noselect (cvs-fileinfo->full-name fi)))))
+ (funcall (cond ((eq other 'dont-select) 'display-buffer)
+ (other
+ (if view 'view-buffer-other-window
+ 'switch-to-buffer-other-window))
+ (t (if view 'view-buffer 'switch-to-buffer)))
+ buf)
+ (when (and cvs-find-file-and-jump (cvs-applicable-p fi 'diff-base))
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (forward-line (1- (cvs-find-modif fi)))))
+ buf))))))
+
+
+(defun-cvs-mode (cvs-mode-undo . SIMPLE) (flags)
+ "Undo local changes to all marked files.
+The file is removed and `cvs update FILE' is run."
+ ;;"With prefix argument, prompt for cvs FLAGS."
+ (interactive (list nil));; (cvs-flags-query 'cvs-undo-flags "undo flags")
+ (if current-prefix-arg (call-interactively 'cvs-mode-revert-to-rev)
+ (let* ((fis (cvs-do-removal 'undo "update" 'all))
+ (removedp (lambda (fi)
+ (or (eq (cvs-fileinfo->type fi) 'REMOVED)
+ (and (eq (cvs-fileinfo->type fi) 'CONFLICT)
+ (eq (cvs-fileinfo->subtype fi) 'REMOVED)))))
+ (fis-split (cvs-partition removedp fis))
+ (fis-removed (car fis-split))
+ (fis-other (cdr fis-split)))
+ (if (null fis-other)
+ (when fis-removed (cvs-mode-run "add" nil fis-removed))
+ (cvs-mode-run "update" flags fis-other
+ :postproc
+ (when fis-removed
+ `((with-current-buffer ,(current-buffer)
+ (cvs-mode-run "add" nil ',fis-removed)))))))))
+
+
+(defun-cvs-mode (cvs-mode-revert-to-rev . NOARGS) (rev)
+ "Revert the selected files to an old revision."
+ (interactive
+ (list (or (cvs-prefix-get 'cvs-branch-prefix)
+ (let ((current-prefix-arg '(4)))
+ (cvs-flags-query 'cvs-idiff-version)))))
+ (let* ((fis (cvs-mode-marked 'revert "revert" :file t))
+ (tag (concat "tmp_pcl_tag_" (make-temp-name "")))
+ (untag `((with-current-buffer ,(current-buffer)
+ (cvs-mode-run "tag" (list "-d" ',tag) ',fis))))
+ (update `((with-current-buffer ,(current-buffer)
+ (cvs-mode-run "update" (list "-j" ',tag "-j" ',rev) ',fis
+ :postproc ',untag)))))
+ (cvs-mode-run "tag" (list tag) fis :postproc update)))
+
+
+(defun-cvs-mode cvs-mode-delete-lock ()
+ "Delete the lock file that CVS is waiting for.
+Note that this can be dangerous. You should only do this
+if you are convinced that the process that created the lock is dead."
+ (interactive)
+ (let* ((default-directory (cvs-expand-dir-name cvs-lock-file))
+ (locks (directory-files default-directory nil cvs-lock-file-regexp)))
+ (cond
+ ((not locks) (error "No lock files found"))
+ ((yes-or-no-p (concat "Really delete locks in " cvs-lock-file "? "))
+ (dolist (lock locks)
+ (cond ((file-directory-p lock) (delete-directory lock))
+ ((file-exists-p lock) (delete-file lock))))))))
+
+
+(defun-cvs-mode cvs-mode-remove-handled ()
+ "Remove all lines that are handled.
+Empty directories are removed."
+ (interactive)
+ (cvs-cleanup-collection cvs-cookies
+ t (or cvs-auto-remove-directories 'handled) t))
+
+
+(defun-cvs-mode cvs-mode-acknowledge ()
+ "Remove all marked files from the buffer."
+ (interactive)
+ (dolist (fi (cvs-get-marked (cvs-ignore-marks-p "acknowledge") t))
+ (setf (cvs-fileinfo->type fi) 'DEAD))
+ (cvs-cleanup-collection cvs-cookies nil nil nil))
+
+(defun cvs-do-removal (filter &optional cmd all)
+ "Remove files.
+Returns a list of FIS that should be `cvs remove'd."
+ (let* ((files (cvs-mode-marked filter cmd :file t :read-only t))
+ (fis (cdr (cvs-partition (lambda (fi)
+ (eq (cvs-fileinfo->type fi) 'UNKNOWN))
+ (cvs-mode-marked filter cmd))))
+ (silent (or (not cvs-confirm-removals)
+ (cvs-every (lambda (fi)
+ (or (not (file-exists-p
+ (cvs-fileinfo->full-name fi)))
+ (cvs-applicable-p fi 'safe-rm)))
+ files)))
+ (tmpbuf (cvs-temp-buffer)))
+ (when (and (not silent) (equal cvs-confirm-removals 'list))
+ (with-current-buffer tmpbuf
+ (let ((inhibit-read-only t))
+ (cvs-insert-strings (mapcar 'cvs-fileinfo->full-name fis))
+ (cvs-pop-to-buffer-same-frame (current-buffer))
+ (shrink-window-if-larger-than-buffer))))
+ (if (not (or silent
+ (unwind-protect
+ (yes-or-no-p
+ (let ((nfiles (length files))
+ (verb (if (eq filter 'undo) "Undo" "Delete")))
+ (if (= 1 nfiles)
+ (format "%s file: \"%s\" ? "
+ verb
+ (cvs-fileinfo->file (car files)))
+ (format "%s %d files? "
+ verb
+ nfiles))))
+ (cvs-bury-buffer tmpbuf cvs-buffer))))
+ (progn (message "Aborting") nil)
+ (dolist (fi files)
+ (let* ((type (cvs-fileinfo->type fi))
+ (file (cvs-fileinfo->full-name fi)))
+ (when (or all (eq type 'UNKNOWN))
+ (when (file-exists-p file) (delete-file file))
+ (unless all (setf (cvs-fileinfo->type fi) 'DEAD) t))))
+ fis)))
+
+(defun-cvs-mode (cvs-mode-remove . SIMPLE) (flags)
+ "Remove all marked files.
+With prefix argument, prompt for cvs flags."
+ (interactive (list (cvs-flags-query 'cvs-remove-flags "cvs remove flags")))
+ (let ((fis (cvs-do-removal 'remove)))
+ (if fis (cvs-mode-run "remove" (cons "-f" flags) fis)
+ (cvs-cleanup-collection cvs-cookies nil nil nil))))
+
+
+(defvar cvs-tag-name "")
+(defun-cvs-mode (cvs-mode-tag . SIMPLE) (tag &optional flags)
+ "Run `cvs tag TAG' on all selected files.
+With prefix argument, prompt for cvs flags.
+By default this can only be used on directories.
+Use \\[cvs-mode-force-command] or change `cvs-force-dir-tag' if you need
+to use it on individual files."
+ (interactive
+ (list (setq cvs-tag-name
+ (cvs-query-read cvs-tag-name "Tag name: " cvs-qtypedesc-tag))
+ (cvs-flags-query 'cvs-tag-flags "tag flags")))
+ (cvs-mode-do "tag" (append flags (list tag))
+ (when cvs-force-dir-tag 'tag)))
+
+(defun-cvs-mode (cvs-mode-untag . SIMPLE) (tag &optional flags)
+ "Run `cvs tag -d TAG' on all selected files.
+With prefix argument, prompt for cvs flags."
+ (interactive
+ (list (setq cvs-tag-name
+ (cvs-query-read cvs-tag-name "Tag to delete: " cvs-qtypedesc-tag))
+ (cvs-flags-query 'cvs-tag-flags "tag flags")))
+ (cvs-mode-do "tag" (append '("-d") flags (list tag))
+ (when cvs-force-dir-tag 'tag)))
+
+
+;; Byte compile files.
+
+(defun-cvs-mode cvs-mode-byte-compile-files ()
+ "Run byte-compile-file on all selected files that end in '.el'."
+ (interactive)
+ (let ((marked (cvs-get-marked (cvs-ignore-marks-p "byte-compile"))))
+ (dolist (fi marked)
+ (let ((filename (cvs-fileinfo->full-name fi)))
+ (when (string-match "\\.el\\'" filename)
+ (byte-compile-file filename))))))
+
+;; ChangeLog support.
+
+(defun-cvs-mode cvs-mode-add-change-log-entry-other-window ()
+ "Add a ChangeLog entry in the ChangeLog of the current directory."
+ (interactive)
+ ;; Require `add-log' explicitly, because if it gets autoloaded when we call
+ ;; add-change-log-entry-other-window below, the
+ ;; add-log-buffer-file-name-function ends up unbound when we leave the `let'.
+ (require 'add-log)
+ (dolist (fi (cvs-mode-marked nil nil))
+ (let* ((default-directory (cvs-expand-dir-name (cvs-fileinfo->dir fi)))
+ (add-log-buffer-file-name-function
+ (lambda ()
+ (let ((file (expand-file-name (cvs-fileinfo->file fi))))
+ (if (file-directory-p file)
+ ;; Be careful to use a directory name, otherwise add-log
+ ;; starts looking for a ChangeLog file in the
+ ;; parent dir.
+ (file-name-as-directory file)
+ file)))))
+ (kill-local-variable 'change-log-default-name)
+ (save-excursion (add-change-log-entry-other-window)))))
+
+;; interactive commands to set optional flags
+
+(defun cvs-mode-set-flags (flag)
+ "Ask for new setting of cvs-FLAG-flags."
+ (interactive
+ (list (completing-read
+ "Which flag: "
+ '("cvs" "diff" "update" "status" "log" "tag" ;"rtag"
+ "commit" "remove" "undo" "checkout")
+ nil t)))
+ (let* ((sym (intern (concat "cvs-" flag "-flags"))))
+ (let ((current-prefix-arg '(16)))
+ (cvs-flags-query sym (concat flag " flags")))))
+
+\f
+;;;;
+;;;; Utilities for the *cvs* buffer
+;;;;
+
+(defun cvs-dir-member-p (fileinfo dir)
+ "Return true if FILEINFO represents a file in directory DIR."
+ (and (not (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE))
+ (cvs-string-prefix-p dir (cvs-fileinfo->dir fileinfo))))
+
+(defun cvs-execute-single-file (fi extractor program constant-args)
+ "Internal function for `cvs-execute-single-file-list'."
+ (let* ((arg-list (funcall extractor fi))
+ (inhibit-read-only t))
+
+ ;; Execute the command unless extractor returned t.
+ (when (listp arg-list)
+ (let* ((args (append constant-args arg-list)))
+
+ (insert (format "=== %s %s\n\n"
+ program (split-string-and-unquote args)))
+
+ ;; FIXME: return the exit status?
+ (apply 'process-file program nil t t args)
+ (goto-char (point-max))))))
+
+;; FIXME: make this run in the background ala cvs-run-process...
+(defun cvs-execute-single-file-list (fis extractor program constant-args)
+ "Run PROGRAM on all elements on FIS.
+CONSTANT-ARGS is a list of strings to pass as arguments to PROGRAM.
+The arguments given to the program will be CONSTANT-ARGS followed by
+the list that EXTRACTOR returns.
+
+EXTRACTOR will be called once for each file on FIS. It is given
+one argument, the cvs-fileinfo. It can return t, which means ignore
+this file, or a list of arguments to send to the program."
+ (dolist (fi fis)
+ (cvs-execute-single-file fi extractor program constant-args)))
+
+\f
+(defun cvs-revert-if-needed (fis)
+ (dolist (fileinfo fis)
+ (let* ((file (cvs-fileinfo->full-name fileinfo))
+ (buffer (find-buffer-visiting file)))
+ ;; For a revert to happen the user must be editing the file...
+ (unless (or (null buffer)
+ (memq (cvs-fileinfo->type fileinfo) '(MESSAGE UNKNOWN))
+ ;; FIXME: check whether revert is really needed.
+ ;; `(verify-visited-file-modtime buffer)' doesn't cut it
+ ;; because it only looks at the time stamp (it ignores
+ ;; read-write changes) which is not changed by `commit'.
+ (buffer-modified-p buffer))
+ (with-current-buffer buffer
+ (ignore-errors
+ (revert-buffer 'ignore-auto 'dont-ask 'preserve-modes)
+ ;; `preserve-modes' avoids changing the (minor) modes. But we
+ ;; do want to reset the mode for VC, so we do it explicitly.
+ (vc-find-file-hook)
+ (when (eq (cvs-fileinfo->type fileinfo) 'CONFLICT)
+ (smerge-start-session))))))))
+
+\f
+(defun cvs-change-cvsroot (newroot)
+ "Change the cvsroot."
+ (interactive "DNew repository: ")
+ (if (or (file-directory-p (expand-file-name "CVSROOT" newroot))
+ (y-or-n-p (concat "Warning: no CVSROOT found inside repository."
+ " Change cvs-cvsroot anyhow? ")))
+ (setq cvs-cvsroot newroot)))
+
+;;;;
+;;;; useful global settings
+;;;;
+
+;;
+;; Hook to allow calling PCL-CVS by visiting the /CVS subdirectory
+;;
+
+;;;###autoload
+(defcustom cvs-dired-action 'cvs-quickdir
+ "The action to be performed when opening a CVS directory.
+Sensible values are `cvs-examine', `cvs-status' and `cvs-quickdir'."
+ :group 'pcl-cvs
+ :type '(choice (const cvs-examine) (const cvs-status) (const cvs-quickdir)))
+
+;;;###autoload
+(defcustom cvs-dired-use-hook '(4)
+ "Whether or not opening a CVS directory should run PCL-CVS.
+A value of nil means never do it.
+ALWAYS means to always do it unless a prefix argument is given to the
+ command that prompted the opening of the directory.
+Anything else means to do it only if the prefix arg is equal to this value."
+ :group 'pcl-cvs
+ :type '(choice (const :tag "Never" nil)
+ (const :tag "Always" always)
+ (const :tag "Prefix" (4))))
+
+;;;###autoload
+(progn (defun cvs-dired-noselect (dir)
+ "Run `cvs-examine' if DIR is a CVS administrative directory.
+The exact behavior is determined also by `cvs-dired-use-hook'."
+ (when (stringp dir)
+ (setq dir (directory-file-name dir))
+ (when (and (string= "CVS" (file-name-nondirectory dir))
+ (file-readable-p (expand-file-name "Entries" dir))
+ cvs-dired-use-hook
+ (if (eq cvs-dired-use-hook 'always)
+ (not current-prefix-arg)
+ (equal current-prefix-arg cvs-dired-use-hook)))
+ (save-excursion
+ (funcall cvs-dired-action (file-name-directory dir) t t))))))
+
+;;
+;; hook into VC
+;;
+
+(add-hook 'vc-post-command-functions 'cvs-vc-command-advice)
+
+(defun cvs-vc-command-advice (command files flags)
+ (when (and (equal command "cvs")
+ (progn
+ (while (and (stringp (car flags))
+ (string-match "\\`-" (car flags)))
+ (pop flags))
+ ;; don't parse output we don't understand.
+ (member (car flags) cvs-parse-known-commands))
+ ;; Don't parse "update -p" output.
+ (not (and (member (car flags) '("update" "checkout"))
+ (let ((found-p nil))
+ (dolist (flag flags found-p)
+ (if (equal flag "-p") (setq found-p t)))))))
+ (save-current-buffer
+ (let ((buffer (current-buffer))
+ (dir default-directory)
+ (cvs-from-vc t))
+ (dolist (cvs-buf (buffer-list))
+ (set-buffer cvs-buf)
+ ;; look for a corresponding pcl-cvs buffer
+ (when (and (eq major-mode 'cvs-mode)
+ (cvs-string-prefix-p default-directory dir))
+ (let ((subdir (substring dir (length default-directory))))
+ (set-buffer buffer)
+ (set (make-local-variable 'cvs-buffer) cvs-buf)
+ ;; `cvs -q add file' produces no useful output :-(
+ (when (and (equal (car flags) "add")
+ (goto-char (point-min))
+ (looking-at ".*to add this file permanently\n\\'"))
+ (dolist (file (if (listp files) files (list files)))
+ (insert "cvs add: scheduling file `"
+ (file-name-nondirectory file)
+ "' for addition\n")))
+ ;; VC never (?) does `cvs -n update' so dcd=nil
+ ;; should probably always be the right choice.
+ (cvs-parse-process nil subdir))))))))
+
+;;
+;; Hook into write-buffer
+;;
+
+(defun cvs-mark-buffer-changed ()
+ (let* ((file (expand-file-name buffer-file-name))
+ (version (and (fboundp 'vc-backend)
+ (eq (vc-backend file) 'CVS)
+ (vc-working-revision file))))
+ (when version
+ (save-excursion
+ (dolist (cvs-buf (buffer-list))
+ (set-buffer cvs-buf)
+ ;; look for a corresponding pcl-cvs buffer
+ (when (and (eq major-mode 'cvs-mode)
+ (cvs-string-prefix-p default-directory file))
+ (let* ((file (substring file (length default-directory)))
+ (fi (cvs-create-fileinfo
+ (if (string= "0" version)
+ 'ADDED 'MODIFIED)
+ (or (file-name-directory file) "")
+ (file-name-nondirectory file)
+ "cvs-mark-buffer-changed")))
+ (cvs-addto-collection cvs-cookies fi))))))))
+
+(add-hook 'after-save-hook 'cvs-mark-buffer-changed)
+
+\f
+(provide 'pcvs)
+
+;; arch-tag: 8e3a7494-0453-4389-9ab3-a557ce9fab61
+;;; pcvs.el ends here
--- /dev/null
+;;; smerge-mode.el --- Minor mode to resolve diff3 conflicts
+
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: tools revision-control merge diff3 cvs conflict
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Provides a lightweight alternative to emerge/ediff.
+;; To use it, simply add to your .emacs the following lines:
+;;
+;; (autoload 'smerge-mode "smerge-mode" nil t)
+;;
+;; you can even have it turned on automatically with the following
+;; piece of code in your .emacs:
+;;
+;; (defun sm-try-smerge ()
+;; (save-excursion
+;; (goto-char (point-min))
+;; (when (re-search-forward "^<<<<<<< " nil t)
+;; (smerge-mode 1))))
+;; (add-hook 'find-file-hook 'sm-try-smerge t)
+
+;;; Todo:
+
+;; - if requested, ask the user whether he wants to call ediff right away
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'diff-mode) ;For diff-auto-refine-mode.
+
+
+;;; The real definition comes later.
+(defvar smerge-mode)
+
+(defgroup smerge ()
+ "Minor mode to highlight and resolve diff3 conflicts."
+ :group 'tools
+ :prefix "smerge-")
+
+(defcustom smerge-diff-buffer-name "*vc-diff*"
+ "Buffer name to use for displaying diffs."
+ :group 'smerge
+ :type '(choice
+ (const "*vc-diff*")
+ (const "*cvs-diff*")
+ (const "*smerge-diff*")
+ string))
+
+(defcustom smerge-diff-switches
+ (append '("-d" "-b")
+ (if (listp diff-switches) diff-switches (list diff-switches)))
+ "A list of strings specifying switches to be passed to diff.
+Used in `smerge-diff-base-mine' and related functions."
+ :group 'smerge
+ :type '(repeat string))
+
+(defcustom smerge-auto-leave t
+ "Non-nil means to leave `smerge-mode' when the last conflict is resolved."
+ :group 'smerge
+ :type 'boolean)
+
+(defface smerge-mine
+ '((((min-colors 88) (background light))
+ (:foreground "blue1"))
+ (((background light))
+ (:foreground "blue"))
+ (((min-colors 88) (background dark))
+ (:foreground "cyan1"))
+ (((background dark))
+ (:foreground "cyan")))
+ "Face for your code."
+ :group 'smerge)
+(define-obsolete-face-alias 'smerge-mine-face 'smerge-mine "22.1")
+(defvar smerge-mine-face 'smerge-mine)
+
+(defface smerge-other
+ '((((background light))
+ (:foreground "darkgreen"))
+ (((background dark))
+ (:foreground "lightgreen")))
+ "Face for the other code."
+ :group 'smerge)
+(define-obsolete-face-alias 'smerge-other-face 'smerge-other "22.1")
+(defvar smerge-other-face 'smerge-other)
+
+(defface smerge-base
+ '((((min-colors 88) (background light))
+ (:foreground "red1"))
+ (((background light))
+ (:foreground "red"))
+ (((background dark))
+ (:foreground "orange")))
+ "Face for the base code."
+ :group 'smerge)
+(define-obsolete-face-alias 'smerge-base-face 'smerge-base "22.1")
+(defvar smerge-base-face 'smerge-base)
+
+(defface smerge-markers
+ '((((background light))
+ (:background "grey85"))
+ (((background dark))
+ (:background "grey30")))
+ "Face for the conflict markers."
+ :group 'smerge)
+(define-obsolete-face-alias 'smerge-markers-face 'smerge-markers "22.1")
+(defvar smerge-markers-face 'smerge-markers)
+
+(defface smerge-refined-change
+ '((t :background "yellow"))
+ "Face used for char-based changes shown by `smerge-refine'."
+ :group 'smerge)
+
+(easy-mmode-defmap smerge-basic-map
+ `(("n" . smerge-next)
+ ("p" . smerge-prev)
+ ("r" . smerge-resolve)
+ ("a" . smerge-keep-all)
+ ("b" . smerge-keep-base)
+ ("o" . smerge-keep-other)
+ ("m" . smerge-keep-mine)
+ ("E" . smerge-ediff)
+ ("C" . smerge-combine-with-next)
+ ("R" . smerge-refine)
+ ("\C-m" . smerge-keep-current)
+ ("=" . ,(make-sparse-keymap "Diff"))
+ ("=<" "base-mine" . smerge-diff-base-mine)
+ ("=>" "base-other" . smerge-diff-base-other)
+ ("==" "mine-other" . smerge-diff-mine-other))
+ "The base keymap for `smerge-mode'.")
+
+(defcustom smerge-command-prefix "\C-c^"
+ "Prefix for `smerge-mode' commands."
+ :group 'smerge
+ :type '(choice (const :tag "ESC" "\e")
+ (const :tag "C-c ^" "\C-c^" )
+ (const :tag "none" "")
+ string))
+
+(easy-mmode-defmap smerge-mode-map
+ `((,smerge-command-prefix . ,smerge-basic-map))
+ "Keymap for `smerge-mode'.")
+
+(defvar smerge-check-cache nil)
+(make-variable-buffer-local 'smerge-check-cache)
+(defun smerge-check (n)
+ (condition-case nil
+ (let ((state (cons (point) (buffer-modified-tick))))
+ (unless (equal (cdr smerge-check-cache) state)
+ (smerge-match-conflict)
+ (setq smerge-check-cache (cons (match-data) state)))
+ (nth (* 2 n) (car smerge-check-cache)))
+ (error nil)))
+
+(easy-menu-define smerge-mode-menu smerge-mode-map
+ "Menu for `smerge-mode'."
+ '("SMerge"
+ ["Next" smerge-next :help "Go to next conflict"]
+ ["Previous" smerge-prev :help "Go to previous conflict"]
+ "--"
+ ["Keep All" smerge-keep-all :help "Keep all three versions"
+ :active (smerge-check 1)]
+ ["Keep Current" smerge-keep-current :help "Use current (at point) version"
+ :active (and (smerge-check 1) (> (smerge-get-current) 0))]
+ "--"
+ ["Revert to Base" smerge-keep-base :help "Revert to base version"
+ :active (smerge-check 2)]
+ ["Keep Other" smerge-keep-other :help "Keep `other' version"
+ :active (smerge-check 3)]
+ ["Keep Yours" smerge-keep-mine :help "Keep your version"
+ :active (smerge-check 1)]
+ "--"
+ ["Diff Base/Mine" smerge-diff-base-mine
+ :help "Diff `base' and `mine' for current conflict"
+ :active (smerge-check 2)]
+ ["Diff Base/Other" smerge-diff-base-other
+ :help "Diff `base' and `other' for current conflict"
+ :active (smerge-check 2)]
+ ["Diff Mine/Other" smerge-diff-mine-other
+ :help "Diff `mine' and `other' for current conflict"
+ :active (smerge-check 1)]
+ "--"
+ ["Invoke Ediff" smerge-ediff
+ :help "Use Ediff to resolve the conflicts"
+ :active (smerge-check 1)]
+ ["Auto Resolve" smerge-resolve
+ :help "Try auto-resolution heuristics"
+ :active (smerge-check 1)]
+ ["Combine" smerge-combine-with-next
+ :help "Combine current conflict with next"
+ :active (smerge-check 1)]
+ ))
+
+(easy-menu-define smerge-context-menu nil
+ "Context menu for mine area in `smerge-mode'."
+ '(nil
+ ["Keep Current" smerge-keep-current :help "Use current (at point) version"]
+ ["Kill Current" smerge-kill-current :help "Remove current (at point) version"]
+ ["Keep All" smerge-keep-all :help "Keep all three versions"]
+ "---"
+ ["More..." (popup-menu smerge-mode-menu) :help "Show full SMerge mode menu"]
+ ))
+
+(defconst smerge-font-lock-keywords
+ '((smerge-find-conflict
+ (1 smerge-mine-face prepend t)
+ (2 smerge-base-face prepend t)
+ (3 smerge-other-face prepend t)
+ ;; FIXME: `keep' doesn't work right with syntactic fontification.
+ (0 smerge-markers-face keep)
+ (4 nil t t)
+ (5 nil t t)))
+ "Font lock patterns for `smerge-mode'.")
+
+(defconst smerge-begin-re "^<<<<<<< \\(.*\\)\n")
+(defconst smerge-end-re "^>>>>>>> .*\n")
+(defconst smerge-base-re "^||||||| .*\n")
+(defconst smerge-other-re "^=======\n")
+
+(defvar smerge-conflict-style nil
+ "Keep track of which style of conflict is in use.
+Can be nil if the style is undecided, or else:
+- `diff3-E'
+- `diff3-A'")
+
+;; Compiler pacifiers
+(defvar font-lock-mode)
+(defvar font-lock-keywords)
+
+;;;;
+;;;; Actual code
+;;;;
+
+;; Define smerge-next and smerge-prev
+(easy-mmode-define-navigation smerge smerge-begin-re "conflict" nil nil
+ (if diff-auto-refine-mode
+ (condition-case nil (smerge-refine) (error nil))))
+
+(defconst smerge-match-names ["conflict" "mine" "base" "other"])
+
+(defun smerge-ensure-match (n)
+ (unless (match-end n)
+ (error "No `%s'" (aref smerge-match-names n))))
+
+(defun smerge-auto-leave ()
+ (when (and smerge-auto-leave
+ (save-excursion (goto-char (point-min))
+ (not (re-search-forward smerge-begin-re nil t))))
+ (when (and (listp buffer-undo-list) smerge-mode)
+ (push (list 'apply 'smerge-mode 1) buffer-undo-list))
+ (smerge-mode -1)))
+
+
+(defun smerge-keep-all ()
+ "Concatenate all versions."
+ (interactive)
+ (smerge-match-conflict)
+ (let ((mb2 (or (match-beginning 2) (point-max)))
+ (me2 (or (match-end 2) (point-min))))
+ (delete-region (match-end 3) (match-end 0))
+ (delete-region (max me2 (match-end 1)) (match-beginning 3))
+ (if (and (match-end 2) (/= (match-end 1) (match-end 3)))
+ (delete-region (match-end 1) (match-beginning 2)))
+ (delete-region (match-beginning 0) (min (match-beginning 1) mb2))
+ (smerge-auto-leave)))
+
+(defun smerge-keep-n (n)
+ (smerge-remove-props (match-beginning 0) (match-end 0))
+ ;; We used to use replace-match, but that did not preserve markers so well.
+ (delete-region (match-end n) (match-end 0))
+ (delete-region (match-beginning 0) (match-beginning n)))
+
+(defun smerge-combine-with-next ()
+ "Combine the current conflict with the next one."
+ ;; `smerge-auto-combine' relies on the finish position (at the beginning
+ ;; of the closing marker).
+ (interactive)
+ (smerge-match-conflict)
+ (let ((ends nil))
+ (dolist (i '(3 2 1 0))
+ (push (if (match-end i) (copy-marker (match-end i) t)) ends))
+ (setq ends (apply 'vector ends))
+ (goto-char (aref ends 0))
+ (if (not (re-search-forward smerge-begin-re nil t))
+ (error "No next conflict")
+ (smerge-match-conflict)
+ (let ((match-data (mapcar (lambda (m) (if m (copy-marker m)))
+ (match-data))))
+ ;; First copy the in-between text in each alternative.
+ (dolist (i '(1 2 3))
+ (when (aref ends i)
+ (goto-char (aref ends i))
+ (insert-buffer-substring (current-buffer)
+ (aref ends 0) (car match-data))))
+ (delete-region (aref ends 0) (car match-data))
+ ;; Then move the second conflict's alternatives into the first.
+ (dolist (i '(1 2 3))
+ (set-match-data match-data)
+ (when (and (aref ends i) (match-end i))
+ (goto-char (aref ends i))
+ (insert-buffer-substring (current-buffer)
+ (match-beginning i) (match-end i))))
+ (delete-region (car match-data) (cadr match-data))
+ ;; Free the markers.
+ (dolist (m match-data) (if m (move-marker m nil)))
+ (mapc (lambda (m) (if m (move-marker m nil))) ends)))))
+
+(defvar smerge-auto-combine-max-separation 2
+ "Max number of lines between conflicts that should be combined.")
+
+(defun smerge-auto-combine ()
+ "Automatically combine conflicts that are near each other."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (while (smerge-find-conflict)
+ ;; 2 is 1 (default) + 1 (the begin markers).
+ (while (save-excursion
+ (smerge-find-conflict
+ (line-beginning-position
+ (+ 2 smerge-auto-combine-max-separation))))
+ (forward-line -1) ;Go back inside the conflict.
+ (smerge-combine-with-next)
+ (forward-line 1) ;Move past the end of the conflict.
+ ))))
+
+(defvar smerge-resolve-function
+ (lambda () (error "Don't know how to resolve"))
+ "Mode-specific merge function.
+The function is called with zero or one argument (non-nil if the resolution
+function should only apply safe heuristics) and with the match data set
+according to `smerge-match-conflict'.")
+(add-to-list 'debug-ignored-errors "Don't know how to resolve")
+
+(defvar smerge-text-properties
+ `(help-echo "merge conflict: mouse-3 shows a menu"
+ ;; mouse-face highlight
+ keymap (keymap (down-mouse-3 . smerge-popup-context-menu))))
+
+(defun smerge-remove-props (beg end)
+ (remove-overlays beg end 'smerge 'refine)
+ (remove-overlays beg end 'smerge 'conflict)
+ ;; Now that we use overlays rather than text-properties, this function
+ ;; does not cause refontification any more. It can be seen very clearly
+ ;; in buffers where jit-lock-contextually is not t, in which case deleting
+ ;; the "<<<<<<< foobar" leading line leaves the rest of the conflict
+ ;; highlighted as if it were still a valid conflict. Note that in many
+ ;; important cases (such as the previous example) we're actually called
+ ;; during font-locking so inhibit-modification-hooks is non-nil, so we
+ ;; can't just modify the buffer and expect font-lock to be triggered as in:
+ ;; (put-text-property beg end 'smerge-force-highlighting nil)
+ (with-silent-modifications
+ (remove-text-properties beg end '(fontified nil))))
+
+(defun smerge-popup-context-menu (event)
+ "Pop up the Smerge mode context menu under mouse."
+ (interactive "e")
+ (if (and smerge-mode
+ (save-excursion (posn-set-point (event-end event)) (smerge-check 1)))
+ (progn
+ (posn-set-point (event-end event))
+ (smerge-match-conflict)
+ (let ((i (smerge-get-current))
+ o)
+ (if (<= i 0)
+ ;; Out of range
+ (popup-menu smerge-mode-menu)
+ ;; Install overlay.
+ (setq o (make-overlay (match-beginning i) (match-end i)))
+ (unwind-protect
+ (progn
+ (overlay-put o 'face 'highlight)
+ (sit-for 0) ;Display the new highlighting.
+ (popup-menu smerge-context-menu))
+ ;; Delete overlay.
+ (delete-overlay o)))))
+ ;; There's no conflict at point, the text-props are just obsolete.
+ (save-excursion
+ (let ((beg (re-search-backward smerge-end-re nil t))
+ (end (re-search-forward smerge-begin-re nil t)))
+ (smerge-remove-props (or beg (point-min)) (or end (point-max)))
+ (push event unread-command-events)))))
+
+(defun smerge-apply-resolution-patch (buf m0b m0e m3b m3e &optional m2b)
+ "Replace the conflict with a bunch of subconflicts.
+BUF contains a plain diff between match-1 and match-3."
+ (let ((line 1)
+ (textbuf (current-buffer))
+ (name1 (progn (goto-char m0b)
+ (buffer-substring (+ (point) 8) (line-end-position))))
+ (name2 (when m2b (goto-char m2b) (forward-line -1)
+ (buffer-substring (+ (point) 8) (line-end-position))))
+ (name3 (progn (goto-char m0e) (forward-line -1)
+ (buffer-substring (+ (point) 8) (line-end-position)))))
+ (smerge-remove-props m0b m0e)
+ (delete-region m3e m0e)
+ (delete-region m0b m3b)
+ (setq m3b m0b)
+ (setq m3e (- m3e (- m3b m0b)))
+ (goto-char m3b)
+ (with-current-buffer buf
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (not (looking-at "\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?\\([acd]\\)\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?$"))
+ (error "Unexpected patch hunk header: %s"
+ (buffer-substring (point) (line-end-position)))
+ (let* ((op (char-after (match-beginning 3)))
+ (startline (+ (string-to-number (match-string 1))
+ ;; No clue why this is the way it is, but line
+ ;; numbers seem to be off-by-one for `a' ops.
+ (if (eq op ?a) 1 0)))
+ (endline (if (eq op ?a) startline
+ (1+ (if (match-end 2)
+ (string-to-number (match-string 2))
+ startline))))
+ (lines (- endline startline))
+ (otherlines (cond
+ ((eq op ?d) nil)
+ ((null (match-end 5)) 1)
+ (t (- (string-to-number (match-string 5))
+ (string-to-number (match-string 4)) -1))))
+ othertext)
+ (forward-line 1) ;Skip header.
+ (forward-line lines) ;Skip deleted text.
+ (if (eq op ?c) (forward-line 1)) ;Skip separator.
+ (setq othertext
+ (if (null otherlines) ""
+ (let ((pos (point)))
+ (dotimes (i otherlines) (delete-char 2) (forward-line 1))
+ (buffer-substring pos (point)))))
+ (with-current-buffer textbuf
+ (forward-line (- startline line))
+ (insert "<<<<<<< " name1 "\n" othertext
+ (if name2 (concat "||||||| " name2 "\n") "")
+ "=======\n")
+ (forward-line lines)
+ (insert ">>>>>>> " name3 "\n")
+ (setq line endline))))))))
+
+(defun smerge-resolve (&optional safe)
+ "Resolve the conflict at point intelligently.
+This relies on mode-specific knowledge and thus only works in some
+major modes. Uses `smerge-resolve-function' to do the actual work."
+ (interactive)
+ (smerge-match-conflict)
+ (smerge-remove-props (match-beginning 0) (match-end 0))
+ (let ((md (match-data))
+ (m0b (match-beginning 0))
+ (m1b (match-beginning 1))
+ (m2b (match-beginning 2))
+ (m3b (match-beginning 3))
+ (m0e (match-end 0))
+ (m1e (match-end 1))
+ (m2e (match-end 2))
+ (m3e (match-end 3))
+ (buf (generate-new-buffer " *smerge*"))
+ m b o)
+ (unwind-protect
+ (progn
+ (cond
+ ;; Trivial diff3 -A non-conflicts.
+ ((and (eq (match-end 1) (match-end 3))
+ (eq (match-beginning 1) (match-beginning 3)))
+ (smerge-keep-n 3))
+ ;; Mode-specific conflict resolution.
+ ((condition-case nil
+ (atomic-change-group
+ (if safe
+ (funcall smerge-resolve-function safe)
+ (funcall smerge-resolve-function))
+ t)
+ (error nil))
+ ;; Nothing to do: the resolution function has done it already.
+ nil)
+ ;; Non-conflict.
+ ((and (eq m1e m3e) (eq m1b m3b))
+ (set-match-data md) (smerge-keep-n 3))
+ ;; Refine a 2-way conflict using "diff -b".
+ ;; In case of a 3-way conflict with an empty base
+ ;; (i.e. 2 conflicting additions), we do the same, presuming
+ ;; that the 2 additions should be somehow merged rather
+ ;; than concatenated.
+ ((let ((lines (count-lines m3b m3e)))
+ (setq m (make-temp-file "smm"))
+ (write-region m1b m1e m nil 'silent)
+ (setq o (make-temp-file "smo"))
+ (write-region m3b m3e o nil 'silent)
+ (not (or (eq m1b m1e) (eq m3b m3e)
+ (and (not (zerop (call-process diff-command
+ nil buf nil "-b" o m)))
+ ;; TODO: We don't know how to do the refinement
+ ;; if there's a non-empty ancestor and m1 and m3
+ ;; aren't just plain equal.
+ m2b (not (eq m2b m2e)))
+ (with-current-buffer buf
+ (goto-char (point-min))
+ ;; Make sure there's some refinement.
+ (looking-at
+ (concat "1," (number-to-string lines) "c"))))))
+ (smerge-apply-resolution-patch buf m0b m0e m3b m3e m2b))
+ ;; "Mere whitespace changes" conflicts.
+ ((when m2e
+ (setq b (make-temp-file "smb"))
+ (write-region m2b m2e b nil 'silent)
+ (with-current-buffer buf (erase-buffer))
+ ;; Only minor whitespace changes made locally.
+ ;; BEWARE: pass "-c" 'cause the output is reused in the next test.
+ (zerop (call-process diff-command nil buf nil "-bc" b m)))
+ (set-match-data md)
+ (smerge-keep-n 3))
+ ;; Try "diff -b BASE MINE | patch OTHER".
+ ((when (and (not safe) m2e b
+ ;; If the BASE is empty, this would just concatenate
+ ;; the two, which is rarely right.
+ (not (eq m2b m2e)))
+ ;; BEWARE: we're using here the patch of the previous test.
+ (with-current-buffer buf
+ (zerop (call-process-region
+ (point-min) (point-max) "patch" t nil nil
+ "-r" "/dev/null" "--no-backup-if-mismatch"
+ "-fl" o))))
+ (save-restriction
+ (narrow-to-region m0b m0e)
+ (smerge-remove-props m0b m0e)
+ (insert-file-contents o nil nil nil t)))
+ ;; Try "diff -b BASE OTHER | patch MINE".
+ ((when (and (not safe) m2e b
+ ;; If the BASE is empty, this would just concatenate
+ ;; the two, which is rarely right.
+ (not (eq m2b m2e)))
+ (write-region m3b m3e o nil 'silent)
+ (call-process diff-command nil buf nil "-bc" b o)
+ (with-current-buffer buf
+ (zerop (call-process-region
+ (point-min) (point-max) "patch" t nil nil
+ "-r" "/dev/null" "--no-backup-if-mismatch"
+ "-fl" m))))
+ (save-restriction
+ (narrow-to-region m0b m0e)
+ (smerge-remove-props m0b m0e)
+ (insert-file-contents m nil nil nil t)))
+ (t
+ (error "Don't know how to resolve"))))
+ (if (buffer-name buf) (kill-buffer buf))
+ (if m (delete-file m))
+ (if b (delete-file b))
+ (if o (delete-file o))))
+ (smerge-auto-leave))
+
+(defun smerge-resolve-all ()
+ "Perform automatic resolution on all conflicts."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward smerge-begin-re nil t)
+ (condition-case nil
+ (progn
+ (smerge-match-conflict)
+ (smerge-resolve 'safe))
+ (error nil)))))
+
+(defun smerge-batch-resolve ()
+ ;; command-line-args-left is what is left of the command line.
+ (if (not noninteractive)
+ (error "`smerge-batch-resolve' is to be used only with -batch"))
+ (while command-line-args-left
+ (let ((file (pop command-line-args-left)))
+ (if (string-match "\\.rej\\'" file)
+ ;; .rej files should never contain diff3 markers, on the other hand,
+ ;; in Arch, .rej files are sometimes used to indicate that the
+ ;; main file has diff3 markers. So you can pass **/*.rej and
+ ;; it will DTRT.
+ (setq file (substring file 0 (match-beginning 0))))
+ (message "Resolving conflicts in %s..." file)
+ (when (file-readable-p file)
+ (with-current-buffer (find-file-noselect file)
+ (smerge-resolve-all)
+ (save-buffer)
+ (kill-buffer (current-buffer)))))))
+
+(defun smerge-keep-base ()
+ "Revert to the base version."
+ (interactive)
+ (smerge-match-conflict)
+ (smerge-ensure-match 2)
+ (smerge-keep-n 2)
+ (smerge-auto-leave))
+
+(defun smerge-keep-other ()
+ "Use \"other\" version."
+ (interactive)
+ (smerge-match-conflict)
+ ;;(smerge-ensure-match 3)
+ (smerge-keep-n 3)
+ (smerge-auto-leave))
+
+(defun smerge-keep-mine ()
+ "Keep your version."
+ (interactive)
+ (smerge-match-conflict)
+ ;;(smerge-ensure-match 1)
+ (smerge-keep-n 1)
+ (smerge-auto-leave))
+
+(defun smerge-get-current ()
+ (let ((i 3))
+ (while (or (not (match-end i))
+ (< (point) (match-beginning i))
+ (>= (point) (match-end i)))
+ (decf i))
+ i))
+
+(defun smerge-keep-current ()
+ "Use the current (under the cursor) version."
+ (interactive)
+ (smerge-match-conflict)
+ (let ((i (smerge-get-current)))
+ (if (<= i 0) (error "Not inside a version")
+ (smerge-keep-n i)
+ (smerge-auto-leave))))
+
+(defun smerge-kill-current ()
+ "Remove the current (under the cursor) version."
+ (interactive)
+ (smerge-match-conflict)
+ (let ((i (smerge-get-current)))
+ (if (<= i 0) (error "Not inside a version")
+ (let ((left nil))
+ (dolist (n '(3 2 1))
+ (if (and (match-end n) (/= (match-end n) (match-end i)))
+ (push n left)))
+ (if (and (cdr left)
+ (/= (match-end (car left)) (match-end (cadr left))))
+ (ding) ;We don't know how to do that.
+ (smerge-keep-n (car left))
+ (smerge-auto-leave))))))
+
+(defun smerge-diff-base-mine ()
+ "Diff 'base' and 'mine' version in current conflict region."
+ (interactive)
+ (smerge-diff 2 1))
+
+(defun smerge-diff-base-other ()
+ "Diff 'base' and 'other' version in current conflict region."
+ (interactive)
+ (smerge-diff 2 3))
+
+(defun smerge-diff-mine-other ()
+ "Diff 'mine' and 'other' version in current conflict region."
+ (interactive)
+ (smerge-diff 1 3))
+
+(defun smerge-match-conflict ()
+ "Get info about the conflict. Puts the info in the `match-data'.
+The submatches contain:
+ 0: the whole conflict.
+ 1: your code.
+ 2: the base code.
+ 3: other code.
+An error is raised if not inside a conflict."
+ (save-excursion
+ (condition-case nil
+ (let* ((orig-point (point))
+
+ (_ (forward-line 1))
+ (_ (re-search-backward smerge-begin-re))
+
+ (start (match-beginning 0))
+ (mine-start (match-end 0))
+ (filename (or (match-string 1) ""))
+
+ (_ (re-search-forward smerge-end-re))
+ (_ (assert (< orig-point (match-end 0))))
+
+ (other-end (match-beginning 0))
+ (end (match-end 0))
+
+ (_ (re-search-backward smerge-other-re start))
+
+ (mine-end (match-beginning 0))
+ (other-start (match-end 0))
+
+ base-start base-end)
+
+ ;; handle the various conflict styles
+ (cond
+ ((save-excursion
+ (goto-char mine-start)
+ (re-search-forward smerge-begin-re end t))
+ ;; There's a nested conflict and we're after the beginning
+ ;; of the outer one but before the beginning of the inner one.
+ ;; Of course, maybe this is not a nested conflict but in that
+ ;; case it can only be something nastier that we don't know how
+ ;; to handle, so may as well arbitrarily decide to treat it as
+ ;; a nested conflict. --Stef
+ (error "There is a nested conflict"))
+
+ ((re-search-backward smerge-base-re start t)
+ ;; a 3-parts conflict
+ (set (make-local-variable 'smerge-conflict-style) 'diff3-A)
+ (setq base-end mine-end)
+ (setq mine-end (match-beginning 0))
+ (setq base-start (match-end 0)))
+
+ ((string= filename (file-name-nondirectory
+ (or buffer-file-name "")))
+ ;; a 2-parts conflict
+ (set (make-local-variable 'smerge-conflict-style) 'diff3-E))
+
+ ((and (not base-start)
+ (or (eq smerge-conflict-style 'diff3-A)
+ (equal filename "ANCESTOR")
+ (string-match "\\`[.0-9]+\\'" filename)))
+ ;; a same-diff conflict
+ (setq base-start mine-start)
+ (setq base-end mine-end)
+ (setq mine-start other-start)
+ (setq mine-end other-end)))
+
+ (store-match-data (list start end
+ mine-start mine-end
+ base-start base-end
+ other-start other-end
+ (when base-start (1- base-start)) base-start
+ (1- other-start) other-start))
+ t)
+ (search-failed (error "Point not in conflict region")))))
+
+(add-to-list 'debug-ignored-errors "Point not in conflict region")
+
+(defun smerge-conflict-overlay (pos)
+ "Return the conflict overlay at POS if any."
+ (let ((ols (overlays-at pos))
+ conflict)
+ (dolist (ol ols)
+ (if (and (eq (overlay-get ol 'smerge) 'conflict)
+ (> (overlay-end ol) pos))
+ (setq conflict ol)))
+ conflict))
+
+(defun smerge-find-conflict (&optional limit)
+ "Find and match a conflict region. Intended as a font-lock MATCHER.
+The submatches are the same as in `smerge-match-conflict'.
+Returns non-nil if a match is found between point and LIMIT.
+Point is moved to the end of the conflict."
+ (let ((found nil)
+ (pos (point))
+ conflict)
+ ;; First check to see if point is already inside a conflict, using
+ ;; the conflict overlays.
+ (while (and (not found) (setq conflict (smerge-conflict-overlay pos)))
+ ;; Check the overlay's validity and kill it if it's out of date.
+ (condition-case nil
+ (progn
+ (goto-char (overlay-start conflict))
+ (smerge-match-conflict)
+ (goto-char (match-end 0))
+ (if (<= (point) pos)
+ (error "Matching backward!")
+ (setq found t)))
+ (error (smerge-remove-props
+ (overlay-start conflict) (overlay-end conflict))
+ (goto-char pos))))
+ ;; If we're not already inside a conflict, look for the next conflict
+ ;; and add/update its overlay.
+ (while (and (not found) (re-search-forward smerge-begin-re limit t))
+ (condition-case nil
+ (progn
+ (smerge-match-conflict)
+ (goto-char (match-end 0))
+ (let ((conflict (smerge-conflict-overlay (1- (point)))))
+ (if conflict
+ ;; Update its location, just in case it got messed up.
+ (move-overlay conflict (match-beginning 0) (match-end 0))
+ (setq conflict (make-overlay (match-beginning 0) (match-end 0)
+ nil 'front-advance nil))
+ (overlay-put conflict 'evaporate t)
+ (overlay-put conflict 'smerge 'conflict)
+ (let ((props smerge-text-properties))
+ (while props
+ (overlay-put conflict (pop props) (pop props))))))
+ (setq found t))
+ (error nil)))
+ found))
+
+;;; Refined change highlighting
+
+(defvar smerge-refine-forward-function 'smerge-refine-forward
+ "Function used to determine an \"atomic\" element.
+You can set it to `forward-char' to get char-level granularity.
+Its behavior has mainly two restrictions:
+- if this function encounters a newline, it's important that it stops right
+ after the newline.
+ This only matters if `smerge-refine-ignore-whitespace' is nil.
+- it needs to be unaffected by changes performed by the `preproc' argument
+ to `smerge-refine-subst'.
+ This only matters if `smerge-refine-weight-hack' is nil.")
+
+(defvar smerge-refine-ignore-whitespace t
+ "If non-nil, indicate that `smerge-refine' should try to ignore change in whitespace.")
+
+(defvar smerge-refine-weight-hack t
+ "If non-nil, pass to diff as many lines as there are chars in the region.
+I.e. each atomic element (e.g. word) will be copied as many times (on different
+lines) as it has chars. This has two advantages:
+- if `diff' tries to minimize the number *lines* (rather than chars)
+ added/removed, this adjust the weights so that adding/removing long
+ symbols is considered correspondingly more costly.
+- `smerge-refine-forward-function' only needs to be called when chopping up
+ the regions, and `forward-char' can be used afterwards.
+It has the following disadvantages:
+- cannot use `diff -w' because the weighting causes added spaces in a line
+ to be represented as added copies of some line, so `diff -w' can't do the
+ right thing any more.
+- may in degenerate cases take a 1KB input region and turn it into a 1MB
+ file to pass to diff.")
+
+(defun smerge-refine-forward (n)
+ (let ((case-fold-search nil)
+ (re "[[:upper:]]?[[:lower:]]+\\|[[:upper:]]+\\|[[:digit:]]+\\|.\\|\n"))
+ (when (and smerge-refine-ignore-whitespace
+ ;; smerge-refine-weight-hack causes additional spaces to
+ ;; appear as additional lines as well, so even if diff ignore
+ ;; whitespace changes, it'll report added/removed lines :-(
+ (not smerge-refine-weight-hack))
+ (setq re (concat "[ \t]*\\(?:" re "\\)")))
+ (dotimes (i n)
+ (unless (looking-at re) (error "Smerge refine internal error"))
+ (goto-char (match-end 0)))))
+
+(defun smerge-refine-chopup-region (beg end file &optional preproc)
+ "Chopup the region into small elements, one per line.
+Save the result into FILE.
+If non-nil, PREPROC is called with no argument in a buffer that contains
+a copy of the text, just before chopping it up. It can be used to replace
+chars to try and eliminate some spurious differences."
+ ;; We used to chop up char-by-char rather than word-by-word like ediff
+ ;; does. It had the benefit of simplicity and very fine results, but it
+ ;; often suffered from problem that diff would find correlations where
+ ;; there aren't any, so the resulting "change" didn't make much sense.
+ ;; You can still get this behavior by setting
+ ;; `smerge-refine-forward-function' to `forward-char'.
+ (let ((buf (current-buffer)))
+ (with-temp-buffer
+ (insert-buffer-substring buf beg end)
+ (when preproc (goto-char (point-min)) (funcall preproc))
+ (when smerge-refine-ignore-whitespace
+ ;; It doesn't make much of a difference for diff-fine-highlight
+ ;; because we still have the _/+/</>/! prefix anyway. Can still be
+ ;; useful in other circumstances.
+ (subst-char-in-region (point-min) (point-max) ?\n ?\s))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (funcall smerge-refine-forward-function 1)
+ (let ((s (if (prog2 (forward-char -1) (bolp) (forward-char 1))
+ nil
+ (buffer-substring (line-beginning-position) (point)))))
+ ;; We add \n after each char except after \n, so we get
+ ;; one line per text char, where each line contains
+ ;; just one char, except for \n chars which are
+ ;; represented by the empty line.
+ (unless (eq (char-before) ?\n) (insert ?\n))
+ ;; HACK ALERT!!
+ (if smerge-refine-weight-hack
+ (dotimes (i (1- (length s))) (insert s "\n")))))
+ (unless (bolp) (error "Smerge refine internal error"))
+ (let ((coding-system-for-write 'emacs-mule))
+ (write-region (point-min) (point-max) file nil 'nomessage)))))
+
+(defun smerge-refine-highlight-change (buf beg match-num1 match-num2 props)
+ (with-current-buffer buf
+ (goto-char beg)
+ (let* ((startline (- (string-to-number match-num1) 1))
+ (beg (progn (funcall (if smerge-refine-weight-hack
+ 'forward-char
+ smerge-refine-forward-function)
+ startline)
+ (point)))
+ (end (progn (funcall (if smerge-refine-weight-hack
+ 'forward-char
+ smerge-refine-forward-function)
+ (if match-num2
+ (- (string-to-number match-num2)
+ startline)
+ 1))
+ (point))))
+ (when smerge-refine-ignore-whitespace
+ (skip-chars-backward " \t\n" beg) (setq end (point))
+ (goto-char beg)
+ (skip-chars-forward " \t\n" end) (setq beg (point)))
+ (when (> end beg)
+ (let ((ol (make-overlay
+ beg end nil
+ ;; Make them tend to shrink rather than spread when editing.
+ 'front-advance nil)))
+ (overlay-put ol 'evaporate t)
+ (dolist (x props) (overlay-put ol (car x) (cdr x)))
+ ol)))))
+
+(defun smerge-refine-subst (beg1 end1 beg2 end2 props &optional preproc)
+ "Show fine differences in the two regions BEG1..END1 and BEG2..END2.
+PROPS is an alist of properties to put (via overlays) on the changes.
+If non-nil, PREPROC is called with no argument in a buffer that contains
+a copy of a region, just before preparing it to for `diff'. It can be
+used to replace chars to try and eliminate some spurious differences."
+ (let* ((buf (current-buffer))
+ (pos (point))
+ (file1 (make-temp-file "diff1"))
+ (file2 (make-temp-file "diff2")))
+ ;; Chop up regions into smaller elements and save into files.
+ (smerge-refine-chopup-region beg1 end1 file1 preproc)
+ (smerge-refine-chopup-region beg2 end2 file2 preproc)
+
+ ;; Call diff on those files.
+ (unwind-protect
+ (with-temp-buffer
+ (let ((coding-system-for-read 'emacs-mule))
+ (call-process diff-command nil t nil
+ (if (and smerge-refine-ignore-whitespace
+ (not smerge-refine-weight-hack))
+ ;; Pass -a so diff treats it as a text file even
+ ;; if it contains \0 and such.
+ ;; Pass -d so as to get the smallest change, but
+ ;; also and more importantly because otherwise it
+ ;; may happen that diff doesn't behave like
+ ;; smerge-refine-weight-hack expects it to.
+ ;; See http://thread.gmane.org/gmane.emacs.devel/82685.
+ "-awd" "-ad")
+ file1 file2))
+ ;; Process diff's output.
+ (goto-char (point-min))
+ (let ((last1 nil)
+ (last2 nil))
+ (while (not (eobp))
+ (if (not (looking-at "\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?\\([acd]\\)\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?$"))
+ (error "Unexpected patch hunk header: %s"
+ (buffer-substring (point) (line-end-position))))
+ (let ((op (char-after (match-beginning 3)))
+ (m1 (match-string 1))
+ (m2 (match-string 2))
+ (m4 (match-string 4))
+ (m5 (match-string 5)))
+ (when (memq op '(?d ?c))
+ (setq last1
+ (smerge-refine-highlight-change buf beg1 m1 m2 props)))
+ (when (memq op '(?a ?c))
+ (setq last2
+ (smerge-refine-highlight-change buf beg2 m4 m5 props))))
+ (forward-line 1) ;Skip hunk header.
+ (and (re-search-forward "^[0-9]" nil 'move) ;Skip hunk body.
+ (goto-char (match-beginning 0))))
+ ;; (assert (or (null last1) (< (overlay-start last1) end1)))
+ ;; (assert (or (null last2) (< (overlay-start last2) end2)))
+ (if smerge-refine-weight-hack
+ (progn
+ ;; (assert (or (null last1) (<= (overlay-end last1) end1)))
+ ;; (assert (or (null last2) (<= (overlay-end last2) end2)))
+ )
+ ;; smerge-refine-forward-function when calling in chopup may
+ ;; have stopped because it bumped into EOB whereas in
+ ;; smerge-refine-weight-hack it may go a bit further.
+ (if (and last1 (> (overlay-end last1) end1))
+ (move-overlay last1 (overlay-start last1) end1))
+ (if (and last2 (> (overlay-end last2) end2))
+ (move-overlay last2 (overlay-start last2) end2))
+ )))
+ (goto-char pos)
+ (delete-file file1)
+ (delete-file file2))))
+
+(defun smerge-refine (&optional part)
+ "Highlight the words of the conflict that are different.
+For 3-way conflicts, highlights only two of the three parts.
+A numeric argument PART can be used to specify which two parts;
+repeating the command will highlight other two parts."
+ (interactive
+ (if (integerp current-prefix-arg) (list current-prefix-arg)
+ (smerge-match-conflict)
+ (let* ((prop (get-text-property (match-beginning 0) 'smerge-refine-part))
+ (part (if (and (consp prop)
+ (eq (buffer-chars-modified-tick) (car prop)))
+ (cdr prop))))
+ ;; If already highlighted, cycle.
+ (list (if (integerp part) (1+ (mod part 3)))))))
+
+ (if (and (integerp part) (or (< part 1) (> part 3)))
+ (error "No conflict part nb %s" part))
+ (smerge-match-conflict)
+ (remove-overlays (match-beginning 0) (match-end 0) 'smerge 'refine)
+ ;; Ignore `part' if not applicable, and default it if not provided.
+ (setq part (cond ((null (match-end 2)) 2)
+ ((eq (match-end 1) (match-end 3)) 1)
+ ((integerp part) part)
+ (t 2)))
+ (let ((n1 (if (eq part 1) 2 1))
+ (n2 (if (eq part 3) 2 3)))
+ (smerge-ensure-match n1)
+ (smerge-ensure-match n2)
+ (with-silent-modifications
+ (put-text-property (match-beginning 0) (1+ (match-beginning 0))
+ 'smerge-refine-part
+ (cons (buffer-chars-modified-tick) part)))
+ (smerge-refine-subst (match-beginning n1) (match-end n1)
+ (match-beginning n2) (match-end n2)
+ '((smerge . refine)
+ (face . smerge-refined-change)))))
+
+(defun smerge-diff (n1 n2)
+ (smerge-match-conflict)
+ (smerge-ensure-match n1)
+ (smerge-ensure-match n2)
+ (let ((name1 (aref smerge-match-names n1))
+ (name2 (aref smerge-match-names n2))
+ ;; Read them before the match-data gets clobbered.
+ (beg1 (match-beginning n1))
+ (end1 (match-end n1))
+ (beg2 (match-beginning n2))
+ (end2 (match-end n2))
+ (file1 (make-temp-file "smerge1"))
+ (file2 (make-temp-file "smerge2"))
+ (dir default-directory)
+ (file (if buffer-file-name (file-relative-name buffer-file-name)))
+ ;; We would want to use `emacs-mule-unix' for read&write, but we
+ ;; bump into problems with the coding-system used by diff to write
+ ;; the file names and the time stamps in the header.
+ ;; `buffer-file-coding-system' is not always correct either, but if
+ ;; the OS/user uses only one coding-system, then it works.
+ (coding-system-for-read buffer-file-coding-system))
+ (write-region beg1 end1 file1 nil 'nomessage)
+ (write-region beg2 end2 file2 nil 'nomessage)
+ (unwind-protect
+ (with-current-buffer (get-buffer-create smerge-diff-buffer-name)
+ (setq default-directory dir)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (let ((status
+ (apply 'call-process diff-command nil t nil
+ (append smerge-diff-switches
+ (list "-L" (concat name1 "/" file)
+ "-L" (concat name2 "/" file)
+ file1 file2)))))
+ (if (eq status 0) (insert "No differences found.\n"))))
+ (goto-char (point-min))
+ (diff-mode)
+ (display-buffer (current-buffer) t))
+ (delete-file file1)
+ (delete-file file2))))
+
+;; compiler pacifiers
+(defvar smerge-ediff-windows)
+(defvar smerge-ediff-buf)
+(defvar ediff-buffer-A)
+(defvar ediff-buffer-B)
+(defvar ediff-buffer-C)
+(defvar ediff-ancestor-buffer)
+(defvar ediff-quit-hook)
+(declare-function ediff-cleanup-mess "ediff-util" nil)
+
+;;;###autoload
+(defun smerge-ediff (&optional name-mine name-other name-base)
+ "Invoke ediff to resolve the conflicts.
+NAME-MINE, NAME-OTHER, and NAME-BASE, if non-nil, are used for the
+buffer names."
+ (interactive)
+ (let* ((buf (current-buffer))
+ (mode major-mode)
+ ;;(ediff-default-variant 'default-B)
+ (config (current-window-configuration))
+ (filename (file-name-nondirectory buffer-file-name))
+ (mine (generate-new-buffer
+ (or name-mine (concat "*" filename " MINE*"))))
+ (other (generate-new-buffer
+ (or name-other (concat "*" filename " OTHER*"))))
+ base)
+ (with-current-buffer mine
+ (buffer-disable-undo)
+ (insert-buffer-substring buf)
+ (goto-char (point-min))
+ (while (smerge-find-conflict)
+ (when (match-beginning 2) (setq base t))
+ (smerge-keep-n 1))
+ (buffer-enable-undo)
+ (set-buffer-modified-p nil)
+ (funcall mode))
+
+ (with-current-buffer other
+ (buffer-disable-undo)
+ (insert-buffer-substring buf)
+ (goto-char (point-min))
+ (while (smerge-find-conflict)
+ (smerge-keep-n 3))
+ (buffer-enable-undo)
+ (set-buffer-modified-p nil)
+ (funcall mode))
+
+ (when base
+ (setq base (generate-new-buffer
+ (or name-base (concat "*" filename " BASE*"))))
+ (with-current-buffer base
+ (buffer-disable-undo)
+ (insert-buffer-substring buf)
+ (goto-char (point-min))
+ (while (smerge-find-conflict)
+ (if (match-end 2)
+ (smerge-keep-n 2)
+ (delete-region (match-beginning 0) (match-end 0))))
+ (buffer-enable-undo)
+ (set-buffer-modified-p nil)
+ (funcall mode)))
+
+ ;; the rest of the code is inspired from vc.el
+ ;; Fire up ediff.
+ (set-buffer
+ (if base
+ (ediff-merge-buffers-with-ancestor mine other base)
+ ;; nil 'ediff-merge-revisions-with-ancestor buffer-file-name)
+ (ediff-merge-buffers mine other)))
+ ;; nil 'ediff-merge-revisions buffer-file-name)))
+
+ ;; Ediff is now set up, and we are in the control buffer.
+ ;; Do a few further adjustments and take precautions for exit.
+ (set (make-local-variable 'smerge-ediff-windows) config)
+ (set (make-local-variable 'smerge-ediff-buf) buf)
+ (set (make-local-variable 'ediff-quit-hook)
+ (lambda ()
+ (let ((buffer-A ediff-buffer-A)
+ (buffer-B ediff-buffer-B)
+ (buffer-C ediff-buffer-C)
+ (buffer-Ancestor ediff-ancestor-buffer)
+ (buf smerge-ediff-buf)
+ (windows smerge-ediff-windows))
+ (ediff-cleanup-mess)
+ (with-current-buffer buf
+ (erase-buffer)
+ (insert-buffer-substring buffer-C)
+ (kill-buffer buffer-A)
+ (kill-buffer buffer-B)
+ (kill-buffer buffer-C)
+ (when (bufferp buffer-Ancestor) (kill-buffer buffer-Ancestor))
+ (set-window-configuration windows)
+ (message "Conflict resolution finished; you may save the buffer")))))
+ (message "Please resolve conflicts now; exit ediff when done")))
+
+(defun smerge-makeup-conflict (pt1 pt2 pt3 &optional pt4)
+ "Insert diff3 markers to make a new conflict.
+Uses point and mark for two of the relevant positions and previous marks
+for the other ones.
+By default, makes up a 2-way conflict,
+with a \\[universal-argument] prefix, makes up a 3-way conflict."
+ (interactive
+ (list (point)
+ (mark)
+ (progn (pop-mark) (mark))
+ (when current-prefix-arg (pop-mark) (mark))))
+ ;; Start from the end so as to avoid problems with pos-changes.
+ (destructuring-bind (pt1 pt2 pt3 &optional pt4)
+ (sort (list* pt1 pt2 pt3 (if pt4 (list pt4))) '>=)
+ (goto-char pt1) (beginning-of-line)
+ (insert ">>>>>>> OTHER\n")
+ (goto-char pt2) (beginning-of-line)
+ (insert "=======\n")
+ (goto-char pt3) (beginning-of-line)
+ (when pt4
+ (insert "||||||| BASE\n")
+ (goto-char pt4) (beginning-of-line))
+ (insert "<<<<<<< MINE\n"))
+ (if smerge-mode nil (smerge-mode 1))
+ (smerge-refine))
+
+
+(defconst smerge-parsep-re
+ (concat smerge-begin-re "\\|" smerge-end-re "\\|"
+ smerge-base-re "\\|" smerge-other-re "\\|"))
+
+;;;###autoload
+(define-minor-mode smerge-mode
+ "Minor mode to simplify editing output from the diff3 program.
+\\{smerge-mode-map}"
+ :group 'smerge :lighter " SMerge"
+ (when (and (boundp 'font-lock-mode) font-lock-mode)
+ (save-excursion
+ (if smerge-mode
+ (font-lock-add-keywords nil smerge-font-lock-keywords 'append)
+ (font-lock-remove-keywords nil smerge-font-lock-keywords))
+ (goto-char (point-min))
+ (while (smerge-find-conflict)
+ (save-excursion
+ (font-lock-fontify-region (match-beginning 0) (match-end 0) nil)))))
+ (if (string-match (regexp-quote smerge-parsep-re) paragraph-separate)
+ (unless smerge-mode
+ (set (make-local-variable 'paragraph-separate)
+ (replace-match "" t t paragraph-separate)))
+ (when smerge-mode
+ (set (make-local-variable 'paragraph-separate)
+ (concat smerge-parsep-re paragraph-separate))))
+ (unless smerge-mode
+ (smerge-remove-props (point-min) (point-max))))
+
+;;;###autoload
+(defun smerge-start-session ()
+ "Turn on `smerge-mode' and move point to first conflict marker.
+If no conflict maker is found, turn off `smerge-mode'."
+ (interactive)
+ (smerge-mode 1)
+ (condition-case nil
+ (unless (looking-at smerge-begin-re)
+ (smerge-next))
+ (error (smerge-auto-leave))))
+
+(provide 'smerge-mode)
+
+;; arch-tag: 605c8d1e-e43d-4943-a6f3-1bcc4333e690
+;;; smerge-mode.el ends here
--- /dev/null
+;;; vc-annotate.el --- VC Annotate Support
+
+;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Martin Lorentzson <emwson@emw.ericsson.se>
+;; Maintainer: FSF
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+
+(require 'vc-hooks)
+(require 'vc)
+
+;;; Code:
+(eval-when-compile
+ (require 'cl))
+
+(defcustom vc-annotate-display-mode 'fullscale
+ "Which mode to color the output of \\[vc-annotate] with by default."
+ :type '(choice (const :tag "By Color Map Range" nil)
+ (const :tag "Scale to Oldest" scale)
+ (const :tag "Scale Oldest->Newest" fullscale)
+ (number :tag "Specify Fractional Number of Days"
+ :value "20.5"))
+ :group 'vc)
+
+(defcustom vc-annotate-color-map
+ (if (and (tty-display-color-p) (<= (display-color-cells) 8))
+ ;; A custom sorted TTY colormap
+ (let* ((colors
+ (sort
+ (delq nil
+ (mapcar (lambda (x)
+ (if (not (or
+ (string-equal (car x) "white")
+ (string-equal (car x) "black") ))
+ (car x)))
+ (tty-color-alist)))
+ (lambda (a b)
+ (cond
+ ((or (string-equal a "red") (string-equal b "blue")) t)
+ ((or (string-equal b "red") (string-equal a "blue")) nil)
+ ((string-equal a "yellow") t)
+ ((string-equal b "yellow") nil)
+ ((string-equal a "cyan") t)
+ ((string-equal b "cyan") nil)
+ ((string-equal a "green") t)
+ ((string-equal b "green") nil)
+ ((string-equal a "magenta") t)
+ ((string-equal b "magenta") nil)
+ (t (string< a b))))))
+ (date 20.)
+ (delta (/ (- 360. date) (1- (length colors)))))
+ (mapcar (lambda (x)
+ (prog1
+ (cons date x)
+ (setq date (+ date delta)))) colors))
+ ;; Normal colormap: hue stepped from 0-240deg, value=1., saturation=0.75
+ '(( 20. . "#FF3F3F")
+ ( 40. . "#FF6C3F")
+ ( 60. . "#FF993F")
+ ( 80. . "#FFC63F")
+ (100. . "#FFF33F")
+ (120. . "#DDFF3F")
+ (140. . "#B0FF3F")
+ (160. . "#83FF3F")
+ (180. . "#56FF3F")
+ (200. . "#3FFF56")
+ (220. . "#3FFF83")
+ (240. . "#3FFFB0")
+ (260. . "#3FFFDD")
+ (280. . "#3FF3FF")
+ (300. . "#3FC6FF")
+ (320. . "#3F99FF")
+ (340. . "#3F6CFF")
+ (360. . "#3F3FFF")))
+ "Association list of age versus color, for \\[vc-annotate].
+Ages are given in units of fractional days. Default is eighteen
+steps using a twenty day increment, from red to blue. For TTY
+displays with 8 or fewer colors, the default is red to blue with
+all other colors between (excluding black and white)."
+ :type 'alist
+ :group 'vc)
+
+(defcustom vc-annotate-very-old-color "#3F3FFF"
+ "Color for lines older than the current color range in \\[vc-annotate]."
+ :type 'string
+ :group 'vc)
+
+(defcustom vc-annotate-background "black"
+ "Background color for \\[vc-annotate].
+Default color is used if nil."
+ :type '(choice (const :tag "Default background" nil) (color))
+ :group 'vc)
+
+(defcustom vc-annotate-menu-elements '(2 0.5 0.1 0.01)
+ "Menu elements for the mode-specific menu of VC-Annotate mode.
+List of factors, used to expand/compress the time scale. See `vc-annotate'."
+ :type '(repeat number)
+ :group 'vc)
+
+(defvar vc-annotate-mode-map
+ (let ((m (make-sparse-keymap)))
+ (define-key m "a" 'vc-annotate-revision-previous-to-line)
+ (define-key m "d" 'vc-annotate-show-diff-revision-at-line)
+ (define-key m "D" 'vc-annotate-show-changeset-diff-revision-at-line)
+ (define-key m "f" 'vc-annotate-find-revision-at-line)
+ (define-key m "j" 'vc-annotate-revision-at-line)
+ (define-key m "l" 'vc-annotate-show-log-revision-at-line)
+ (define-key m "n" 'vc-annotate-next-revision)
+ (define-key m "p" 'vc-annotate-prev-revision)
+ (define-key m "w" 'vc-annotate-working-revision)
+ (define-key m "v" 'vc-annotate-toggle-annotation-visibility)
+ m)
+ "Local keymap used for VC-Annotate mode.")
+
+;;; Annotate functionality
+
+;; Declare globally instead of additional parameter to
+;; temp-buffer-show-function (not possible to pass more than one
+;; parameter). The use of annotate-ratio is deprecated in favor of
+;; annotate-mode, which replaces it with the more sensible "span-to
+;; days", along with autoscaling support.
+(defvar vc-annotate-ratio nil "Global variable.")
+
+;; internal buffer-local variables
+(defvar vc-annotate-backend nil)
+(defvar vc-annotate-parent-file nil)
+(defvar vc-annotate-parent-rev nil)
+(defvar vc-annotate-parent-display-mode nil)
+
+(defconst vc-annotate-font-lock-keywords
+ ;; The fontification is done by vc-annotate-lines instead of font-lock.
+ '((vc-annotate-lines)))
+
+(define-derived-mode vc-annotate-mode special-mode "Annotate"
+ "Major mode for output buffers of the `vc-annotate' command.
+
+You can use the mode-specific menu to alter the time-span of the used
+colors. See variable `vc-annotate-menu-elements' for customizing the
+menu items."
+ ;; Frob buffer-invisibility-spec so that if it is originally a naked t,
+ ;; it will become a list, to avoid initial annotations being invisible.
+ (add-to-invisibility-spec 'foo)
+ (remove-from-invisibility-spec 'foo)
+ (set (make-local-variable 'truncate-lines) t)
+ (set (make-local-variable 'font-lock-defaults)
+ '(vc-annotate-font-lock-keywords t))
+ (hack-dir-local-variables-non-file-buffer))
+
+(defun vc-annotate-toggle-annotation-visibility ()
+ "Toggle whether or not the annotation is visible."
+ (interactive)
+ (funcall (if (memq 'vc-annotate-annotation buffer-invisibility-spec)
+ 'remove-from-invisibility-spec
+ 'add-to-invisibility-spec)
+ 'vc-annotate-annotation)
+ (force-window-update (current-buffer)))
+
+(defun vc-annotate-display-default (ratio)
+ "Display the output of \\[vc-annotate] using the default color range.
+The color range is given by `vc-annotate-color-map', scaled by RATIO.
+The current time is used as the offset."
+ (interactive (progn (kill-local-variable 'vc-annotate-color-map) '(1.0)))
+ (message "Redisplaying annotation...")
+ (vc-annotate-display ratio)
+ (message "Redisplaying annotation...done"))
+
+(defun vc-annotate-oldest-in-map (color-map)
+ "Return the oldest time in the COLOR-MAP."
+ ;; Since entries should be sorted, we can just use the last one.
+ (caar (last color-map)))
+
+(defun vc-annotate-get-time-set-line-props ()
+ (let ((bol (point))
+ (date (vc-call-backend vc-annotate-backend 'annotate-time))
+ (inhibit-read-only t))
+ (assert (>= (point) bol))
+ (put-text-property bol (point) 'invisible 'vc-annotate-annotation)
+ date))
+
+(defun vc-annotate-display-autoscale (&optional full)
+ "Highlight the output of \\[vc-annotate] using an autoscaled color map.
+Autoscaling means that the map is scaled from the current time to the
+oldest annotation in the buffer, or, with prefix argument FULL, to
+cover the range from the oldest annotation to the newest."
+ (interactive "P")
+ (let ((newest 0.0)
+ (oldest 999999.) ;Any CVS users at the founding of Rome?
+ (current (vc-annotate-convert-time (current-time)))
+ date)
+ (message "Redisplaying annotation...")
+ ;; Run through this file and find the oldest and newest dates annotated.
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (setq date (vc-annotate-get-time-set-line-props))
+ (when (> date newest)
+ (setq newest date))
+ (when (< date oldest)
+ (setq oldest date)))
+ (forward-line 1)))
+ (vc-annotate-display
+ (/ (- (if full newest current) oldest)
+ (vc-annotate-oldest-in-map vc-annotate-color-map))
+ (if full newest))
+ (message "Redisplaying annotation...done \(%s\)"
+ (if full
+ (format "Spanned from %.1f to %.1f days old"
+ (- current oldest)
+ (- current newest))
+ (format "Spanned to %.1f days old" (- current oldest))))))
+
+;; Menu -- Using easymenu.el
+(easy-menu-define vc-annotate-mode-menu vc-annotate-mode-map
+ "VC Annotate Display Menu"
+ `("VC-Annotate"
+ ["By Color Map Range" (unless (null vc-annotate-display-mode)
+ (setq vc-annotate-display-mode nil)
+ (vc-annotate-display-select))
+ :style toggle :selected (null vc-annotate-display-mode)]
+ ,@(let ((oldest-in-map (vc-annotate-oldest-in-map vc-annotate-color-map)))
+ (mapcar (lambda (element)
+ (let ((days (* element oldest-in-map)))
+ `[,(format "Span %.1f days" days)
+ (vc-annotate-display-select nil ,days)
+ :style toggle :selected
+ (eql vc-annotate-display-mode ,days) ]))
+ vc-annotate-menu-elements))
+ ["Span ..."
+ (vc-annotate-display-select
+ nil (float (string-to-number (read-string "Span how many days? "))))]
+ "--"
+ ["Span to Oldest"
+ (unless (eq vc-annotate-display-mode 'scale)
+ (vc-annotate-display-select nil 'scale))
+ :help
+ "Use an autoscaled color map from the oldest annotation to the current time"
+ :style toggle :selected
+ (eq vc-annotate-display-mode 'scale)]
+ ["Span Oldest->Newest"
+ (unless (eq vc-annotate-display-mode 'fullscale)
+ (vc-annotate-display-select nil 'fullscale))
+ :help
+ "Use an autoscaled color map from the oldest to the newest annotation"
+ :style toggle :selected
+ (eq vc-annotate-display-mode 'fullscale)]
+ "--"
+ ["Toggle annotation visibility" vc-annotate-toggle-annotation-visibility
+ :help
+ "Toggle whether the annotation is visible or not"]
+ ["Annotate previous revision" vc-annotate-prev-revision
+ :help "Visit the annotation of the revision previous to this one"]
+ ["Annotate next revision" vc-annotate-next-revision
+ :help "Visit the annotation of the revision after this one"]
+ ["Annotate revision at line" vc-annotate-revision-at-line
+ :help
+ "Visit the annotation of the revision identified in the current line"]
+ ["Annotate revision previous to line" vc-annotate-revision-previous-to-line
+ :help "Visit the annotation of the revision before the revision at line"]
+ ["Annotate latest revision" vc-annotate-working-revision
+ :help "Visit the annotation of the working revision of this file"]
+ "--"
+ ["Show log of revision at line" vc-annotate-show-log-revision-at-line
+ :help "Visit the log of the revision at line"]
+ ["Show diff of revision at line" vc-annotate-show-diff-revision-at-line
+ :help "Visit the diff of the revision at line from its previous revision"]
+ ["Show changeset diff of revision at line"
+ vc-annotate-show-changeset-diff-revision-at-line
+ :enable
+ (eq 'repository (vc-call-backend ,vc-annotate-backend 'revision-granularity))
+ :help "Visit the diff of the revision at line from its previous revision"]
+ ["Visit revision at line" vc-annotate-find-revision-at-line
+ :help "Visit the revision identified in the current line"]))
+
+(defun vc-annotate-display-select (&optional buffer mode)
+ "Highlight the output of \\[vc-annotate].
+By default, the current buffer is highlighted, unless overridden by
+BUFFER. `vc-annotate-display-mode' specifies the highlighting mode to
+use; you may override this using the second optional arg MODE."
+ (interactive)
+ (when mode (setq vc-annotate-display-mode mode))
+ (pop-to-buffer (or buffer (current-buffer)))
+ (cond ((null vc-annotate-display-mode)
+ ;; The ratio is global, thus relative to the global color-map.
+ (kill-local-variable 'vc-annotate-color-map)
+ (vc-annotate-display-default (or vc-annotate-ratio 1.0)))
+ ;; One of the auto-scaling modes
+ ((eq vc-annotate-display-mode 'scale)
+ (vc-exec-after `(vc-annotate-display-autoscale)))
+ ((eq vc-annotate-display-mode 'fullscale)
+ (vc-exec-after `(vc-annotate-display-autoscale t)))
+ ((numberp vc-annotate-display-mode) ; A fixed number of days lookback
+ (vc-annotate-display-default
+ (/ vc-annotate-display-mode
+ (vc-annotate-oldest-in-map vc-annotate-color-map))))
+ (t (error "No such display mode: %s"
+ vc-annotate-display-mode))))
+
+;;;###autoload
+(defun vc-annotate (file rev &optional display-mode buf move-point-to)
+ "Display the edit history of the current file using colors.
+
+This command creates a buffer that shows, for each line of the current
+file, when it was last edited and by whom. Additionally, colors are
+used to show the age of each line--blue means oldest, red means
+youngest, and intermediate colors indicate intermediate ages. By
+default, the time scale stretches back one year into the past;
+everything that is older than that is shown in blue.
+
+With a prefix argument, this command asks two questions in the
+minibuffer. First, you may enter a revision number; then the buffer
+displays and annotates that revision instead of the working revision
+\(type RET in the minibuffer to leave that default unchanged). Then,
+you are prompted for the time span in days which the color range
+should cover. For example, a time span of 20 days means that changes
+over the past 20 days are shown in red to blue, according to their
+age, and everything that is older than that is shown in blue.
+
+If MOVE-POINT-TO is given, move the point to that line.
+
+Customization variables:
+
+`vc-annotate-menu-elements' customizes the menu elements of the
+mode-specific menu. `vc-annotate-color-map' and
+`vc-annotate-very-old-color' define the mapping of time to colors.
+`vc-annotate-background' specifies the background color."
+ (interactive
+ (save-current-buffer
+ (vc-ensure-vc-buffer)
+ (list buffer-file-name
+ (let ((def (vc-working-revision buffer-file-name)))
+ (if (null current-prefix-arg) def
+ (read-string
+ (format "Annotate from revision (default %s): " def)
+ nil nil def)))
+ (if (null current-prefix-arg)
+ vc-annotate-display-mode
+ (float (string-to-number
+ (read-string "Annotate span days (default 20): "
+ nil nil "20")))))))
+ (vc-ensure-vc-buffer)
+ (setq vc-annotate-display-mode display-mode) ;Not sure why. --Stef
+ (let* ((temp-buffer-name (format "*Annotate %s (rev %s)*" (buffer-name) rev))
+ (temp-buffer-show-function 'vc-annotate-display-select)
+ ;; If BUF is specified, we presume the caller maintains current line,
+ ;; so we don't need to do it here. This implementation may give
+ ;; strange results occasionally in the case of REV != WORKFILE-REV.
+ (current-line (or move-point-to (unless buf
+ (save-restriction
+ (widen)
+ (line-number-at-pos))))))
+ (message "Annotating...")
+ ;; If BUF is specified it tells in which buffer we should put the
+ ;; annotations. This is used when switching annotations to another
+ ;; revision, so we should update the buffer's name.
+ (when buf (with-current-buffer buf
+ (rename-buffer temp-buffer-name t)
+ ;; In case it had to be uniquified.
+ (setq temp-buffer-name (buffer-name))))
+ (with-output-to-temp-buffer temp-buffer-name
+ (let ((backend (vc-backend file))
+ (coding-system-for-read buffer-file-coding-system))
+ (vc-call-backend backend 'annotate-command file
+ (get-buffer temp-buffer-name) rev)
+ ;; we must setup the mode first, and then set our local
+ ;; variables before the show-function is called at the exit of
+ ;; with-output-to-temp-buffer
+ (with-current-buffer temp-buffer-name
+ (unless (equal major-mode 'vc-annotate-mode)
+ (vc-annotate-mode))
+ (set (make-local-variable 'vc-annotate-backend) backend)
+ (set (make-local-variable 'vc-annotate-parent-file) file)
+ (set (make-local-variable 'vc-annotate-parent-rev) rev)
+ (set (make-local-variable 'vc-annotate-parent-display-mode)
+ display-mode))))
+
+ (with-current-buffer temp-buffer-name
+ (vc-exec-after
+ `(progn
+ ;; Ideally, we'd rather not move point if the user has already
+ ;; moved it elsewhere, but really point here is not the position
+ ;; of the user's cursor :-(
+ (when ,current-line ;(and (bobp))
+ (goto-line ,current-line)
+ (setq vc-sentinel-movepoint (point)))
+ (unless (active-minibuffer-window)
+ (message "Annotating... done")))))))
+
+(defun vc-annotate-prev-revision (prefix)
+ "Visit the annotation of the revision previous to this one.
+
+With a numeric prefix argument, annotate the revision that many
+revisions previous."
+ (interactive "p")
+ (vc-annotate-warp-revision (- 0 prefix)))
+
+(defun vc-annotate-next-revision (prefix)
+ "Visit the annotation of the revision after this one.
+
+With a numeric prefix argument, annotate the revision that many
+revisions after."
+ (interactive "p")
+ (vc-annotate-warp-revision prefix))
+
+(defun vc-annotate-working-revision ()
+ "Visit the annotation of the working revision of this file."
+ (interactive)
+ (if (not (equal major-mode 'vc-annotate-mode))
+ (message "Cannot be invoked outside of a vc annotate buffer")
+ (let ((warp-rev (vc-working-revision vc-annotate-parent-file)))
+ (if (equal warp-rev vc-annotate-parent-rev)
+ (message "Already at revision %s" warp-rev)
+ (vc-annotate-warp-revision warp-rev)))))
+
+(defun vc-annotate-extract-revision-at-line ()
+ "Extract the revision number of the current line.
+Return a cons (REV . FILENAME)."
+ ;; This function must be invoked from a buffer in vc-annotate-mode
+ (let ((rev (vc-call-backend vc-annotate-backend
+ 'annotate-extract-revision-at-line)))
+ (if (or (null rev) (consp rev))
+ rev
+ (cons rev vc-annotate-parent-file))))
+
+(defun vc-annotate-revision-at-line ()
+ "Visit the annotation of the revision identified in the current line."
+ (interactive)
+ (if (not (equal major-mode 'vc-annotate-mode))
+ (message "Cannot be invoked outside of a vc annotate buffer")
+ (let ((rev-at-line (vc-annotate-extract-revision-at-line)))
+ (if (not rev-at-line)
+ (message "Cannot extract revision number from the current line")
+ (if (and (equal (car rev-at-line) vc-annotate-parent-rev)
+ (string= (cdr rev-at-line) vc-annotate-parent-file))
+ (message "Already at revision %s" rev-at-line)
+ (vc-annotate-warp-revision (car rev-at-line) (cdr rev-at-line)))))))
+
+(defun vc-annotate-find-revision-at-line ()
+ "Visit the revision identified in the current line."
+ (interactive)
+ (if (not (equal major-mode 'vc-annotate-mode))
+ (message "Cannot be invoked outside of a vc annotate buffer")
+ (let ((rev-at-line (vc-annotate-extract-revision-at-line)))
+ (if (not rev-at-line)
+ (message "Cannot extract revision number from the current line")
+ (switch-to-buffer-other-window
+ (vc-find-revision (cdr rev-at-line) (car rev-at-line)))))))
+
+(defun vc-annotate-revision-previous-to-line ()
+ "Visit the annotation of the revision before the revision at line."
+ (interactive)
+ (if (not (equal major-mode 'vc-annotate-mode))
+ (message "Cannot be invoked outside of a vc annotate buffer")
+ (let* ((rev-at-line (vc-annotate-extract-revision-at-line))
+ (prev-rev nil)
+ (rev (car rev-at-line))
+ (fname (cdr rev-at-line)))
+ (if (not rev-at-line)
+ (message "Cannot extract revision number from the current line")
+ (setq prev-rev
+ (vc-call-backend vc-annotate-backend 'previous-revision
+ fname rev))
+ (vc-annotate-warp-revision prev-rev fname)))))
+
+(defvar log-view-vc-backend)
+(defvar log-view-vc-fileset)
+
+(defun vc-annotate-show-log-revision-at-line ()
+ "Visit the log of the revision at line.
+If the VC backend supports it, only show the log entry for the revision.
+If a *vc-change-log* buffer exists and already shows a log for
+the file in question, search for the log entry required and move point ."
+ (interactive)
+ (if (not (equal major-mode 'vc-annotate-mode))
+ (message "Cannot be invoked outside of a vc annotate buffer")
+ (let ((rev-at-line (vc-annotate-extract-revision-at-line)))
+ (if (not rev-at-line)
+ (message "Cannot extract revision number from the current line")
+ (let ((backend vc-annotate-backend)
+ (log-buf (get-buffer "*vc-change-log*"))
+ pos)
+ (if (and
+ log-buf
+ ;; Look for a log buffer that already displays the correct file.
+ (with-current-buffer log-buf
+ (and (eq backend log-view-vc-backend)
+ (null (cdr log-view-vc-fileset))
+ (string= (car log-view-vc-fileset) (cdr rev-at-line))
+ ;; Check if the entry we require can be found.
+ (vc-call-backend
+ backend 'show-log-entry (car rev-at-line))
+ (setq pos (point)))))
+ (progn
+ (pop-to-buffer log-buf)
+ (goto-char pos))
+ ;; Ask the backend to display a single log entry.
+ (vc-print-log-internal
+ vc-annotate-backend (list (cdr rev-at-line))
+ (car rev-at-line) t 1)))))))
+
+(defun vc-annotate-show-diff-revision-at-line-internal (filediff)
+ (if (not (equal major-mode 'vc-annotate-mode))
+ (message "Cannot be invoked outside of a vc annotate buffer")
+ (let* ((rev-at-line (vc-annotate-extract-revision-at-line))
+ (prev-rev nil)
+ (rev (car rev-at-line))
+ (fname (cdr rev-at-line)))
+ (if (not rev-at-line)
+ (message "Cannot extract revision number from the current line")
+ (setq prev-rev
+ (vc-call-backend vc-annotate-backend 'previous-revision
+ fname rev))
+ (if (not prev-rev)
+ (message "Cannot diff from any revision prior to %s" rev)
+ (save-window-excursion
+ (vc-diff-internal
+ nil
+ ;; The value passed here should follow what
+ ;; `vc-deduce-fileset' returns.
+ (list vc-annotate-backend
+ (if filediff
+ (list fname)
+ nil))
+ prev-rev rev))
+ (switch-to-buffer "*vc-diff*"))))))
+
+(defun vc-annotate-show-diff-revision-at-line ()
+ "Visit the diff of the revision at line from its previous revision."
+ (interactive)
+ (vc-annotate-show-diff-revision-at-line-internal t))
+
+(defun vc-annotate-show-changeset-diff-revision-at-line ()
+ "Visit the diff of the revision at line from its previous revision for all files in the changeset."
+ (interactive)
+ (when (eq 'file (vc-call-backend vc-annotate-backend 'revision-granularity))
+ (error "The %s backend does not support changeset diffs" vc-annotate-backend))
+ (vc-annotate-show-diff-revision-at-line-internal nil))
+
+(defun vc-annotate-warp-revision (revspec &optional file)
+ "Annotate the revision described by REVSPEC.
+
+If REVSPEC is a positive integer, warp that many revisions forward,
+if possible, otherwise echo a warning message. If REVSPEC is a
+negative integer, warp that many revisions backward, if possible,
+otherwise echo a warning message. If REVSPEC is a string, then it
+describes a revision number, so warp to that revision."
+ (if (not (equal major-mode 'vc-annotate-mode))
+ (message "Cannot be invoked outside of a vc annotate buffer")
+ (let* ((buf (current-buffer))
+ (oldline (line-number-at-pos))
+ (revspeccopy revspec)
+ (newrev nil))
+ (cond
+ ((and (integerp revspec) (> revspec 0))
+ (setq newrev vc-annotate-parent-rev)
+ (while (and (> revspec 0) newrev)
+ (setq newrev (vc-call-backend vc-annotate-backend 'next-revision
+ (or file vc-annotate-parent-file) newrev))
+ (setq revspec (1- revspec)))
+ (unless newrev
+ (message "Cannot increment %d revisions from revision %s"
+ revspeccopy vc-annotate-parent-rev)))
+ ((and (integerp revspec) (< revspec 0))
+ (setq newrev vc-annotate-parent-rev)
+ (while (and (< revspec 0) newrev)
+ (setq newrev (vc-call-backend vc-annotate-backend 'previous-revision
+ (or file vc-annotate-parent-file) newrev))
+ (setq revspec (1+ revspec)))
+ (unless newrev
+ (message "Cannot decrement %d revisions from revision %s"
+ (- 0 revspeccopy) vc-annotate-parent-rev)))
+ ((stringp revspec) (setq newrev revspec))
+ (t (error "Invalid argument to vc-annotate-warp-revision")))
+ (when newrev
+ (vc-annotate (or file vc-annotate-parent-file) newrev
+ vc-annotate-parent-display-mode
+ buf
+ ;; Pass the current line so that vc-annotate will
+ ;; place the point in the line.
+ (min oldline (progn (goto-char (point-max))
+ (forward-line -1)
+ (line-number-at-pos))))))))
+
+(defun vc-annotate-compcar (threshold a-list)
+ "Test successive cons cells of A-LIST against THRESHOLD.
+Return the first cons cell with a car that is not less than THRESHOLD,
+nil if no such cell exists."
+ (let ((i 1)
+ (tmp-cons (car a-list)))
+ (while (and tmp-cons (< (car tmp-cons) threshold))
+ (setq tmp-cons (car (nthcdr i a-list)))
+ (setq i (+ i 1)))
+ tmp-cons)) ; Return the appropriate value
+
+(defun vc-annotate-convert-time (time)
+ "Convert a time value to a floating-point number of days.
+The argument TIME is a list as returned by `current-time' or
+`encode-time', only the first two elements of that list are considered."
+ (/ (+ (* (float (car time)) (lsh 1 16)) (cadr time)) 24 3600))
+
+(defun vc-annotate-difference (&optional offset)
+ "Return the time span in days to the next annotation.
+This calls the backend function annotate-time, and returns the
+difference in days between the time returned and the current time,
+or OFFSET if present."
+ (let ((next-time (vc-annotate-get-time-set-line-props)))
+ (when next-time
+ (- (or offset
+ (vc-call-backend vc-annotate-backend 'annotate-current-time))
+ next-time))))
+
+(defun vc-default-annotate-current-time (backend)
+ "Return the current time, encoded as fractional days."
+ (vc-annotate-convert-time (current-time)))
+
+(defvar vc-annotate-offset nil)
+
+(defun vc-annotate-display (ratio &optional offset)
+ "Highlight `vc-annotate' output in the current buffer.
+RATIO is the expansion that should be applied to `vc-annotate-color-map'.
+The annotations are relative to the current time, unless overridden by OFFSET."
+ (when (/= ratio 1.0)
+ (set (make-local-variable 'vc-annotate-color-map)
+ (mapcar (lambda (elem) (cons (* (car elem) ratio) (cdr elem)))
+ vc-annotate-color-map)))
+ (set (make-local-variable 'vc-annotate-offset) offset)
+ (font-lock-mode 1))
+
+(defun vc-annotate-lines (limit)
+ (while (< (point) limit)
+ (let ((difference (vc-annotate-difference vc-annotate-offset))
+ (start (point))
+ (end (progn (forward-line 1) (point))))
+ (when difference
+ (let* ((color (or (vc-annotate-compcar difference vc-annotate-color-map)
+ (cons nil vc-annotate-very-old-color)))
+ ;; substring from index 1 to remove any leading `#' in the name
+ (face-name (concat "vc-annotate-face-"
+ (if (string-equal
+ (substring (cdr color) 0 1) "#")
+ (substring (cdr color) 1)
+ (cdr color))))
+ ;; Make the face if not done.
+ (face (or (intern-soft face-name)
+ (let ((tmp-face (make-face (intern face-name))))
+ (set-face-foreground tmp-face (cdr color))
+ (when vc-annotate-background
+ (set-face-background tmp-face
+ vc-annotate-background))
+ tmp-face)))) ; Return the face
+ (put-text-property start end 'face face)))))
+ ;; Pretend to font-lock there were no matches.
+ nil)
+
+(provide 'vc-annotate)
+
+;; arch-tag: c3454a89-80e5-4ffd-8993-671b59612898
+;;; vc-annotate.el ends here
--- /dev/null
+;;; vc-arch.el --- VC backend for the Arch version-control system
+
+;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Stefan Monnier <monnier@gnu.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The home page of the Arch version control system is at
+;;
+;; http://www.gnuarch.org/
+;;
+;; This is derived from vc-mcvs.el as follows:
+;; - cp vc-mcvs.el vc-arch.el and then M-% mcvs RET arch RET
+;;
+;; Then of course started the hacking.
+;;
+;; What has been partly tested:
+;; - Open a file.
+;; - C-x v = without any prefix arg.
+;; - C-x v v to commit a change to a single file.
+
+;; Bugs:
+
+;; - *VC-log*'s initial content lacks the `Summary:' lines.
+;; - All files under the tree are considered as "under Arch's control"
+;; without regards to =tagging-method and such.
+;; - Files are always considered as `edited'.
+;; - C-x v l does not work.
+;; - C-x v i does not work.
+;; - C-x v ~ does not work.
+;; - C-x v u does not work.
+;; - C-x v s does not work.
+;; - C-x v r does not work.
+;; - VC directory listings do not work.
+;; - And more...
+
+;;; Code:
+
+(eval-when-compile (require 'vc) (require 'cl))
+
+;;; Properties of the backend
+
+(defun vc-arch-revision-granularity () 'repository)
+(defun vc-arch-checkout-model (files) 'implicit)
+
+;;;
+;;; Customization options
+;;;
+
+;; It seems Arch diff does not accept many options, so this is not
+;; very useful. It exists mainly so that the VC backends are all
+;; consistent with regards to their treatment of diff switches.
+(defcustom vc-arch-diff-switches t
+ "String or list of strings specifying switches for Arch diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "23.1"
+ :group 'vc)
+
+(define-obsolete-variable-alias 'vc-arch-command 'vc-arch-program "23.1")
+
+(defcustom vc-arch-program
+ (let ((candidates '("tla" "baz")))
+ (while (and candidates (not (executable-find (car candidates))))
+ (setq candidates (cdr candidates)))
+ (or (car candidates) "tla"))
+ "Name of the Arch executable."
+ :type 'string
+ :group 'vc)
+
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'Arch 'vc-functions nil)
+
+;;;###autoload (defun vc-arch-registered (file)
+;;;###autoload (if (vc-find-root file "{arch}/=tagging-method")
+;;;###autoload (progn
+;;;###autoload (load "vc-arch")
+;;;###autoload (vc-arch-registered file))))
+
+(defun vc-arch-add-tagline ()
+ "Add an `arch-tag' to the end of the current file."
+ (interactive)
+ (comment-normalize-vars)
+ (goto-char (point-max))
+ (forward-comment -1)
+ (skip-chars-forward " \t\n")
+ (cond
+ ((not (bolp)) (insert "\n\n"))
+ ((not (eq ?\n (char-before (1- (point))))) (insert "\n")))
+ (let ((beg (point))
+ (idfile (and buffer-file-name
+ (expand-file-name
+ (concat ".arch-ids/"
+ (file-name-nondirectory buffer-file-name)
+ ".id")
+ (file-name-directory buffer-file-name)))))
+ (insert "arch-tag: ")
+ (if (and idfile (file-exists-p idfile))
+ ;; If the file is unreadable, we do want to get an error here.
+ (progn
+ (insert-file-contents idfile)
+ (forward-line 1)
+ (delete-file idfile))
+ (condition-case nil
+ (call-process "uuidgen" nil t)
+ (file-error (insert (format "%s <%s> %s"
+ (current-time-string)
+ user-mail-address
+ (+ (nth 2 (current-time))
+ (buffer-size)))))))
+ (comment-region beg (point))))
+
+(defconst vc-arch-tagline-re "^\\W*arch-tag:[ \t]*\\(.*[^ \t\n]\\)")
+
+(defmacro vc-with-current-file-buffer (file &rest body)
+ (declare (indent 2) (debug t))
+ `(let ((-kill-buf- nil)
+ (-file- ,file))
+ (with-current-buffer (or (find-buffer-visiting -file-)
+ (setq -kill-buf- (generate-new-buffer " temp")))
+ ;; Avoid find-file-literally since it can do many undesirable extra
+ ;; things (among which, call us back into an infinite loop).
+ (if -kill-buf- (insert-file-contents -file-))
+ (unwind-protect
+ (progn ,@body)
+ (if (buffer-live-p -kill-buf-) (kill-buffer -kill-buf-))))))
+
+(defun vc-arch-file-source-p (file)
+ "Can return nil, `maybe' or a non-nil value.
+Only the value `maybe' can be trusted :-(."
+ ;; FIXME: Check the tag and name of parent dirs.
+ (unless (string-match "\\`[,+]" (file-name-nondirectory file))
+ (or (string-match "\\`{arch}/"
+ (file-relative-name file (vc-arch-root file)))
+ (file-exists-p
+ ;; Check the presence of an ID file.
+ (expand-file-name
+ (concat ".arch-ids/" (file-name-nondirectory file) ".id")
+ (file-name-directory file)))
+ ;; Check the presence of a tagline.
+ (vc-with-current-file-buffer file
+ (save-excursion
+ (goto-char (point-max))
+ (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t)
+ (progn
+ (goto-char (point-min))
+ (re-search-forward vc-arch-tagline-re (+ (point) 1000) t)))))
+ ;; FIXME: check =tagging-method to see whether untagged files might
+ ;; be source or not.
+ (with-current-buffer
+ (find-file-noselect (expand-file-name "{arch}/=tagging-method"
+ (vc-arch-root file)))
+ (let ((untagged-source t)) ;Default is `names'.
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward "^[ \t]*\\(\\(tagline\\|implicit\\|names\\)\\|explicit\\)" nil t)
+ (setq untagged-source (match-end 2)))
+ (if (re-search-forward "^[ \t]*untagged-source[ \t]+\\(\\(source\\)\\|precious\\|backup\\|junk\\|unrecognized\\)" nil t)
+ (setq untagged-source (match-end 2))))
+ (if untagged-source 'maybe))))))
+
+(defun vc-arch-file-id (file)
+ ;; Don't include the kind of ID this is because it seems to be too messy.
+ (let ((idfile (expand-file-name
+ (concat ".arch-ids/" (file-name-nondirectory file) ".id")
+ (file-name-directory file))))
+ (if (file-exists-p idfile)
+ (with-temp-buffer
+ (insert-file-contents idfile)
+ (looking-at ".*[^ \n\t]")
+ (match-string 0))
+ (with-current-buffer (find-file-noselect file)
+ (save-excursion
+ (goto-char (point-max))
+ (if (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t)
+ (progn
+ (goto-char (point-min))
+ (re-search-forward vc-arch-tagline-re (+ (point) 1000) t)))
+ (match-string 1)
+ (concat "./" (file-relative-name file (vc-arch-root file)))))))))
+
+(defun vc-arch-tagging-method (file)
+ (with-current-buffer
+ (find-file-noselect
+ (expand-file-name "{arch}/=tagging-method" (vc-arch-root file)))
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward
+ "^[ \t]*\\(tagline\\|implicit\\|names\\|explicit\\)" nil t)
+ (intern (match-string 1))
+ 'names))))
+
+(defun vc-arch-root (file)
+ "Return the root directory of an Arch project, if any."
+ (or (vc-file-getprop file 'arch-root)
+ ;; Check the =tagging-method, in case someone naively manually
+ ;; creates a {arch} directory somewhere.
+ (let ((root (vc-find-root file "{arch}/=tagging-method")))
+ (when root
+ (vc-file-setprop
+ file 'arch-root root)))))
+
+(defun vc-arch-register (files &optional rev comment)
+ (if rev (error "Explicit initial revision not supported for Arch"))
+ (dolist (file files)
+ (let ((tagmet (vc-arch-tagging-method file)))
+ (if (and (memq tagmet '(tagline implicit)) comment-start)
+ (with-current-buffer (find-file-noselect file)
+ (if (buffer-modified-p)
+ (error "Save %s first" (buffer-name)))
+ (vc-arch-add-tagline)
+ (save-buffer)))))
+ (vc-arch-command nil 0 files "add"))
+
+(defun vc-arch-registered (file)
+ ;; Don't seriously check whether it's source or not. Checking would
+ ;; require running TLA, so it's better to not do it, so it also works if
+ ;; TLA is not installed.
+ (and (vc-arch-root file)
+ (vc-arch-file-source-p file)))
+
+(defun vc-arch-default-version (file)
+ (or (vc-file-getprop (vc-arch-root file) 'arch-default-version)
+ (let* ((root (vc-arch-root file))
+ (f (expand-file-name "{arch}/++default-version" root)))
+ (if (file-readable-p f)
+ (vc-file-setprop
+ root 'arch-default-version
+ (with-temp-buffer
+ (insert-file-contents f)
+ ;; Strip the terminating newline.
+ (buffer-substring (point-min) (1- (point-max)))))))))
+
+(defun vc-arch-workfile-unchanged-p (file)
+ "Stub: arch workfiles are always considered to be in a changed state,"
+ nil)
+
+(defun vc-arch-state (file)
+ ;; There's no checkout operation and merging is not done from VC
+ ;; so the only operation that's state dependent that VC supports is commit
+ ;; which is only activated if the file is `edited'.
+ (let* ((root (vc-arch-root file))
+ (ver (vc-arch-default-version file))
+ (pat (concat "\\`" (subst-char-in-string ?/ ?% ver)))
+ (dir (expand-file-name ",,inode-sigs/"
+ (expand-file-name "{arch}" root)))
+ (sigfile nil))
+ (dolist (f (if (file-directory-p dir) (directory-files dir t pat)))
+ (if (or (not sigfile) (file-newer-than-file-p f sigfile))
+ (setq sigfile f)))
+ (if (not sigfile)
+ 'edited ;We know nothing.
+ (let ((id (vc-arch-file-id file)))
+ (setq id (replace-regexp-in-string "[ \t]" "_" id))
+ (with-current-buffer (find-file-noselect sigfile)
+ (goto-char (point-min))
+ (while (and (search-forward id nil 'move)
+ (save-excursion
+ (goto-char (- (match-beginning 0) 2))
+ ;; For `names', the lines start with `?./foo/bar'.
+ ;; For others there's 2 chars before the ./foo/bar.
+ (or (not (or (bolp) (looking-at "\n?")))
+ ;; Ignore E_ entries used for foo.id files.
+ (looking-at "E_")))))
+ (if (eobp)
+ ;; ID not found.
+ (if (equal (file-name-nondirectory sigfile)
+ (subst-char-in-string
+ ?/ ?% (vc-arch-working-revision file)))
+ 'added
+ ;; Might be `added' or `up-to-date' as well.
+ ;; FIXME: Check in the patch logs to find out.
+ 'edited)
+ ;; Found the ID, let's check the inode.
+ (if (not (re-search-forward
+ "\t.*mtime=\\([0-9]+\\):size=\\([0-9]+\\)"
+ (line-end-position) t))
+ ;; Buh? Unexpected format.
+ 'edited
+ (let ((ats (file-attributes file)))
+ (if (and (eq (nth 7 ats) (string-to-number (match-string 2)))
+ (equal (format-time-string "%s" (nth 5 ats))
+ (match-string 1)))
+ 'up-to-date
+ 'edited)))))))))
+
+(defun vc-arch-dir-status (dir callback)
+ "Run 'tla inventory' for DIR and pass results to CALLBACK.
+CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
+`vc-dir-refresh'."
+ (let ((default-directory dir))
+ (vc-arch-command t 'async nil "changes"))
+ ;; The updating could be done asynchronously.
+ (vc-exec-after
+ `(vc-arch-after-dir-status ',callback)))
+
+(defun vc-arch-after-dir-status (callback)
+ (let* ((state-map '(("M " . edited)
+ ("Mb" . edited) ;binary
+ ("D " . removed)
+ ("D/" . removed) ;directory
+ ("A " . added)
+ ("A/" . added) ;directory
+ ("=>" . renamed)
+ ("/>" . renamed) ;directory
+ ("lf" . symlink-to-file)
+ ("fl" . file-to-symlink)
+ ("--" . permissions-changed)
+ ("-/" . permissions-changed) ;directory
+ ))
+ (state-map-regexp (regexp-opt (mapcar 'car state-map) t))
+ (entry-regexp (concat "^" state-map-regexp " \\(.*\\)$"))
+ result)
+ (goto-char (point-min))
+ ;;(message "Got %s" (buffer-string))
+ (while (re-search-forward entry-regexp nil t)
+ (let* ((state-string (match-string 1))
+ (state (cdr (assoc state-string state-map)))
+ (filename (match-string 2)))
+ (push (list filename state) result)))
+
+ (funcall callback result nil)))
+
+(defun vc-arch-working-revision (file)
+ (let* ((root (expand-file-name "{arch}" (vc-arch-root file)))
+ (defbranch (vc-arch-default-version file)))
+ (when (and defbranch (string-match "\\`\\(.+@[^/\n]+\\)/\\(\\(\\(.*?\\)\\(?:--.*\\)?\\)--.*\\)\\'" defbranch))
+ (let* ((archive (match-string 1 defbranch))
+ (category (match-string 4 defbranch))
+ (branch (match-string 3 defbranch))
+ (version (match-string 2 defbranch))
+ (sealed nil) (rev-nb 0)
+ (rev nil)
+ logdir tmp)
+ (setq logdir (expand-file-name category root))
+ (setq logdir (expand-file-name branch logdir))
+ (setq logdir (expand-file-name version logdir))
+ (setq logdir (expand-file-name archive logdir))
+ (setq logdir (expand-file-name "patch-log" logdir))
+ (dolist (file (if (file-directory-p logdir) (directory-files logdir)))
+ ;; Revision names go: base-0, patch-N, version-0, versionfix-M.
+ (when (and (eq (aref file 0) ?v) (not sealed))
+ (setq sealed t rev-nb 0))
+ (if (and (string-match "-\\([0-9]+\\)\\'" file)
+ (setq tmp (string-to-number (match-string 1 file)))
+ (or (not sealed) (eq (aref file 0) ?v))
+ (>= tmp rev-nb))
+ (setq rev-nb tmp rev file)))
+ ;; Use "none-000" if the tree hasn't yet been committed on the
+ ;; default branch. We'll then get "Arch:000[branch]" on the mode-line.
+ (concat defbranch "--" (or rev "none-000"))))))
+
+
+(defcustom vc-arch-mode-line-rewrite
+ '(("\\`.*--\\(.*--.*\\)--\\(v?\\).*-\\([0-9]+\\)\\'" . "\\2\\3[\\1]"))
+ "Rewrite rules to shorten Arch's revision names on the mode-line."
+ :type '(repeat (cons regexp string))
+ :group 'vc)
+
+(defun vc-arch-mode-line-string (file)
+ "Return string for placement in modeline by `vc-mode-line' for FILE."
+ (let ((rev (vc-working-revision file)))
+ (dolist (rule vc-arch-mode-line-rewrite)
+ (if (string-match (car rule) rev)
+ (setq rev (replace-match (cdr rule) t nil rev))))
+ (format "Arch%c%s"
+ (case (vc-state file)
+ ((up-to-date needs-update) ?-)
+ (added ?@)
+ (t ?:))
+ rev)))
+
+(defun vc-arch-diff3-rej-p (rej)
+ (let ((attrs (file-attributes rej)))
+ (and attrs (< (nth 7 attrs) 60)
+ (with-temp-buffer
+ (insert-file-contents rej)
+ (goto-char (point-min))
+ (looking-at "Conflicts occured, diff3 conflict markers left in file\\.")))))
+
+(defun vc-arch-delete-rej-if-obsolete ()
+ "For use in `after-save-hook'."
+ (save-excursion
+ (let ((rej (concat buffer-file-name ".rej")))
+ (when (and buffer-file-name (vc-arch-diff3-rej-p rej))
+ (unless (re-search-forward "^<<<<<<< " nil t)
+ ;; The .rej file is obsolete.
+ (condition-case nil (delete-file rej) (error nil))
+ ;; Remove the hook so that it is not called multiple times.
+ (remove-hook 'after-save-hook 'vc-arch-delete-rej-if-obsolete t))))))
+
+(defun vc-arch-find-file-hook ()
+ (let ((rej (concat buffer-file-name ".rej")))
+ (when (and buffer-file-name (file-exists-p rej))
+ (if (vc-arch-diff3-rej-p rej)
+ (save-excursion
+ (goto-char (point-min))
+ (if (not (re-search-forward "^<<<<<<< " nil t))
+ ;; The .rej file is obsolete.
+ (condition-case nil (delete-file rej) (error nil))
+ (smerge-mode 1)
+ (add-hook 'after-save-hook
+ 'vc-arch-delete-rej-if-obsolete nil t)
+ (message "There are unresolved conflicts in this file")))
+ (message "There are unresolved conflicts in %s"
+ (file-name-nondirectory rej))))))
+
+(defun vc-arch-checkin (files rev comment &optional extra-args-ignored)
+ (if rev (error "Committing to a specific revision is unsupported"))
+ ;; FIXME: This implementation probably only works for singleton filesets
+ (let ((summary (file-relative-name (car files) (vc-arch-root (car files)))))
+ ;; Extract a summary from the comment.
+ (when (or (string-match "\\`Summary:[ \t]*\\(.*[^ \t\n]\\)\\([ \t]*\n\\)*" comment)
+ (string-match "\\`[ \t]*\\(.*[^ \t\n]\\)[ \t]*\\(\n?\\'\\|\n\\([ \t]*\n\\)+\\)" comment))
+ (setq summary (match-string 1 comment))
+ (setq comment (substring comment (match-end 0))))
+ (vc-arch-command nil 0 files "commit" "-s" summary "-L" comment "--"
+ (vc-switches 'Arch 'checkin))))
+
+(defun vc-arch-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using Arch between two versions of FILES."
+ ;; FIXME: This implementation only works for singleton filesets. To make
+ ;; it work for more cases, we have to either call `file-diffs' manually on
+ ;; each and every `file' in the fileset, or use `changes --diffs' (and
+ ;; variants) and maybe filter the output with `filterdiff' to only include
+ ;; the files in which we're interested.
+ (let ((file (car files)))
+ (if (and newvers
+ (vc-up-to-date-p file)
+ (equal newvers (vc-working-revision file)))
+ ;; Newvers is the base revision and the current file is unchanged,
+ ;; so we can diff with the current file.
+ (setq newvers nil))
+ (if newvers
+ (error "Diffing specific revisions not implemented")
+ (let* (process-file-side-effects
+ (async (not vc-disable-async-diff))
+ ;; Run the command from the root dir.
+ (default-directory (vc-arch-root file))
+ (status
+ (vc-arch-command
+ (or buffer "*vc-diff*")
+ (if async 'async 1)
+ nil "file-diffs"
+ (vc-switches 'Arch 'diff)
+ (file-relative-name file)
+ (if (equal oldvers (vc-working-revision file))
+ nil
+ oldvers))))
+ (if async 1 status))))) ; async diff, pessimistic assumption.
+
+(defun vc-arch-delete-file (file)
+ (vc-arch-command nil 0 file "rm"))
+
+(defun vc-arch-rename-file (old new)
+ (vc-arch-command nil 0 new "mv" (file-relative-name old)))
+
+(defalias 'vc-arch-responsible-p 'vc-arch-root)
+
+(defun vc-arch-command (buffer okstatus file &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-arch.el."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus vc-arch-program file flags))
+
+(defun vc-arch-init-revision () nil)
+
+;;; Completion of versions and revisions.
+
+(defun vc-arch--version-completion-table (root string)
+ (delq nil
+ (mapcar
+ (lambda (d)
+ (when (string-match "/\\([^/]+\\)/\\([^/]+\\)\\'" d)
+ (concat (match-string 2 d) "/" (match-string 1 d))))
+ (let ((default-directory root))
+ (file-expand-wildcards
+ (concat "*/*/"
+ (if (string-match "/" string)
+ (concat (substring string (match-end 0))
+ "*/" (substring string 0 (match-beginning 0)))
+ (concat "*/" string))
+ "*"))))))
+
+(defun vc-arch-revision-completion-table (files)
+ (lexical-let ((files files))
+ (lambda (string pred action)
+ ;; FIXME: complete revision patches as well.
+ (let* ((root (expand-file-name "{arch}" (vc-arch-root (car files))))
+ (table (vc-arch--version-completion-table root string)))
+ (complete-with-action action table string pred)))))
+
+;;; Trimming revision libraries.
+
+;; This code is not directly related to VC and there are many variants of
+;; this functionality available as scripts, but I like this version better,
+;; so maybe others will like it too.
+
+(defun vc-arch-trim-find-least-useful-rev (revs)
+ (let* ((first (pop revs))
+ (second (pop revs))
+ (third (pop revs))
+ ;; We try to give more importance to recent revisions. The idea is
+ ;; that it's OK if checking out a revision 1000-patch-old is ten
+ ;; times slower than checking out a revision 100-patch-old. But at
+ ;; the same time a 2-patch-old rev isn't really ten times more
+ ;; important than a 20-patch-old, so we use an arbitrary constant
+ ;; "100" to reduce this effect for recent revisions. Making this
+ ;; constant a float has the side effect of causing the subsequent
+ ;; computations to be done as floats as well.
+ (max (+ 100.0 (car (or (car (last revs)) third))))
+ (cost (lambda () (/ (- (car third) (car first)) (- max (car second)))))
+ (minrev second)
+ (mincost (funcall cost)))
+ (while revs
+ (setq first second)
+ (setq second third)
+ (setq third (pop revs))
+ (when (< (funcall cost) mincost)
+ (setq minrev second)
+ (setq mincost (funcall cost))))
+ minrev))
+
+(defun vc-arch-trim-make-sentinel (revs)
+ (if (null revs) (lambda (proc msg) (message "VC-Arch trimming ... done"))
+ (lexical-let ((revs revs))
+ (lambda (proc msg)
+ (message "VC-Arch trimming %s..." (file-name-nondirectory (car revs)))
+ (rename-file (car revs) (concat (car revs) "*rm*"))
+ (setq proc (start-process "vc-arch-trim" nil
+ "rm" "-rf" (concat (car revs) "*rm*")))
+ (set-process-sentinel proc (vc-arch-trim-make-sentinel (cdr revs)))))))
+
+(defun vc-arch-trim-one-revlib (dir)
+ "Delete half of the revisions in the revision library."
+ (interactive "Ddirectory: ")
+ (let ((garbage (directory-files dir 'full "\\`,," 'nosort)))
+ (when garbage
+ (funcall (vc-arch-trim-make-sentinel garbage) nil nil)))
+ (let ((revs
+ (sort (delq nil
+ (mapcar
+ (lambda (f)
+ (when (string-match "-\\([0-9]+\\)\\'" f)
+ (cons (string-to-number (match-string 1 f)) f)))
+ (directory-files dir nil nil 'nosort)))
+ 'car-less-than-car))
+ (subdirs nil))
+ (when (cddr revs)
+ (dotimes (i (/ (length revs) 2))
+ (let ((minrev (vc-arch-trim-find-least-useful-rev revs)))
+ (setq revs (delq minrev revs))
+ (push minrev subdirs)))
+ (funcall (vc-arch-trim-make-sentinel
+ (mapcar (lambda (x) (expand-file-name (cdr x) dir)) subdirs))
+ nil nil))))
+
+(defun vc-arch-trim-revlib ()
+ "Delete half of the revisions in the revision library."
+ (interactive)
+ (let ((rl-dir (with-output-to-string
+ (call-process vc-arch-program nil standard-output nil
+ "my-revision-library"))))
+ (while (string-match "\\(.*\\)\n" rl-dir)
+ (let ((dir (match-string 1 rl-dir)))
+ (setq rl-dir
+ (if (and (file-directory-p dir) (file-writable-p dir))
+ dir
+ (substring rl-dir (match-end 0))))))
+ (unless (file-writable-p rl-dir)
+ (error "No writable revlib directory found"))
+ (message "Revlib at %s" rl-dir)
+ (let* ((archives (directory-files rl-dir 'full "[^.]\\|..."))
+ (categories
+ (apply 'append
+ (mapcar (lambda (dir)
+ (when (file-directory-p dir)
+ (directory-files dir 'full "[^.]\\|...")))
+ archives)))
+ (branches
+ (apply 'append
+ (mapcar (lambda (dir)
+ (when (file-directory-p dir)
+ (directory-files dir 'full "[^.]\\|...")))
+ categories)))
+ (versions
+ (apply 'append
+ (mapcar (lambda (dir)
+ (when (file-directory-p dir)
+ (directory-files dir 'full "--.*--")))
+ branches))))
+ (mapc 'vc-arch-trim-one-revlib versions))
+ ))
+
+(defvar vc-arch-extra-menu-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [add-tagline]
+ '(menu-item "Add tagline" vc-arch-add-tagline))
+ map))
+
+(defun vc-arch-extra-menu () vc-arch-extra-menu-map)
+
+
+;;; Less obvious implementations.
+
+(defun vc-arch-find-revision (file rev buffer)
+ (let ((out (make-temp-file "vc-out")))
+ (unwind-protect
+ (progn
+ (with-temp-buffer
+ (vc-arch-command (current-buffer) 1 nil "file-diffs" file rev)
+ (call-process-region (point-min) (point-max)
+ "patch" nil nil nil "-R" "-o" out file))
+ (with-current-buffer buffer
+ (insert-file-contents out)))
+ (delete-file out))))
+
+(provide 'vc-arch)
+
+;; arch-tag: a35c7c1c-5237-429d-88ef-3d718fd2e704
+;;; vc-arch.el ends here
--- /dev/null
+;;; vc-bzr.el --- VC backend for the bzr revision control system
+
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Dave Love <fx@gnu.org>
+;; Riccardo Murri <riccardo.murri@gmail.com>
+;; Keywords: tools
+;; Created: Sept 2006
+;; Version: 2008-01-04 (Bzr revno 25)
+;; URL: http://launchpad.net/vc-bzr
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; See <URL:http://bazaar-vcs.org/> concerning bzr. See
+;; <URL:http://launchpad.net/vc-bzr> for alternate development
+;; branches of `vc-bzr'.
+
+;; Load this library to register bzr support in VC.
+
+;; Known bugs
+;; ==========
+
+;; When editing a symlink and *both* the symlink and its target
+;; are bzr-versioned, `vc-bzr` presently runs `bzr status` on the
+;; symlink, thereby not detecting whether the actual contents
+;; (that is, the target contents) are changed.
+;; See https://bugs.launchpad.net/vc-bzr/+bug/116607
+
+;; For an up-to-date list of bugs, please see:
+;; https://bugs.launchpad.net/vc-bzr/+bugs
+
+;;; Properties of the backend
+
+(defun vc-bzr-revision-granularity () 'repository)
+(defun vc-bzr-checkout-model (files) 'implicit)
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl)
+ (require 'vc) ;; for vc-exec-after
+ (require 'vc-dir))
+
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'Bzr 'vc-functions nil)
+
+(defgroup vc-bzr nil
+ "VC bzr backend."
+ :version "22.2"
+ :group 'vc)
+
+(defcustom vc-bzr-program "bzr"
+ "Name of the bzr command (excluding any arguments)."
+ :group 'vc-bzr
+ :type 'string)
+
+(defcustom vc-bzr-diff-switches nil
+ "String or list of strings specifying switches for bzr diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :group 'vc-bzr)
+
+(defcustom vc-bzr-log-switches nil
+ "String or list of strings specifying switches for bzr log under VC."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :group 'vc-bzr)
+
+;; since v0.9, bzr supports removing the progress indicators
+;; by setting environment variable BZR_PROGRESS_BAR to "none".
+(defun vc-bzr-command (bzr-command buffer okstatus file-or-list &rest args)
+ "Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND.
+Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
+`LC_MESSAGES=C' to the environment."
+ (let ((process-environment
+ (list* "BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9)
+ "LC_MESSAGES=C" ; Force English output
+ process-environment)))
+ (apply 'vc-do-command (or buffer "*vc*") okstatus vc-bzr-program
+ file-or-list bzr-command args)))
+
+
+;;;###autoload
+(defconst vc-bzr-admin-dirname ".bzr"
+ "Name of the directory containing Bzr repository status files.")
+;;;###autoload
+(defconst vc-bzr-admin-checkout-format-file
+ (concat vc-bzr-admin-dirname "/checkout/format"))
+(defconst vc-bzr-admin-dirstate
+ (concat vc-bzr-admin-dirname "/checkout/dirstate"))
+(defconst vc-bzr-admin-branch-format-file
+ (concat vc-bzr-admin-dirname "/branch/format"))
+(defconst vc-bzr-admin-revhistory
+ (concat vc-bzr-admin-dirname "/branch/revision-history"))
+(defconst vc-bzr-admin-lastrev
+ (concat vc-bzr-admin-dirname "/branch/last-revision"))
+
+;;;###autoload (defun vc-bzr-registered (file)
+;;;###autoload (if (vc-find-root file vc-bzr-admin-checkout-format-file)
+;;;###autoload (progn
+;;;###autoload (load "vc-bzr")
+;;;###autoload (vc-bzr-registered file))))
+
+(defun vc-bzr-root (file)
+ "Return the root directory of the bzr repository containing FILE."
+ ;; Cache technique copied from vc-arch.el.
+ (or (vc-file-getprop file 'bzr-root)
+ (let ((root (vc-find-root file vc-bzr-admin-checkout-format-file)))
+ (when root (vc-file-setprop file 'bzr-root root)))))
+
+(require 'sha1) ;For sha1-program
+
+(defun vc-bzr-sha1 (file)
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (let ((prog sha1-program)
+ (args nil)
+ process-file-side-effects)
+ (when (consp prog)
+ (setq args (cdr prog))
+ (setq prog (car prog)))
+ (apply 'process-file prog (file-relative-name file) t nil args)
+ (buffer-substring (point-min) (+ (point-min) 40)))))
+
+(defun vc-bzr-state-heuristic (file)
+ "Like `vc-bzr-state' but hopefully without running Bzr."
+ ;; `bzr status' was excrutiatingly slow with large histories and
+ ;; pending merges, so try to avoid using it until they fix their
+ ;; performance problems.
+ ;; This function tries first to parse Bzr internal file
+ ;; `checkout/dirstate', but it may fail if Bzr internal file format
+ ;; has changed. As a safeguard, the `checkout/dirstate' file is
+ ;; only parsed if it contains the string `#bazaar dirstate flat
+ ;; format 3' in the first line.
+ ;; If the `checkout/dirstate' file cannot be parsed, fall back to
+ ;; running `vc-bzr-state'."
+ (lexical-let ((root (vc-bzr-root file)))
+ (when root ; Short cut.
+ ;; This looks at internal files. May break if they change
+ ;; their format.
+ (lexical-let ((dirstate (expand-file-name vc-bzr-admin-dirstate root)))
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents dirstate)
+ (goto-char (point-min))
+ (if (not (looking-at "#bazaar dirstate flat format 3"))
+ (vc-bzr-state file) ; Some other unknown format?
+ (let* ((relfile (file-relative-name file root))
+ (reldir (file-name-directory relfile)))
+ (if (re-search-forward
+ (concat "^\0"
+ (if reldir (regexp-quote
+ (directory-file-name reldir)))
+ "\0"
+ (regexp-quote (file-name-nondirectory relfile))
+ "\0"
+ "[^\0]*\0" ;id?
+ "\\([^\0]*\\)\0" ;"a/f/d", a=removed?
+ "\\([^\0]*\\)\0" ;sha1 (empty if conflicted)?
+ "\\([^\0]*\\)\0" ;size?p
+ "[^\0]*\0" ;"y/n", executable?
+ "[^\0]*\0" ;?
+ "\\([^\0]*\\)\0" ;"a/f/d" a=added?
+ "\\([^\0]*\\)\0" ;sha1 again?
+ "\\([^\0]*\\)\0" ;size again?
+ "[^\0]*\0" ;"y/n", executable again?
+ "[^\0]*\0" ;last revid?
+ ;; There are more fields when merges are pending.
+ )
+ nil t)
+ ;; Apparently the second sha1 is the one we want: when
+ ;; there's a conflict, the first sha1 is absent (and the
+ ;; first size seems to correspond to the file with
+ ;; conflict markers).
+ (cond
+ ((eq (char-after (match-beginning 1)) ?a) 'removed)
+ ((eq (char-after (match-beginning 4)) ?a) 'added)
+ ((or (and (eq (string-to-number (match-string 3))
+ (nth 7 (file-attributes file)))
+ (equal (match-string 5)
+ (vc-bzr-sha1 file)))
+ (and
+ ;; It looks like for lightweight
+ ;; checkouts \2 is empty and we need to
+ ;; look for size in \6.
+ (eq (match-beginning 2) (match-end 2))
+ (eq (string-to-number (match-string 6))
+ (nth 7 (file-attributes file)))
+ (equal (match-string 5)
+ (vc-bzr-sha1 file))))
+ 'up-to-date)
+ (t 'edited))
+ 'unregistered))))
+ ;; Either the dirstate file can't be read, or the sha1
+ ;; executable is missing, or ...
+ ;; In either case, recent versions of Bzr aren't that slow
+ ;; any more.
+ (error (vc-bzr-state file)))))))
+
+
+(defun vc-bzr-registered (file)
+ "Return non-nil if FILE is registered with bzr."
+ (let ((state (vc-bzr-state-heuristic file)))
+ (not (memq state '(nil unregistered ignored)))))
+
+(defconst vc-bzr-state-words
+ "added\\|ignored\\|kind changed\\|modified\\|removed\\|renamed\\|unknown"
+ "Regexp matching file status words as reported in `bzr' output.")
+
+(defun vc-bzr-file-name-relative (filename)
+ "Return file name FILENAME stripped of the initial Bzr repository path."
+ (lexical-let*
+ ((filename* (expand-file-name filename))
+ (rootdir (vc-bzr-root filename*)))
+ (when rootdir
+ (file-relative-name filename* rootdir))))
+
+(defun vc-bzr-status (file)
+ "Return FILE status according to Bzr.
+Return value is a cons (STATUS . WARNING), where WARNING is a
+string or nil, and STATUS is one of the symbols: `added',
+`ignored', `kindchanged', `modified', `removed', `renamed', `unknown',
+which directly correspond to `bzr status' output, or 'unchanged
+for files whose copy in the working tree is identical to the one
+in the branch repository, or nil for files that are not
+registered with Bzr.
+
+If any error occurred in running `bzr status', then return nil."
+ (with-temp-buffer
+ (let ((ret (condition-case nil
+ (vc-bzr-command "status" t 0 file)
+ (file-error nil))) ; vc-bzr-program not found.
+ (status 'unchanged))
+ ;; the only secure status indication in `bzr status' output
+ ;; is a couple of lines following the pattern::
+ ;; | <status>:
+ ;; | <file name>
+ ;; if the file is up-to-date, we get no status report from `bzr',
+ ;; so if the regexp search for the above pattern fails, we consider
+ ;; the file to be up-to-date.
+ (goto-char (point-min))
+ (when (re-search-forward
+ ;; bzr prints paths relative to the repository root.
+ (concat "^\\(" vc-bzr-state-words "\\):[ \t\n]+"
+ (regexp-quote (vc-bzr-file-name-relative file))
+ ;; Bzr appends a '/' to directory names and
+ ;; '*' to executable files
+ (if (file-directory-p file) "/?" "\\*?")
+ "[ \t\n]*$")
+ nil t)
+ (lexical-let ((statusword (match-string 1)))
+ ;; Erase the status text that matched.
+ (delete-region (match-beginning 0) (match-end 0))
+ (setq status
+ (intern (replace-regexp-in-string " " "" statusword)))))
+ (when status
+ (goto-char (point-min))
+ (skip-chars-forward " \n\t") ;Throw away spaces.
+ (cons status
+ ;; "bzr" will output warnings and informational messages to
+ ;; stderr; due to Emacs' `vc-do-command' (and, it seems,
+ ;; `start-process' itself) limitations, we cannot catch stderr
+ ;; and stdout into different buffers. So, if there's anything
+ ;; left in the buffer after removing the above status
+ ;; keywords, let us just presume that any other message from
+ ;; "bzr" is a user warning, and display it.
+ (unless (eobp) (buffer-substring (point) (point-max))))))))
+
+(defun vc-bzr-state (file)
+ (lexical-let ((result (vc-bzr-status file)))
+ (when (consp result)
+ (when (cdr result)
+ (message "Warnings in `bzr' output: %s" (cdr result)))
+ (cdr (assq (car result)
+ '((added . added)
+ (kindchanged . edited)
+ (renamed . edited)
+ (modified . edited)
+ (removed . removed)
+ (ignored . ignored)
+ (unknown . unregistered)
+ (unchanged . up-to-date)))))))
+
+(defun vc-bzr-resolve-when-done ()
+ "Call \"bzr resolve\" if the conflict markers have been removed."
+ (save-excursion
+ (goto-char (point-min))
+ (unless (re-search-forward "^<<<<<<< " nil t)
+ (vc-bzr-command "resolve" nil 0 buffer-file-name)
+ ;; Remove the hook so that it is not called multiple times.
+ (remove-hook 'after-save-hook 'vc-bzr-resolve-when-done t))))
+
+(defun vc-bzr-find-file-hook ()
+ (when (and buffer-file-name
+ ;; FIXME: We should check that "bzr status" says "conflict".
+ (file-exists-p (concat buffer-file-name ".BASE"))
+ (file-exists-p (concat buffer-file-name ".OTHER"))
+ (file-exists-p (concat buffer-file-name ".THIS"))
+ ;; If "bzr status" says there's a conflict but there are no
+ ;; conflict markers, it's not clear what we should do.
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "^<<<<<<< " nil t)))
+ ;; TODO: the merge algorithm used in `bzr merge' is nicely configurable,
+ ;; but the one in `bzr pull' isn't, so it would be good to provide an
+ ;; elisp function to remerge from the .BASE/OTHER/THIS files.
+ (smerge-start-session)
+ (add-hook 'after-save-hook 'vc-bzr-resolve-when-done nil t)
+ (message "There are unresolved conflicts in this file")))
+
+(defun vc-bzr-workfile-unchanged-p (file)
+ (eq 'unchanged (car (vc-bzr-status file))))
+
+(defun vc-bzr-working-revision (file)
+ ;; Together with the code in vc-state-heuristic, this makes it possible
+ ;; to get the initial VC state of a Bzr file even if Bzr is not installed.
+ (lexical-let*
+ ((rootdir (vc-bzr-root file))
+ (branch-format-file (expand-file-name vc-bzr-admin-branch-format-file
+ rootdir))
+ (revhistory-file (expand-file-name vc-bzr-admin-revhistory rootdir))
+ (lastrev-file (expand-file-name vc-bzr-admin-lastrev rootdir)))
+ ;; This looks at internal files to avoid forking a bzr process.
+ ;; May break if they change their format.
+ (if (and (file-exists-p branch-format-file)
+ ;; For lightweight checkouts (obtained with bzr checkout --lightweight)
+ ;; the branch-format-file does not contain the revision
+ ;; information, we need to look up the branch-format-file
+ ;; in the place where the lightweight checkout comes
+ ;; from. We only do that if it's a local file.
+ (let ((location-fname (expand-file-name
+ (concat vc-bzr-admin-dirname
+ "/branch/location") rootdir)))
+ ;; The existence of this file is how we distinguish
+ ;; lightweight checkouts.
+ (if (file-exists-p location-fname)
+ (with-temp-buffer
+ (insert-file-contents location-fname)
+ ;; If the lightweight checkout points to a
+ ;; location in the local file system, then we can
+ ;; look there for the version information.
+ (when (re-search-forward "file://\\(.+\\)" nil t)
+ (let ((l-c-parent-dir (match-string 1)))
+ (when (and (memq system-type '(ms-dos windows-nt))
+ (string-match-p "^/[[:alpha:]]:" l-c-parent-dir))
+ ;;; The non-Windows code takes a shortcut by using the host/path
+ ;;; separator slash as the start of the absolute path. That
+ ;;; does not work on Windows, so we must remove it (bug#5345)
+ (setq l-c-parent-dir (substring l-c-parent-dir 1)))
+ (setq branch-format-file
+ (expand-file-name vc-bzr-admin-branch-format-file
+ l-c-parent-dir))
+ (setq lastrev-file
+ (expand-file-name vc-bzr-admin-lastrev l-c-parent-dir))
+ ;; FIXME: maybe it's overkill to check if both these files exist.
+ (and (file-exists-p branch-format-file)
+ (file-exists-p lastrev-file)))))
+ t)))
+ (with-temp-buffer
+ (insert-file-contents branch-format-file)
+ (goto-char (point-min))
+ (cond
+ ((or
+ (looking-at "Bazaar-NG branch, format 0.0.4")
+ (looking-at "Bazaar-NG branch format 5"))
+ ;; count lines in .bzr/branch/revision-history
+ (insert-file-contents revhistory-file)
+ (number-to-string (count-lines (line-end-position) (point-max))))
+ ((or
+ (looking-at "Bazaar Branch Format 6 (bzr 0.15)")
+ (looking-at "Bazaar Branch Format 7 (needs bzr 1.6)"))
+ ;; revno is the first number in .bzr/branch/last-revision
+ (insert-file-contents lastrev-file)
+ (when (re-search-forward "[0-9]+" nil t)
+ (buffer-substring (match-beginning 0) (match-end 0))))))
+ ;; fallback to calling "bzr revno"
+ (lexical-let*
+ ((result (vc-bzr-command-discarding-stderr
+ vc-bzr-program "revno" (file-relative-name file)))
+ (exitcode (car result))
+ (output (cdr result)))
+ (cond
+ ((eq exitcode 0) (substring output 0 -1))
+ (t nil))))))
+
+(defun vc-bzr-create-repo ()
+ "Create a new Bzr repository."
+ (vc-bzr-command "init" nil 0 nil))
+
+(defun vc-bzr-init-revision (&optional file)
+ "Always return nil, as Bzr cannot register explicit versions."
+ nil)
+
+(defun vc-bzr-previous-revision (file rev)
+ (if (string-match "\\`[0-9]+\\'" rev)
+ (number-to-string (1- (string-to-number rev)))
+ (concat "before:" rev)))
+
+(defun vc-bzr-next-revision (file rev)
+ (if (string-match "\\`[0-9]+\\'" rev)
+ (number-to-string (1+ (string-to-number rev)))
+ (error "Don't know how to compute the next revision of %s" rev)))
+
+(defun vc-bzr-register (files &optional rev comment)
+ "Register FILE under bzr.
+Signal an error unless REV is nil.
+COMMENT is ignored."
+ (if rev (error "Can't register explicit revision with bzr"))
+ (vc-bzr-command "add" nil 0 files))
+
+;; Could run `bzr status' in the directory and see if it succeeds, but
+;; that's relatively expensive.
+(defalias 'vc-bzr-responsible-p 'vc-bzr-root
+ "Return non-nil if FILE is (potentially) controlled by bzr.
+The criterion is that there is a `.bzr' directory in the same
+or a superior directory.")
+
+(defun vc-bzr-could-register (file)
+ "Return non-nil if FILE could be registered under bzr."
+ (and (vc-bzr-responsible-p file) ; shortcut
+ (condition-case ()
+ (with-temp-buffer
+ (vc-bzr-command "add" t 0 file "--dry-run")
+ ;; The command succeeds with no output if file is
+ ;; registered (in bzr 0.8).
+ (goto-char (point-min))
+ (looking-at "added "))
+ (error))))
+
+(defun vc-bzr-unregister (file)
+ "Unregister FILE from bzr."
+ (vc-bzr-command "remove" nil 0 file "--keep"))
+
+(declare-function log-edit-extract-headers "log-edit" (headers string))
+
+(defun vc-bzr-checkin (files rev comment)
+ "Check FILE in to bzr with log message COMMENT.
+REV non-nil gets an error."
+ (if rev (error "Can't check in a specific revision with bzr"))
+ (apply 'vc-bzr-command "commit" nil 0
+ files (cons "-m" (log-edit-extract-headers '(("Author" . "--author")
+ ("Date" . "--commit-time")
+ ("Fixes" . "--fixes"))
+ comment))))
+
+(defun vc-bzr-find-revision (file rev buffer)
+ "Fetch revision REV of file FILE and put it into BUFFER."
+ (with-current-buffer buffer
+ (if (and rev (stringp rev) (not (string= rev "")))
+ (vc-bzr-command "cat" t 0 file "-r" rev)
+ (vc-bzr-command "cat" t 0 file))))
+
+(defun vc-bzr-checkout (file &optional editable rev)
+ (if rev (error "Operation not supported")
+ ;; Else, there's nothing to do.
+ nil))
+
+(defun vc-bzr-revert (file &optional contents-done)
+ (unless contents-done
+ (with-temp-buffer (vc-bzr-command "revert" t 0 file))))
+
+(defvar log-view-message-re)
+(defvar log-view-file-re)
+(defvar log-view-font-lock-keywords)
+(defvar log-view-current-tag-function)
+(defvar log-view-per-file-logs)
+
+(define-derived-mode vc-bzr-log-view-mode log-view-mode "Bzr-Log-View"
+ (remove-hook 'log-view-mode-hook 'vc-bzr-log-view-mode) ;Deactivate the hack.
+ (require 'add-log)
+ (set (make-local-variable 'log-view-per-file-logs) nil)
+ (set (make-local-variable 'log-view-file-re) "\\`a\\`")
+ (set (make-local-variable 'log-view-message-re)
+ (if (eq vc-log-view-type 'short)
+ "^ *\\([0-9.]+\\): \\(.*?\\)[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)\\( \\[merge\\]\\)?"
+ "^ *\\(?:revno: \\([0-9.]+\\)\\|merged: .+\\)"))
+ (set (make-local-variable 'log-view-font-lock-keywords)
+ ;; log-view-font-lock-keywords is careful to use the buffer-local
+ ;; value of log-view-message-re only since Emacs-23.
+ (if (eq vc-log-view-type 'short)
+ (append `((,log-view-message-re
+ (1 'log-view-message-face)
+ (2 'change-log-name)
+ (3 'change-log-date)
+ (4 'change-log-list nil lax))))
+ (append `((,log-view-message-re . 'log-view-message-face))
+ ;; log-view-font-lock-keywords
+ '(("^ *\\(?:committer\\|author\\): \
+\\([^<(]+?\\)[ ]*[(<]\\([[:alnum:]_.+-]+@[[:alnum:]_.-]+\\)[>)]"
+ (1 'change-log-name)
+ (2 'change-log-email))
+ ("^ *timestamp: \\(.*\\)" (1 'change-log-date-face)))))))
+
+(defun vc-bzr-print-log (files buffer &optional shortlog start-revision limit)
+ "Get bzr change log for FILES into specified BUFFER."
+ ;; `vc-do-command' creates the buffer, but we need it before running
+ ;; the command.
+ (vc-setup-buffer buffer)
+ ;; If the buffer exists from a previous invocation it might be
+ ;; read-only.
+ ;; FIXME: `vc-bzr-command' runs `bzr log' with `LC_MESSAGES=C', so
+ ;; the log display may not what the user wants - but I see no other
+ ;; way of getting the above regexps working.
+ (with-current-buffer buffer
+ (apply 'vc-bzr-command "log" buffer 'async files
+ (append
+ (when shortlog '("--line"))
+ (when start-revision (list (format "-r..%s" start-revision)))
+ (when limit (list "-l" (format "%s" limit)))
+ (if (stringp vc-bzr-log-switches)
+ (list vc-bzr-log-switches)
+ vc-bzr-log-switches)))))
+
+(defun vc-bzr-log-incoming (buffer remote-location)
+ (apply 'vc-bzr-command "missing" buffer 'async nil
+ (list "--theirs-only" (unless (string= remote-location "") remote-location))))
+
+(defun vc-bzr-log-outgoing (buffer remote-location)
+ (apply 'vc-bzr-command "missing" buffer 'async nil
+ (list "--mine-only" (unless (string= remote-location "") remote-location))))
+
+(defun vc-bzr-show-log-entry (revision)
+ "Find entry for patch name REVISION in bzr change log buffer."
+ (goto-char (point-min))
+ (when revision
+ (let (case-fold-search
+ found)
+ (if (re-search-forward
+ ;; "revno:" can appear either at the beginning of a line,
+ ;; or indented.
+ (concat "^[ ]*-+\n[ ]*revno: "
+ ;; The revision can contain ".", quote it so that it
+ ;; does not interfere with regexp matching.
+ (regexp-quote revision) "$") nil t)
+ (progn
+ (beginning-of-line 0)
+ (setq found t))
+ (goto-char (point-min)))
+ found)))
+
+(defun vc-bzr-diff (files &optional rev1 rev2 buffer)
+ "VC bzr backend for diff."
+ ;; `bzr diff' exits with code 1 if diff is non-empty.
+ (apply #'vc-bzr-command "diff" (or buffer "*vc-diff*")
+ (if vc-disable-async-diff 1 'async) files
+ "--diff-options" (mapconcat 'identity
+ (vc-switches 'bzr 'diff)
+ " ")
+ ;; This `when' is just an optimization because bzr-1.2 is *much*
+ ;; faster when the revision argument is not given.
+ (when (or rev1 rev2)
+ (list "-r" (format "%s..%s"
+ (or rev1 "revno:-1")
+ (or rev2 ""))))))
+
+
+;; FIXME: vc-{next,previous}-revision need fixing in vc.el to deal with
+;; straight integer revisions.
+
+(defun vc-bzr-delete-file (file)
+ "Delete FILE and delete it in the bzr repository."
+ (condition-case ()
+ (delete-file file)
+ (file-error nil))
+ (vc-bzr-command "remove" nil 0 file))
+
+(defun vc-bzr-rename-file (old new)
+ "Rename file from OLD to NEW using `bzr mv'."
+ (vc-bzr-command "mv" nil 0 new old))
+
+(defvar vc-bzr-annotation-table nil
+ "Internal use.")
+(make-variable-buffer-local 'vc-bzr-annotation-table)
+
+(defun vc-bzr-annotate-command (file buffer &optional revision)
+ "Prepare BUFFER for `vc-annotate' on FILE.
+Each line is tagged with the revision number, which has a `help-echo'
+property containing author and date information."
+ (apply #'vc-bzr-command "annotate" buffer 'async file "--long" "--all"
+ (if revision (list "-r" revision)))
+ (lexical-let ((table (make-hash-table :test 'equal)))
+ (set-process-filter
+ (get-buffer-process buffer)
+ (lambda (proc string)
+ (when (process-buffer proc)
+ (with-current-buffer (process-buffer proc)
+ (setq string (concat (process-get proc :vc-left-over) string))
+ (while (string-match "^\\( *[0-9.]+ *\\) \\([^\n ]+\\) +\\([0-9]\\{8\\}\\)\\( |.*\n\\)" string)
+ (let* ((rev (match-string 1 string))
+ (author (match-string 2 string))
+ (date (match-string 3 string))
+ (key (substring string (match-beginning 0)
+ (match-beginning 4)))
+ (line (match-string 4 string))
+ (tag (gethash key table))
+ (inhibit-read-only t))
+ (setq string (substring string (match-end 0)))
+ (unless tag
+ (setq tag
+ (propertize
+ (format "%s %-7.7s" rev author)
+ 'help-echo (format "Revision: %d, author: %s, date: %s"
+ (string-to-number rev)
+ author date)
+ 'mouse-face 'highlight))
+ (puthash key tag table))
+ (goto-char (process-mark proc))
+ (insert tag line)
+ (move-marker (process-mark proc) (point))))
+ (process-put proc :vc-left-over string)))))))
+
+(declare-function vc-annotate-convert-time "vc-annotate" (time))
+
+(defun vc-bzr-annotate-time ()
+ (when (re-search-forward "^ *[0-9.]+ +[^\n ]* +|" nil t)
+ (let ((prop (get-text-property (line-beginning-position) 'help-echo)))
+ (string-match "[0-9]+\\'" prop)
+ (let ((str (match-string-no-properties 0 prop)))
+ (vc-annotate-convert-time
+ (encode-time 0 0 0
+ (string-to-number (substring str 6 8))
+ (string-to-number (substring str 4 6))
+ (string-to-number (substring str 0 4))))))))
+
+(defun vc-bzr-annotate-extract-revision-at-line ()
+ "Return revision for current line of annoation buffer, or nil.
+Return nil if current line isn't annotated."
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at "^ *\\([0-9.]+\\) +[^\n ]* +|")
+ (match-string-no-properties 1))))
+
+(defun vc-bzr-command-discarding-stderr (command &rest args)
+ "Execute shell command COMMAND (with ARGS); return its output and exitcode.
+Return value is a cons (EXITCODE . OUTPUT), where EXITCODE is
+the (numerical) exit code of the process, and OUTPUT is a string
+containing whatever the process sent to its standard output
+stream. Standard error output is discarded."
+ (with-temp-buffer
+ (cons
+ (apply #'process-file command nil (list (current-buffer) nil) nil args)
+ (buffer-substring (point-min) (point-max)))))
+
+(defstruct (vc-bzr-extra-fileinfo
+ (:copier nil)
+ (:constructor vc-bzr-create-extra-fileinfo (extra-name))
+ (:conc-name vc-bzr-extra-fileinfo->))
+ extra-name) ;; original name for rename targets, new name for
+
+(defun vc-bzr-dir-printer (info)
+ "Pretty-printer for the vc-dir-fileinfo structure."
+ (let ((extra (vc-dir-fileinfo->extra info)))
+ (vc-default-dir-printer 'Bzr info)
+ (when extra
+ (insert (propertize
+ (format " (renamed from %s)"
+ (vc-bzr-extra-fileinfo->extra-name extra))
+ 'face 'font-lock-comment-face)))))
+
+;; FIXME: this needs testing, it's probably incomplete.
+(defun vc-bzr-after-dir-status (update-function relative-dir)
+ (let ((status-str nil)
+ (translation '(("+N " . added)
+ ("-D " . removed)
+ (" M " . edited) ;; file text modified
+ (" *" . edited) ;; execute bit changed
+ (" M*" . edited) ;; text modified + execute bit changed
+ ;; FIXME: what about ignored files?
+ (" D " . missing)
+ ;; For conflicts, should we list the .THIS/.BASE/.OTHER?
+ ("C " . conflict)
+ ("? " . unregistered)
+ ;; No such state, but we need to distinguish this case.
+ ("R " . renamed)
+ ("RM " . renamed)
+ ;; For a non existent file FOO, the output is:
+ ;; bzr: ERROR: Path(s) do not exist: FOO
+ ("bzr" . not-found)
+ ;; If the tree is not up to date, bzr will print this warning:
+ ;; working tree is out of date, run 'bzr update'
+ ;; ignore it.
+ ;; FIXME: maybe this warning can be put in the vc-dir header...
+ ("wor" . not-found)
+ ;; Ignore "P " and "P." for pending patches.
+ ("P " . not-found)
+ ("P. " . not-found)
+ ))
+ (translated nil)
+ (result nil))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq status-str
+ (buffer-substring-no-properties (point) (+ (point) 3)))
+ (setq translated (cdr (assoc status-str translation)))
+ (cond
+ ((eq translated 'conflict)
+ ;; For conflicts the file appears twice in the listing: once
+ ;; with the M flag and once with the C flag, so take care
+ ;; not to add it twice to `result'. Ugly.
+ (let* ((file
+ (buffer-substring-no-properties
+ ;;For files with conflicts the format is:
+ ;;C Text conflict in FILENAME
+ ;; Bah.
+ (+ (point) 21) (line-end-position)))
+ (entry (assoc file result)))
+ (when entry
+ (setf (nth 1 entry) 'conflict))))
+ ((eq translated 'renamed)
+ (re-search-forward "R[ M] \\(.*\\) => \\(.*\\)$" (line-end-position) t)
+ (let ((new-name (file-relative-name (match-string 2) relative-dir))
+ (old-name (file-relative-name (match-string 1) relative-dir)))
+ (push (list new-name 'edited
+ (vc-bzr-create-extra-fileinfo old-name)) result)))
+ ;; do nothing for non existent files
+ ((eq translated 'not-found))
+ (t
+ (push (list (file-relative-name
+ (buffer-substring-no-properties
+ (+ (point) 4)
+ (line-end-position)) relative-dir)
+ translated) result)))
+ (forward-line))
+ (funcall update-function result)))
+
+(defun vc-bzr-dir-status (dir update-function)
+ "Return a list of conses (file . state) for DIR."
+ (vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S")
+ (vc-exec-after
+ `(vc-bzr-after-dir-status (quote ,update-function)
+ ;; "bzr status" results are relative to
+ ;; the bzr root directory, NOT to the
+ ;; directory "bzr status" was invoked in.
+ ;; Ugh.
+ ;; We pass the relative directory here so
+ ;; that `vc-bzr-after-dir-status' can
+ ;; frob the results accordingly.
+ (file-relative-name ,dir (vc-bzr-root ,dir)))))
+
+(defun vc-bzr-dir-status-files (dir files default-state update-function)
+ "Return a list of conses (file . state) for DIR."
+ (apply 'vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S" files)
+ (vc-exec-after
+ `(vc-bzr-after-dir-status (quote ,update-function)
+ (file-relative-name ,dir (vc-bzr-root ,dir)))))
+
+(defvar vc-bzr-shelve-map
+ (let ((map (make-sparse-keymap)))
+ ;; Turn off vc-dir marking
+ (define-key map [mouse-2] 'ignore)
+
+ (define-key map [down-mouse-3] 'vc-bzr-shelve-menu)
+ (define-key map "\C-k" 'vc-bzr-shelve-delete-at-point)
+ (define-key map "=" 'vc-bzr-shelve-show-at-point)
+ (define-key map "\C-m" 'vc-bzr-shelve-show-at-point)
+ (define-key map "A" 'vc-bzr-shelve-apply-and-keep-at-point)
+ (define-key map "P" 'vc-bzr-shelve-apply-at-point)
+ (define-key map "S" 'vc-bzr-shelve-snapshot)
+ map))
+
+(defvar vc-bzr-shelve-menu-map
+ (let ((map (make-sparse-keymap "Bzr Shelve")))
+ (define-key map [de]
+ '(menu-item "Delete shelf" vc-bzr-shelve-delete-at-point
+ :help "Delete the current shelf"))
+ (define-key map [ap]
+ '(menu-item "Apply and keep shelf" vc-bzr-shelve-apply-and-keep-at-point
+ :help "Apply the current shelf and keep it"))
+ (define-key map [po]
+ '(menu-item "Apply and remove shelf (pop)" vc-bzr-shelve-apply-at-point
+ :help "Apply the current shelf and remove it"))
+ (define-key map [sh]
+ '(menu-item "Show shelve" vc-bzr-shelve-show-at-point
+ :help "Show the contents of the current shelve"))
+ map))
+
+(defvar vc-bzr-extra-menu-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [bzr-sn]
+ '(menu-item "Shelve a snapshot" vc-bzr-shelve-snapshot
+ :help "Shelve the current state of the tree and keep the current state"))
+ (define-key map [bzr-sh]
+ '(menu-item "Shelve..." vc-bzr-shelve
+ :help "Shelve changes"))
+ map))
+
+(defun vc-bzr-extra-menu () vc-bzr-extra-menu-map)
+
+(defun vc-bzr-extra-status-menu () vc-bzr-extra-menu-map)
+
+(defun vc-bzr-dir-extra-headers (dir)
+ (let*
+ ((str (with-temp-buffer
+ (vc-bzr-command "info" t 0 dir)
+ (buffer-string)))
+ (shelve (vc-bzr-shelve-list))
+ (shelve-help-echo "Use M-x vc-bzr-shelve to create shelves")
+ (root-dir (vc-bzr-root dir))
+ (pending-merge
+ ;; FIXME: looking for .bzr/checkout/merge-hashes is not a
+ ;; reliable method to detect pending merges, disable this
+ ;; until a proper solution is implemented.
+ (and nil
+ (file-exists-p
+ (expand-file-name ".bzr/checkout/merge-hashes" root-dir))))
+ (pending-merge-help-echo
+ (format "A merge has been performed.\nA commit from the top-level directory (%s)\nis required before being able to check in anything else" root-dir))
+ (light-checkout
+ (when (string-match ".+light checkout root: \\(.+\\)$" str)
+ (match-string 1 str)))
+ (light-checkout-branch
+ (when light-checkout
+ (when (string-match ".+checkout of branch: \\(.+\\)$" str)
+ (match-string 1 str)))))
+ (concat
+ (propertize "Parent branch : " 'face 'font-lock-type-face)
+ (propertize
+ (if (string-match "parent branch: \\(.+\\)$" str)
+ (match-string 1 str)
+ "None")
+ 'face 'font-lock-variable-name-face)
+ "\n"
+ (when light-checkout
+ (concat
+ (propertize "Light checkout root: " 'face 'font-lock-type-face)
+ (propertize light-checkout 'face 'font-lock-variable-name-face)
+ "\n"))
+ (when light-checkout-branch
+ (concat
+ (propertize "Checkout of branch : " 'face 'font-lock-type-face)
+ (propertize light-checkout-branch 'face 'font-lock-variable-name-face)
+ "\n"))
+ (when pending-merge
+ (concat
+ (propertize "Warning : " 'face 'font-lock-warning-face
+ 'help-echo pending-merge-help-echo)
+ (propertize "Pending merges, commit recommended before any other action"
+ 'help-echo pending-merge-help-echo
+ 'face 'font-lock-warning-face)
+ "\n"))
+ (if shelve
+ (concat
+ (propertize "Shelves :\n" 'face 'font-lock-type-face
+ 'help-echo shelve-help-echo)
+ (mapconcat
+ (lambda (x)
+ (propertize x
+ 'face 'font-lock-variable-name-face
+ 'mouse-face 'highlight
+ 'help-echo "mouse-3: Show shelve menu\nA: Apply and keep shelf\nP: Apply and remove shelf (pop)\nS: Snapshot to a shelf\nC-k: Delete shelf"
+ 'keymap vc-bzr-shelve-map))
+ shelve "\n"))
+ (concat
+ (propertize "Shelves : " 'face 'font-lock-type-face
+ 'help-echo shelve-help-echo)
+ (propertize "No shelved changes"
+ 'help-echo shelve-help-echo
+ 'face 'font-lock-variable-name-face))))))
+
+(defun vc-bzr-shelve (name)
+ "Create a shelve."
+ (interactive "sShelf name: ")
+ (let ((root (vc-bzr-root default-directory)))
+ (when root
+ (vc-bzr-command "shelve" nil 0 nil "--all" "-m" name)
+ (vc-resynch-buffer root t t))))
+
+(defun vc-bzr-shelve-show (name)
+ "Show the contents of shelve NAME."
+ (interactive "sShelve name: ")
+ (vc-setup-buffer "*vc-diff*")
+ ;; FIXME: how can you show the contents of a shelf?
+ (vc-bzr-command "unshelve" "*vc-diff*" 'async nil "--preview" name)
+ (set-buffer "*vc-diff*")
+ (diff-mode)
+ (setq buffer-read-only t)
+ (pop-to-buffer (current-buffer)))
+
+(defun vc-bzr-shelve-apply (name)
+ "Apply shelve NAME and remove it afterwards."
+ (interactive "sApply (and remove) shelf: ")
+ (vc-bzr-command "unshelve" nil 0 nil "--apply" name)
+ (vc-resynch-buffer (vc-bzr-root default-directory) t t))
+
+(defun vc-bzr-shelve-apply-and-keep (name)
+ "Apply shelve NAME and keep it afterwards."
+ (interactive "sApply (and keep) shelf: ")
+ (vc-bzr-command "unshelve" nil 0 nil "--apply" "--keep" name)
+ (vc-resynch-buffer (vc-bzr-root default-directory) t t))
+
+(defun vc-bzr-shelve-snapshot ()
+ "Create a stash with the current tree state."
+ (interactive)
+ (vc-bzr-command "shelve" nil 0 nil "--all" "-m"
+ (let ((ct (current-time)))
+ (concat
+ (format-time-string "Snapshot on %Y-%m-%d" ct)
+ (format-time-string " at %H:%M" ct))))
+ (vc-bzr-command "unshelve" nil 0 nil "--apply" "--keep")
+ (vc-resynch-buffer (vc-bzr-root default-directory) t t))
+
+(defun vc-bzr-shelve-list ()
+ (with-temp-buffer
+ (vc-bzr-command "shelve" (current-buffer) 1 nil "--list" "-q")
+ (delete
+ ""
+ (split-string
+ (buffer-substring (point-min) (point-max))
+ "\n"))))
+
+(defun vc-bzr-shelve-get-at-point (point)
+ (save-excursion
+ (goto-char point)
+ (beginning-of-line)
+ (if (looking-at "^ +\\([0-9]+\\):")
+ (match-string 1)
+ (error "Cannot find shelf at point"))))
+
+(defun vc-bzr-shelve-delete-at-point ()
+ (interactive)
+ (let ((shelve (vc-bzr-shelve-get-at-point (point))))
+ (when (y-or-n-p (format "Remove shelf %s ?" shelve))
+ (vc-bzr-command "unshelve" nil 0 nil "--delete-only" shelve)
+ (vc-dir-refresh))))
+
+(defun vc-bzr-shelve-show-at-point ()
+ (interactive)
+ (vc-bzr-shelve-show (vc-bzr-shelve-get-at-point (point))))
+
+(defun vc-bzr-shelve-apply-at-point ()
+ (interactive)
+ (vc-bzr-shelve-apply (vc-bzr-shelve-get-at-point (point))))
+
+(defun vc-bzr-shelve-apply-and-keep-at-point ()
+ (interactive)
+ (vc-bzr-shelve-apply-and-keep (vc-bzr-shelve-get-at-point (point))))
+
+(defun vc-bzr-shelve-menu (e)
+ (interactive "e")
+ (vc-dir-at-event e (popup-menu vc-bzr-shelve-menu-map e)))
+
+(defun vc-bzr-revision-table (files)
+ (let ((vc-bzr-revisions '())
+ (default-directory (file-name-directory (car files))))
+ (with-temp-buffer
+ (vc-bzr-command "log" t 0 files "--line")
+ (let ((start (point-min))
+ (loglines (buffer-substring-no-properties (point-min) (point-max))))
+ (while (string-match "^\\([0-9]+\\):" loglines)
+ (push (match-string 1 loglines) vc-bzr-revisions)
+ (setq start (+ start (match-end 0)))
+ (setq loglines (buffer-substring-no-properties start (point-max))))))
+ vc-bzr-revisions))
+
+(defun vc-bzr-conflicted-files (dir)
+ (let ((default-directory (vc-bzr-root dir))
+ (files ()))
+ (with-temp-buffer
+ (vc-bzr-command "status" t 0 default-directory)
+ (goto-char (point-min))
+ (when (re-search-forward "^conflicts:\n" nil t)
+ (while (looking-at " \\(?:Text conflict in \\(.*\\)\\|.*\\)\n")
+ (if (match-end 1)
+ (push (expand-file-name (match-string 1)) files))
+ (goto-char (match-end 0)))))
+ files))
+
+;;; Revision completion
+
+(eval-and-compile
+ (defconst vc-bzr-revision-keywords
+ '("revno" "revid" "last" "before"
+ "tag" "date" "ancestor" "branch" "submit")))
+
+(defun vc-bzr-revision-completion-table (files)
+ (lexical-let ((files files))
+ ;; What about using `files'?!? --Stef
+ (lambda (string pred action)
+ (cond
+ ((string-match "\\`\\(ancestor\\|branch\\|\\(revno:\\)?[-0-9]+:\\):"
+ string)
+ (completion-table-with-context (substring string 0 (match-end 0))
+ (apply-partially
+ 'completion-table-with-predicate
+ 'completion-file-name-table
+ 'file-directory-p t)
+ (substring string (match-end 0))
+ pred
+ action))
+ ((string-match "\\`\\(before\\):" string)
+ (completion-table-with-context (substring string 0 (match-end 0))
+ (vc-bzr-revision-completion-table files)
+ (substring string (match-end 0))
+ pred
+ action))
+ ((string-match "\\`\\(tag\\):" string)
+ (let ((prefix (substring string 0 (match-end 0)))
+ (tag (substring string (match-end 0)))
+ (table nil)
+ process-file-side-effects)
+ (with-temp-buffer
+ ;; "bzr-1.2 tags" is much faster with --show-ids.
+ (process-file vc-bzr-program nil '(t) nil "tags" "--show-ids")
+ ;; The output is ambiguous, unless we assume that revids do not
+ ;; contain spaces.
+ (goto-char (point-min))
+ (while (re-search-forward "^\\(.*[^ \n]\\) +[^ \n]*$" nil t)
+ (push (match-string-no-properties 1) table)))
+ (completion-table-with-context prefix table tag pred action)))
+
+ ((string-match "\\`\\([a-z]+\\):" string)
+ ;; no actual completion for the remaining keywords.
+ (completion-table-with-context (substring string 0 (match-end 0))
+ (if (member (match-string 1 string)
+ vc-bzr-revision-keywords)
+ ;; If it's a valid keyword,
+ ;; use a non-empty table to
+ ;; indicate it.
+ '("") nil)
+ (substring string (match-end 0))
+ pred
+ action))
+ (t
+ ;; Could use completion-table-with-terminator, except that it
+ ;; currently doesn't work right w.r.t pcm and doesn't give
+ ;; the *Completions* output we want.
+ (complete-with-action action (eval-when-compile
+ (mapcar (lambda (s) (concat s ":"))
+ vc-bzr-revision-keywords))
+ string pred))))))
+
+(eval-after-load "vc"
+ '(add-to-list 'vc-directory-exclusion-list vc-bzr-admin-dirname t))
+
+(provide 'vc-bzr)
+;; arch-tag: 8101bad8-4e92-4e7d-85ae-d8e08b4e7c06
+;;; vc-bzr.el ends here
--- /dev/null
+;;; vc-cvs.el --- non-resident support for CVS version-control
+
+;; Copyright (C) 1995, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl) (require 'vc))
+
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'CVS 'vc-functions nil)
+
+;;; Properties of the backend.
+
+(defun vc-cvs-revision-granularity () 'file)
+
+(defun vc-cvs-checkout-model (files)
+ "CVS-specific version of `vc-checkout-model'."
+ (if (getenv "CVSREAD")
+ 'announce
+ (let* ((file (if (consp files) (car files) files))
+ (attrib (file-attributes file)))
+ (or (vc-file-getprop file 'vc-checkout-model)
+ (vc-file-setprop
+ file 'vc-checkout-model
+ (if (and attrib ;; don't check further if FILE doesn't exist
+ ;; If the file is not writable (despite CVSREAD being
+ ;; undefined), this is probably because the file is being
+ ;; "watched" by other developers.
+ ;; (If vc-mistrust-permissions was t, we actually shouldn't
+ ;; trust this, but there is no other way to learn this from
+ ;; CVS at the moment (version 1.9).)
+ (string-match "r-..-..-." (nth 8 attrib)))
+ 'announce
+ 'implicit))))))
+
+;;;
+;;; Customization options
+;;;
+
+(defcustom vc-cvs-global-switches nil
+ "Global switches to pass to any CVS command."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :version "22.1"
+ :group 'vc)
+
+(defcustom vc-cvs-register-switches nil
+ "Switches for registering a file into CVS.
+A string or list of strings passed to the checkin program by
+\\[vc-register]. If nil, use the value of `vc-register-switches'.
+If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-cvs-diff-switches nil
+ "String or list of strings specifying switches for CVS diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-cvs-header (or (cdr (assoc 'CVS vc-header-alist)) '("\$Id\$"))
+ "Header keywords to be inserted by `vc-insert-headers'."
+ :version "21.1"
+ :type '(repeat string)
+ :group 'vc)
+
+(defcustom vc-cvs-use-edit t
+ "Non-nil means to use `cvs edit' to \"check out\" a file.
+This is only meaningful if you don't use the implicit checkout model
+\(i.e. if you have $CVSREAD set)."
+ :type 'boolean
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-cvs-stay-local 'only-file
+ "Non-nil means use local operations when possible for remote repositories.
+This avoids slow queries over the network and instead uses heuristics
+and past information to determine the current status of a file.
+
+If value is the symbol `only-file' `vc-dir' will connect to the
+server, but heuristics will be used to determine the status for
+all other VC operations.
+
+The value can also be a regular expression or list of regular
+expressions to match against the host name of a repository; then VC
+only stays local for hosts that match it. Alternatively, the value
+can be a list of regular expressions where the first element is the
+symbol `except'; then VC always stays local except for hosts matched
+by these regular expressions."
+ :type '(choice (const :tag "Always stay local" t)
+ (const :tag "Only for file operations" only-file)
+ (const :tag "Don't stay local" nil)
+ (list :format "\nExamine hostname and %v"
+ :tag "Examine hostname ..."
+ (set :format "%v" :inline t
+ (const :format "%t" :tag "don't" except))
+ (regexp :format " stay local,\n%t: %v"
+ :tag "if it matches")
+ (repeat :format "%v%i\n" :inline t (regexp :tag "or"))))
+ :version "23.1"
+ :group 'vc)
+
+(defcustom vc-cvs-sticky-date-format-string "%c"
+ "Format string for mode-line display of sticky date.
+Format is according to `format-time-string'. Only used if
+`vc-cvs-sticky-tag-display' is t."
+ :type '(string)
+ :version "22.1"
+ :group 'vc)
+
+(defcustom vc-cvs-sticky-tag-display t
+ "Specify the mode-line display of sticky tags.
+Value t means default display, nil means no display at all. If the
+value is a function or macro, it is called with the sticky tag and
+its' type as parameters, in that order. TYPE can have three different
+values: `symbolic-name' (TAG is a string), `revision-number' (TAG is a
+string) and `date' (TAG is a date as returned by `encode-time'). The
+return value of the function or macro will be displayed as a string.
+
+Here's an example that will display the formatted date for sticky
+dates and the word \"Sticky\" for sticky tag names and revisions.
+
+ (lambda (tag type)
+ (cond ((eq type 'date) (format-time-string
+ vc-cvs-sticky-date-format-string tag))
+ ((eq type 'revision-number) \"Sticky\")
+ ((eq type 'symbolic-name) \"Sticky\")))
+
+Here's an example that will abbreviate to the first character only,
+any text before the first occurrence of `-' for sticky symbolic tags.
+If the sticky tag is a revision number, the word \"Sticky\" is
+displayed. Date and time is displayed for sticky dates.
+
+ (lambda (tag type)
+ (cond ((eq type 'date) (format-time-string \"%Y%m%d %H:%M\" tag))
+ ((eq type 'revision-number) \"Sticky\")
+ ((eq type 'symbolic-name)
+ (condition-case nil
+ (progn
+ (string-match \"\\\\([^-]*\\\\)\\\\(.*\\\\)\" tag)
+ (concat (substring (match-string 1 tag) 0 1) \":\"
+ (substring (match-string 2 tag) 1 nil)))
+ (error tag))))) ; Fall-back to given tag name.
+
+See also variable `vc-cvs-sticky-date-format-string'."
+ :type '(choice boolean function)
+ :version "22.1"
+ :group 'vc)
+
+;;;
+;;; Internal variables
+;;;
+
+
+;;;
+;;; State-querying functions
+;;;
+
+;;;###autoload (defun vc-cvs-registered (f)
+;;;###autoload (when (file-readable-p (expand-file-name
+;;;###autoload "CVS/Entries" (file-name-directory f)))
+;;;###autoload (load "vc-cvs")
+;;;###autoload (vc-cvs-registered f)))
+
+(defun vc-cvs-registered (file)
+ "Check if FILE is CVS registered."
+ (let ((dirname (or (file-name-directory file) ""))
+ (basename (file-name-nondirectory file))
+ ;; make sure that the file name is searched case-sensitively
+ (case-fold-search nil))
+ (if (file-readable-p (expand-file-name "CVS/Entries" dirname))
+ (or (string= basename "")
+ (with-temp-buffer
+ (vc-cvs-get-entries dirname)
+ (goto-char (point-min))
+ (cond ((re-search-forward
+ (concat "^/" (regexp-quote basename) "/[^/]") nil t)
+ (beginning-of-line)
+ (vc-cvs-parse-entry file)
+ t)
+ (t nil))))
+ nil)))
+
+(defun vc-cvs-state (file)
+ "CVS-specific version of `vc-state'."
+ (if (vc-stay-local-p file 'CVS)
+ (let ((state (vc-file-getprop file 'vc-state)))
+ ;; If we should stay local, use the heuristic but only if
+ ;; we don't have a more precise state already available.
+ (if (memq state '(up-to-date edited nil))
+ (vc-cvs-state-heuristic file)
+ state))
+ (with-temp-buffer
+ (cd (file-name-directory file))
+ (let (process-file-side-effects)
+ (vc-cvs-command t 0 file "status"))
+ (vc-cvs-parse-status t))))
+
+(defun vc-cvs-state-heuristic (file)
+ "CVS-specific state heuristic."
+ ;; If the file has not changed since checkout, consider it `up-to-date'.
+ ;; Otherwise consider it `edited'.
+ (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
+ (lastmod (nth 5 (file-attributes file))))
+ (cond
+ ((equal checkout-time lastmod) 'up-to-date)
+ ((string= (vc-working-revision file) "0") 'added)
+ ((null checkout-time) 'unregistered)
+ (t 'edited))))
+
+(defun vc-cvs-working-revision (file)
+ "CVS-specific version of `vc-working-revision'."
+ ;; There is no need to consult RCS headers under CVS, because we
+ ;; get the workfile version for free when we recognize that a file
+ ;; is registered in CVS.
+ (vc-cvs-registered file)
+ (vc-file-getprop file 'vc-working-revision))
+
+(defun vc-cvs-mode-line-string (file)
+ "Return string for placement into the modeline for FILE.
+Compared to the default implementation, this function does two things:
+Handle the special case of a CVS file that is added but not yet
+committed and support display of sticky tags."
+ (let* ((sticky-tag (vc-file-getprop file 'vc-cvs-sticky-tag))
+ help-echo
+ (string
+ (let ((def-ml (vc-default-mode-line-string 'CVS file)))
+ (setq help-echo
+ (get-text-property 0 'help-echo def-ml))
+ def-ml)))
+ (propertize
+ (if (zerop (length sticky-tag))
+ string
+ (setq help-echo (format "%s on the '%s' branch"
+ help-echo sticky-tag))
+ (concat string "[" sticky-tag "]"))
+ 'help-echo help-echo)))
+
+
+;;;
+;;; State-changing functions
+;;;
+
+(defun vc-cvs-register (files &optional rev comment)
+ "Register FILES into the CVS version-control system.
+COMMENT can be used to provide an initial description of FILES.
+Passes either `vc-cvs-register-switches' or `vc-register-switches'
+to the CVS command."
+ ;; Register the directories if needed.
+ (let (dirs)
+ (dolist (file files)
+ (and (not (vc-cvs-responsible-p file))
+ (vc-cvs-could-register file)
+ (push (directory-file-name (file-name-directory file)) dirs)))
+ (if dirs (vc-cvs-register dirs)))
+ (apply 'vc-cvs-command nil 0 files
+ "add"
+ (and comment (string-match "[^\t\n ]" comment)
+ (concat "-m" comment))
+ (vc-switches 'CVS 'register)))
+
+(defun vc-cvs-responsible-p (file)
+ "Return non-nil if CVS thinks it is responsible for FILE."
+ (file-directory-p (expand-file-name "CVS"
+ (if (file-directory-p file)
+ file
+ (file-name-directory file)))))
+
+(defun vc-cvs-could-register (file)
+ "Return non-nil if FILE could be registered in CVS.
+This is only possible if CVS is managing FILE's directory or one of
+its parents."
+ (let ((dir file))
+ (while (and (stringp dir)
+ (not (equal dir (setq dir (file-name-directory dir))))
+ dir)
+ (setq dir (if (file-exists-p
+ (expand-file-name "CVS/Entries" dir))
+ t
+ (directory-file-name dir))))
+ (eq dir t)))
+
+(defun vc-cvs-checkin (files rev comment &optional extra-args-ignored)
+ "CVS-specific version of `vc-backend-checkin'."
+ (unless (or (not rev) (vc-cvs-valid-revision-number-p rev))
+ (if (not (vc-cvs-valid-symbolic-tag-name-p rev))
+ (error "%s is not a valid symbolic tag name" rev)
+ ;; If the input revison is a valid symbolic tag name, we create it
+ ;; as a branch, commit and switch to it.
+ (apply 'vc-cvs-command nil 0 files "tag" "-b" (list rev))
+ (apply 'vc-cvs-command nil 0 files "update" "-r" (list rev))
+ (mapc (lambda (file) (vc-file-setprop file 'vc-cvs-sticky-tag rev))
+ files)))
+ (let ((status (apply 'vc-cvs-command nil 1 files
+ "ci" (if rev (concat "-r" rev))
+ (concat "-m" comment)
+ (vc-switches 'CVS 'checkin))))
+ (set-buffer "*vc*")
+ (goto-char (point-min))
+ (when (not (zerop status))
+ ;; Check checkin problem.
+ (cond
+ ((re-search-forward "Up-to-date check failed" nil t)
+ (mapc (lambda (file) (vc-file-setprop file 'vc-state 'needs-merge))
+ files)
+ (error "%s" (substitute-command-keys
+ (concat "Up-to-date check failed: "
+ "type \\[vc-next-action] to merge in changes"))))
+ (t
+ (pop-to-buffer (current-buffer))
+ (goto-char (point-min))
+ (shrink-window-if-larger-than-buffer)
+ (error "Check-in failed"))))
+ ;; Single-file commit? Then update the revision by parsing the buffer.
+ ;; Otherwise we can't necessarily tell what goes with what; clear
+ ;; its properties so they have to be refetched.
+ (if (= (length files) 1)
+ (vc-file-setprop
+ (car files) 'vc-working-revision
+ (vc-parse-buffer "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" 2))
+ (mapc 'vc-file-clearprops files))
+ ;; Anyway, forget the checkout model of the file, because we might have
+ ;; guessed wrong when we found the file. After commit, we can
+ ;; tell it from the permissions of the file (see
+ ;; vc-cvs-checkout-model).
+ (mapc (lambda (file) (vc-file-setprop file 'vc-checkout-model nil))
+ files)
+
+ ;; if this was an explicit check-in (does not include creation of
+ ;; a branch), remove the sticky tag.
+ (if (and rev (not (vc-cvs-valid-symbolic-tag-name-p rev)))
+ (vc-cvs-command nil 0 files "update" "-A"))))
+
+(defun vc-cvs-find-revision (file rev buffer)
+ (apply 'vc-cvs-command
+ buffer 0 file
+ "-Q" ; suppress diagnostic output
+ "update"
+ (and rev (not (string= rev ""))
+ (concat "-r" rev))
+ "-p"
+ (vc-switches 'CVS 'checkout)))
+
+(defun vc-cvs-checkout (file &optional editable rev)
+ "Checkout a revision of FILE into the working area.
+EDITABLE non-nil means that the file should be writable.
+REV is the revision to check out."
+ (message "Checking out %s..." file)
+ ;; Change buffers to get local value of vc-checkout-switches.
+ (with-current-buffer (or (get-file-buffer file) (current-buffer))
+ (if (and (file-exists-p file) (not rev))
+ ;; If no revision was specified, just make the file writable
+ ;; if necessary (using `cvs-edit' if requested).
+ (and editable (not (eq (vc-cvs-checkout-model (list file)) 'implicit))
+ (if vc-cvs-use-edit
+ (vc-cvs-command nil 0 file "edit")
+ (set-file-modes file (logior (file-modes file) 128))
+ (if (equal file buffer-file-name) (toggle-read-only -1))))
+ ;; Check out a particular revision (or recreate the file).
+ (vc-file-setprop file 'vc-working-revision nil)
+ (apply 'vc-cvs-command nil 0 file
+ (and editable "-w")
+ "update"
+ (when rev
+ (unless (eq rev t)
+ ;; default for verbose checkout: clear the
+ ;; sticky tag so that the actual update will
+ ;; get the head of the trunk
+ (if (string= rev "")
+ "-A"
+ (concat "-r" rev))))
+ (vc-switches 'CVS 'checkout)))
+ (vc-mode-line file 'CVS))
+ (message "Checking out %s...done" file))
+
+(defun vc-cvs-delete-file (file)
+ (vc-cvs-command nil 0 file "remove" "-f"))
+
+(defun vc-cvs-revert (file &optional contents-done)
+ "Revert FILE to the working revision on which it was based."
+ (vc-default-revert 'CVS file contents-done)
+ (unless (eq (vc-cvs-checkout-model (list file)) 'implicit)
+ (if vc-cvs-use-edit
+ (vc-cvs-command nil 0 file "unedit")
+ ;; Make the file read-only by switching off all w-bits
+ (set-file-modes file (logand (file-modes file) 3950)))))
+
+(defun vc-cvs-merge (file first-revision &optional second-revision)
+ "Merge changes into current working copy of FILE.
+The changes are between FIRST-REVISION and SECOND-REVISION."
+ (vc-cvs-command nil 0 file
+ "update" "-kk"
+ (concat "-j" first-revision)
+ (concat "-j" second-revision))
+ (vc-file-setprop file 'vc-state 'edited)
+ (with-current-buffer (get-buffer "*vc*")
+ (goto-char (point-min))
+ (if (re-search-forward "conflicts during merge" nil t)
+ (progn
+ (vc-file-setprop file 'vc-state 'conflict)
+ ;; signal error
+ 1)
+ (vc-file-setprop file 'vc-state 'edited)
+ ;; signal success
+ 0)))
+
+(defun vc-cvs-merge-news (file)
+ "Merge in any new changes made to FILE."
+ (message "Merging changes into %s..." file)
+ ;; (vc-file-setprop file 'vc-working-revision nil)
+ (vc-file-setprop file 'vc-checkout-time 0)
+ (vc-cvs-command nil nil file "update")
+ ;; Analyze the merge result reported by CVS, and set
+ ;; file properties accordingly.
+ (with-current-buffer (get-buffer "*vc*")
+ (goto-char (point-min))
+ ;; get new working revision
+ (if (re-search-forward
+ "^Merging differences between [0-9.]* and \\([0-9.]*\\) into" nil t)
+ (vc-file-setprop file 'vc-working-revision (match-string 1))
+ (vc-file-setprop file 'vc-working-revision nil))
+ ;; get file status
+ (prog1
+ (if (eq (buffer-size) 0)
+ 0 ;; there were no news; indicate success
+ (if (re-search-forward
+ (concat "^\\([CMUP] \\)?"
+ (regexp-quote
+ (substring file (1+ (length (expand-file-name
+ "." default-directory)))))
+ "\\( already contains the differences between \\)?")
+ nil t)
+ (cond
+ ;; Merge successful, we are in sync with repository now
+ ((or (match-string 2)
+ (string= (match-string 1) "U ")
+ (string= (match-string 1) "P "))
+ (vc-file-setprop file 'vc-state 'up-to-date)
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file)))
+ 0);; indicate success to the caller
+ ;; Merge successful, but our own changes are still in the file
+ ((string= (match-string 1) "M ")
+ (vc-file-setprop file 'vc-state 'edited)
+ 0);; indicate success to the caller
+ ;; Conflicts detected!
+ (t
+ (vc-file-setprop file 'vc-state 'conflict)
+ 1);; signal the error to the caller
+ )
+ (pop-to-buffer "*vc*")
+ (error "Couldn't analyze cvs update result")))
+ (message "Merging changes into %s...done" file))))
+
+(defun vc-cvs-modify-change-comment (files rev comment)
+ "Modify the change comments for FILES on a specified REV.
+Will fail unless you have administrative privileges on the repo."
+ (vc-cvs-command nil 0 files "admin" (concat "-m" rev ":" comment)))
+
+;;;
+;;; History functions
+;;;
+
+(declare-function vc-rcs-print-log-cleanup "vc-rcs" ())
+
+(defun vc-cvs-print-log (files buffer &optional shortlog start-revision-ignored limit)
+ "Get change logs associated with FILES."
+ (require 'vc-rcs)
+ ;; It's just the catenation of the individual logs.
+ (vc-cvs-command
+ buffer
+ (if (vc-stay-local-p files 'CVS) 'async 0)
+ files "log")
+ (with-current-buffer buffer
+ (vc-exec-after (vc-rcs-print-log-cleanup)))
+ (when limit 'limit-unsupported))
+
+(defun vc-cvs-comment-history (file)
+ "Get comment history of a file."
+ (vc-call-backend 'RCS 'comment-history file))
+
+(defun vc-cvs-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using CVS between two revisions of FILE."
+ (let* (process-file-side-effects
+ (async (and (not vc-disable-async-diff)
+ (vc-stay-local-p files 'CVS)))
+ (invoke-cvs-diff-list nil)
+ status)
+ ;; Look through the file list and see if any files have backups
+ ;; that can be used to do a plain "diff" instead of "cvs diff".
+ (dolist (file files)
+ (let ((ov oldvers)
+ (nv newvers))
+ (when (or (not ov) (string-equal ov ""))
+ (setq ov (vc-working-revision file)))
+ (when (string-equal nv "")
+ (setq nv nil))
+ (let ((file-oldvers (vc-version-backup-file file ov))
+ (file-newvers (if (not nv)
+ file
+ (vc-version-backup-file file nv)))
+ (coding-system-for-read (vc-coding-system-for-diff file)))
+ (if (and file-oldvers file-newvers)
+ (progn
+ ;; This used to append diff-switches and vc-diff-switches,
+ ;; which was consistent with the vc-diff-switches doc at that
+ ;; time, but not with the actual behavior of any other VC diff.
+ (apply 'vc-do-command (or buffer "*vc-diff*") 1 "diff" nil
+ ;; Not a CVS diff, does not use vc-cvs-diff-switches.
+ (append (vc-switches nil 'diff)
+ (list (file-relative-name file-oldvers)
+ (file-relative-name file-newvers))))
+ (setq status 0))
+ (push file invoke-cvs-diff-list)))))
+ (when invoke-cvs-diff-list
+ (setq status (apply 'vc-cvs-command (or buffer "*vc-diff*")
+ (if async 'async 1)
+ invoke-cvs-diff-list "diff"
+ (and oldvers (concat "-r" oldvers))
+ (and newvers (concat "-r" newvers))
+ (vc-switches 'CVS 'diff))))
+ (if async 1 status))) ; async diff, pessimistic assumption
+
+(defconst vc-cvs-annotate-first-line-re "^[0-9]")
+
+(defun vc-cvs-annotate-process-filter (process string)
+ (setq string (concat (process-get process 'output) string))
+ (if (not (string-match vc-cvs-annotate-first-line-re string))
+ ;; Still waiting for the first real line.
+ (process-put process 'output string)
+ (let ((vc-filter (process-get process 'vc-filter)))
+ (set-process-filter process vc-filter)
+ (funcall vc-filter process (substring string (match-beginning 0))))))
+
+(defun vc-cvs-annotate-command (file buffer &optional revision)
+ "Execute \"cvs annotate\" on FILE, inserting the contents in BUFFER.
+Optional arg REVISION is a revision to annotate from."
+ (vc-cvs-command buffer
+ (if (vc-stay-local-p file 'CVS)
+ 'async 0)
+ file "annotate"
+ (if revision (concat "-r" revision)))
+ ;; Strip the leading few lines.
+ (let ((proc (get-buffer-process buffer)))
+ (if proc
+ ;; If running asynchronously, use a process filter.
+ (progn
+ (process-put proc 'vc-filter (process-filter proc))
+ (set-process-filter proc 'vc-cvs-annotate-process-filter))
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (re-search-forward vc-cvs-annotate-first-line-re)
+ (delete-region (point-min) (1- (point)))))))
+
+(declare-function vc-annotate-convert-time "vc-annotate" (time))
+
+(defun vc-cvs-annotate-current-time ()
+ "Return the current time, based at midnight of the current day, and
+encoded as fractional days."
+ (vc-annotate-convert-time
+ (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time))))))
+
+(defun vc-cvs-annotate-time ()
+ "Return the time of the next annotation (as fraction of days)
+systime, or nil if there is none."
+ (let* ((bol (point))
+ (cache (get-text-property bol 'vc-cvs-annotate-time))
+ (inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (cond
+ (cache)
+ ((looking-at
+ "^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): ")
+ (let ((day (string-to-number (match-string 1)))
+ (month (cdr (assq (intern (match-string 2))
+ '((Jan . 1) (Feb . 2) (Mar . 3)
+ (Apr . 4) (May . 5) (Jun . 6)
+ (Jul . 7) (Aug . 8) (Sep . 9)
+ (Oct . 10) (Nov . 11) (Dec . 12)))))
+ (year (let ((tmp (string-to-number (match-string 3))))
+ ;; Years 0..68 are 2000..2068.
+ ;; Years 69..99 are 1969..1999.
+ (+ (cond ((> 69 tmp) 2000)
+ ((> 100 tmp) 1900)
+ (t 0))
+ tmp))))
+ (put-text-property
+ bol (1+ bol) 'vc-cvs-annotate-time
+ (setq cache (cons
+ ;; Position at end makes for nicer overlay result.
+ ;; Don't put actual buffer pos here, but only relative
+ ;; distance, so we don't ever move backward in the
+ ;; goto-char below, even if the text is moved.
+ (- (match-end 0) (match-beginning 0))
+ (vc-annotate-convert-time
+ (encode-time 0 0 0 day month year))))))))
+ (when cache
+ (goto-char (+ bol (car cache))) ; Fontify from here to eol.
+ (cdr cache)))) ; days (float)
+
+(defun vc-cvs-annotate-extract-revision-at-line ()
+ (save-excursion
+ (beginning-of-line)
+ (if (re-search-forward "^\\([0-9]+\\.[0-9]+\\(\\.[0-9]+\\)*\\) +("
+ (line-end-position) t)
+ (match-string-no-properties 1)
+ nil)))
+
+(defun vc-cvs-previous-revision (file rev)
+ (vc-call-backend 'RCS 'previous-revision file rev))
+
+(defun vc-cvs-next-revision (file rev)
+ (vc-call-backend 'RCS 'next-revision file rev))
+
+;; FIXME: This should probably be replaced by code using cvs2cl.
+(defun vc-cvs-update-changelog (files)
+ (vc-call-backend 'RCS 'update-changelog files))
+
+;;;
+;;; Tag system
+;;;
+
+(defun vc-cvs-create-tag (dir name branchp)
+ "Assign to DIR's current revision a given NAME.
+If BRANCHP is non-nil, the name is created as a branch (and the current
+workspace is immediately moved to that new branch)."
+ (vc-cvs-command nil 0 dir "tag" "-c" (if branchp "-b") name)
+ (when branchp (vc-cvs-command nil 0 dir "update" "-r" name)))
+
+(defun vc-cvs-retrieve-tag (dir name update)
+ "Retrieve a tag at and below DIR.
+NAME is the name of the tag; if it is empty, do a `cvs update'.
+If UPDATE is non-nil, then update (resynch) any affected buffers."
+ (with-current-buffer (get-buffer-create "*vc*")
+ (let ((default-directory dir)
+ (sticky-tag))
+ (erase-buffer)
+ (if (or (not name) (string= name ""))
+ (vc-cvs-command t 0 nil "update")
+ (vc-cvs-command t 0 nil "update" "-r" name)
+ (setq sticky-tag name))
+ (when update
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at "\\([CMUP]\\) \\(.*\\)")
+ (let* ((file (expand-file-name (match-string 2) dir))
+ (state (match-string 1))
+ (buffer (find-buffer-visiting file)))
+ (when buffer
+ (cond
+ ((or (string= state "U")
+ (string= state "P"))
+ (vc-file-setprop file 'vc-state 'up-to-date)
+ (vc-file-setprop file 'vc-working-revision nil)
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file))))
+ ((or (string= state "M")
+ (string= state "C"))
+ (vc-file-setprop file 'vc-state 'edited)
+ (vc-file-setprop file 'vc-working-revision nil)
+ (vc-file-setprop file 'vc-checkout-time 0)))
+ (vc-file-setprop file 'vc-cvs-sticky-tag sticky-tag)
+ (vc-resynch-buffer file t t))))
+ (forward-line 1))))))
+
+
+;;;
+;;; Miscellaneous
+;;;
+
+(defun vc-cvs-make-version-backups-p (file)
+ "Return non-nil if version backups should be made for FILE."
+ (vc-stay-local-p file 'CVS))
+
+(defun vc-cvs-check-headers ()
+ "Check if the current file has any headers in it."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))
+
+
+;;;
+;;; Internal functions
+;;;
+
+(defun vc-cvs-command (buffer okstatus files &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-cvs.el.
+The difference to vc-do-command is that this function always invokes `cvs',
+and that it passes `vc-cvs-global-switches' to it before FLAGS."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus "cvs" files
+ (if (stringp vc-cvs-global-switches)
+ (cons vc-cvs-global-switches flags)
+ (append vc-cvs-global-switches
+ flags))))
+
+(defun vc-cvs-stay-local-p (file) ;Back-compatibility.
+ (vc-stay-local-p file 'CVS))
+
+(defun vc-cvs-repository-hostname (dirname)
+ "Hostname of the CVS server associated to workarea DIRNAME."
+ (let ((rootname (expand-file-name "CVS/Root" dirname)))
+ (when (file-readable-p rootname)
+ (with-temp-buffer
+ (let ((coding-system-for-read
+ (or file-name-coding-system
+ default-file-name-coding-system)))
+ (vc-insert-file rootname))
+ (goto-char (point-min))
+ (nth 2 (vc-cvs-parse-root
+ (buffer-substring (point)
+ (line-end-position))))))))
+
+(defun vc-cvs-parse-uhp (path)
+ "parse user@host/path into (user@host /path)"
+ (if (string-match "\\([^/]+\\)\\(/.*\\)" path)
+ (list (match-string 1 path) (match-string 2 path))
+ (list nil path)))
+
+(defun vc-cvs-parse-root (root)
+ "Split CVS ROOT specification string into a list of fields.
+A CVS root specification of the form
+ [:METHOD:][[USER@]HOSTNAME]:?/path/to/repository
+is converted to a normalized record with the following structure:
+ \(METHOD USER HOSTNAME CVS-ROOT).
+The default METHOD for a CVS root of the form
+ /path/to/repository
+is `local'.
+The default METHOD for a CVS root of the form
+ [USER@]HOSTNAME:/path/to/repository
+is `ext'.
+For an empty string, nil is returned (invalid CVS root)."
+ ;; Split CVS root into colon separated fields (0-4).
+ ;; The `x:' makes sure, that leading colons are not lost;
+ ;; `HOST:/PATH' is then different from `:METHOD:/PATH'.
+ (let* ((root-list (cdr (split-string (concat "x:" root) ":")))
+ (len (length root-list))
+ ;; All syntactic varieties will get a proper METHOD.
+ (root-list
+ (cond
+ ((= len 0)
+ ;; Invalid CVS root
+ nil)
+ ((= len 1)
+ (let ((uhp (vc-cvs-parse-uhp (car root-list))))
+ (cons (if (car uhp) "ext" "local") uhp)))
+ ((= len 2)
+ ;; [USER@]HOST:PATH => method `ext'
+ (and (not (equal (car root-list) ""))
+ (cons "ext" root-list)))
+ ((= len 3)
+ ;; :METHOD:PATH or :METHOD:USER@HOSTNAME/PATH
+ (cons (cadr root-list)
+ (vc-cvs-parse-uhp (caddr root-list))))
+ (t
+ ;; :METHOD:[USER@]HOST:PATH
+ (cdr root-list)))))
+ (if root-list
+ (let ((method (car root-list))
+ (uhost (or (cadr root-list) ""))
+ (root (nth 2 root-list))
+ user host)
+ ;; Split USER@HOST
+ (if (string-match "\\(.*\\)@\\(.*\\)" uhost)
+ (setq user (match-string 1 uhost)
+ host (match-string 2 uhost))
+ (setq host uhost))
+ ;; Remove empty HOST
+ (and (equal host "")
+ (setq host))
+ ;; Fix windows style CVS root `:local:C:\\project\\cvs\\some\\dir'
+ (and host
+ (equal method "local")
+ (setq root (concat host ":" root) host))
+ ;; Normalize CVS root record
+ (list method user host root)))))
+
+;; XXX: This does not work correctly for subdirectories. "cvs status"
+;; information is context sensitive, it contains lines like:
+;; cvs status: Examining DIRNAME
+;; and the file entries after that don't show the full path.
+;; Because of this VC directory listings only show changed files
+;; at the top level for CVS.
+(defun vc-cvs-parse-status (&optional full)
+ "Parse output of \"cvs status\" command in the current buffer.
+Set file properties accordingly. Unless FULL is t, parse only
+essential information. Note that this can never set the 'ignored
+state."
+ (let (file status missing)
+ (goto-char (point-min))
+ (while (looking-at "? \\(.*\\)")
+ (setq file (expand-file-name (match-string 1)))
+ (vc-file-setprop file 'vc-state 'unregistered)
+ (forward-line 1))
+ (when (re-search-forward "^File: " nil t)
+ (when (setq missing (looking-at "no file "))
+ (goto-char (match-end 0)))
+ (cond
+ ((re-search-forward "\\=\\([^ \t]+\\)" nil t)
+ (setq file (expand-file-name (match-string 1)))
+ (setq status(if (re-search-forward "\\=[ \t]+Status: \\(.*\\)" nil t)
+ (match-string 1) "Unknown"))
+ (when (and full
+ (re-search-forward
+ "\\(RCS Version\\|RCS Revision\\|Repository revision\\):\
+\[\t ]+\\([0-9.]+\\)"
+ nil t))
+ (vc-file-setprop file 'vc-latest-revision (match-string 2)))
+ (vc-file-setprop
+ file 'vc-state
+ (cond
+ ((string-match "Up-to-date" status)
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file)))
+ 'up-to-date)
+ ((string-match "Locally Modified" status) 'edited)
+ ((string-match "Needs Merge" status) 'needs-merge)
+ ((string-match "Needs \\(Checkout\\|Patch\\)" status)
+ (if missing 'missing 'needs-update))
+ ((string-match "Locally Added" status) 'added)
+ ((string-match "Locally Removed" status) 'removed)
+ ((string-match "File had conflicts " status) 'conflict)
+ ((string-match "Unknown" status) 'unregistered)
+ (t 'edited))))))))
+
+(defun vc-cvs-after-dir-status (update-function)
+ ;; Heavily inspired by vc-cvs-parse-status. AKA a quick hack.
+ ;; This needs a lot of testing.
+ (let ((status nil)
+ (status-str nil)
+ (file nil)
+ (result nil)
+ (missing nil)
+ (ignore-next nil)
+ (subdir default-directory))
+ (goto-char (point-min))
+ (while
+ ;; Look for either a file entry, an unregistered file, or a
+ ;; directory change.
+ (re-search-forward
+ "\\(^=+\n\\([^=c?\n].*\n\\|\n\\)+\\)\\|\\(\\(^?? .*\n\\)+\\)\\|\\(^cvs status: \\(Examining\\|nothing\\) .*\n\\)"
+ nil t)
+ ;; FIXME: get rid of narrowing here.
+ (narrow-to-region (match-beginning 0) (match-end 0))
+ (goto-char (point-min))
+ ;; The subdir
+ (when (looking-at "cvs status: Examining \\(.+\\)")
+ (setq subdir (expand-file-name (match-string 1))))
+ ;; Unregistered files
+ (while (looking-at "? \\(.*\\)")
+ (setq file (file-relative-name
+ (expand-file-name (match-string 1) subdir)))
+ (push (list file 'unregistered) result)
+ (forward-line 1))
+ (when (looking-at "cvs status: nothing known about")
+ ;; We asked about a non existent file. The output looks like this:
+
+ ;; cvs status: nothing known about `lisp/v.diff'
+ ;; ===================================================================
+ ;; File: no file v.diff Status: Unknown
+ ;;
+ ;; Working revision: No entry for v.diff
+ ;; Repository revision: No revision control file
+ ;;
+
+ ;; Due to narrowing in this iteration we only see the "cvs
+ ;; status:" line, so just set a flag so that we can ignore the
+ ;; file in the next iteration.
+ (setq ignore-next t))
+ ;; A file entry.
+ (when (re-search-forward "^File: \\(no file \\)?\\(.*[^ \t]\\)[ \t]+Status: \\(.*\\)" nil t)
+ (setq missing (match-string 1))
+ (setq file (file-relative-name
+ (expand-file-name (match-string 2) subdir)))
+ (setq status-str (match-string 3))
+ (setq status
+ (cond
+ ((string-match "Up-to-date" status-str) 'up-to-date)
+ ((string-match "Locally Modified" status-str) 'edited)
+ ((string-match "Needs Merge" status-str) 'needs-merge)
+ ((string-match "Needs \\(Checkout\\|Patch\\)" status-str)
+ (if missing 'missing 'needs-update))
+ ((string-match "Locally Added" status-str) 'added)
+ ((string-match "Locally Removed" status-str) 'removed)
+ ((string-match "File had conflicts " status-str) 'conflict)
+ ((string-match "Unknown" status-str) 'unregistered)
+ (t 'edited)))
+ (if ignore-next
+ (setq ignore-next nil)
+ (unless (eq status 'up-to-date)
+ (push (list file status) result))))
+ (goto-char (point-max))
+ (widen))
+ (funcall update-function result))
+ ;; Alternative implementation: use the "update" command instead of
+ ;; the "status" command.
+ ;; (let ((result nil)
+ ;; (translation '((?? . unregistered)
+ ;; (?A . added)
+ ;; (?C . conflict)
+ ;; (?M . edited)
+ ;; (?P . needs-merge)
+ ;; (?R . removed)
+ ;; (?U . needs-update))))
+ ;; (goto-char (point-min))
+ ;; (while (not (eobp))
+ ;; (if (looking-at "^[ACMPRU?] \\(.*\\)$")
+ ;; (push (list (match-string 1)
+ ;; (cdr (assoc (char-after) translation)))
+ ;; result)
+ ;; (cond
+ ;; ((looking-at "cvs update: warning: \\(.*\\) was lost")
+ ;; ;; Format is:
+ ;; ;; cvs update: warning: FILENAME was lost
+ ;; ;; U FILENAME
+ ;; (push (list (match-string 1) 'missing) result)
+ ;; ;; Skip the "U" line
+ ;; (forward-line 1))
+ ;; ((looking-at "cvs update: New directory `\\(.*\\)' -- ignored")
+ ;; (push (list (match-string 1) 'unregistered) result))))
+ ;; (forward-line 1))
+ ;; (funcall update-function result)))
+ )
+
+;; Based on vc-cvs-dir-state-heuristic from Emacs 22.
+;; FIXME does not mention unregistered files.
+(defun vc-cvs-dir-status-heuristic (dir update-function &optional basedir)
+ "Find the CVS state of all files in DIR, using only local information."
+ (let (file basename status result dirlist)
+ (with-temp-buffer
+ (vc-cvs-get-entries dir)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at "D/\\([^/]*\\)////")
+ (push (expand-file-name (match-string 1) dir) dirlist)
+ ;; CVS-removed files are not taken under VC control.
+ (when (looking-at "/\\([^/]*\\)/[^/-]")
+ (setq basename (match-string 1)
+ file (expand-file-name basename dir)
+ status (or (vc-file-getprop file 'vc-state)
+ (vc-cvs-parse-entry file t)))
+ (unless (eq status 'up-to-date)
+ (push (list (if basedir
+ (file-relative-name file basedir)
+ basename)
+ status) result))))
+ (forward-line 1)))
+ (dolist (subdir dirlist)
+ (setq result (append result
+ (vc-cvs-dir-status-heuristic subdir nil
+ (or basedir dir)))))
+ (if basedir result
+ (funcall update-function result))))
+
+(defun vc-cvs-dir-status (dir update-function)
+ "Create a list of conses (file . state) for DIR."
+ ;; FIXME check all files in DIR instead?
+ (let ((local (vc-stay-local-p dir 'CVS)))
+ (if (and local (not (eq local 'only-file)))
+ (vc-cvs-dir-status-heuristic dir update-function)
+ (vc-cvs-command (current-buffer) 'async dir "-f" "status")
+ ;; Alternative implementation: use the "update" command instead of
+ ;; the "status" command.
+ ;; (vc-cvs-command (current-buffer) 'async
+ ;; (file-relative-name dir)
+ ;; "-f" "-n" "update" "-d" "-P")
+ (vc-exec-after
+ `(vc-cvs-after-dir-status (quote ,update-function))))))
+
+(defun vc-cvs-dir-status-files (dir files default-state update-function)
+ "Create a list of conses (file . state) for DIR."
+ (apply 'vc-cvs-command (current-buffer) 'async dir "-f" "status" files)
+ (vc-exec-after
+ `(vc-cvs-after-dir-status (quote ,update-function))))
+
+(defun vc-cvs-file-to-string (file)
+ "Read the content of FILE and return it as a string."
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (buffer-substring (point) (point-max)))
+ (file-error nil)))
+
+(defun vc-cvs-dir-extra-headers (dir)
+ "Extract and represent per-directory properties of a CVS working copy."
+ (let ((repo
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents "CVS/Root")
+ (goto-char (point-min))
+ (and (looking-at ":ext:") (delete-char 5))
+ (concat (buffer-substring (point) (1- (point-max))) "\n"))
+ (file-error nil)))
+ (module
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents "CVS/Repository")
+ (goto-char (point-min))
+ (skip-chars-forward "^\n")
+ (concat (buffer-substring (point-min) (point)) "\n"))
+ (file-error nil))))
+ (concat
+ (cond (repo
+ (concat (propertize "Repository : " 'face 'font-lock-type-face)
+ (propertize repo 'face 'font-lock-variable-name-face)))
+ (t ""))
+ (cond (module
+ (concat (propertize "Module : " 'face 'font-lock-type-face)
+ (propertize module 'face 'font-lock-variable-name-face)))
+ (t ""))
+ (if (file-readable-p "CVS/Tag")
+ (let ((tag (vc-cvs-file-to-string "CVS/Tag")))
+ (cond
+ ((string-match "\\`T" tag)
+ (concat (propertize "Tag : " 'face 'font-lock-type-face)
+ (propertize (substring tag 1)
+ 'face 'font-lock-variable-name-face)))
+ ((string-match "\\`D" tag)
+ (concat (propertize "Date : " 'face 'font-lock-type-face)
+ (propertize (substring tag 1)
+ 'face 'font-lock-variable-name-face)))
+ (t ""))))
+
+ ;; In CVS, branch is a per-file property, not a per-directory property.
+ ;; We can't really do this here without making dangerous assumptions.
+ ;;(propertize "Branch: " 'face 'font-lock-type-face)
+ ;;(propertize "ADD CODE TO PRINT THE BRANCH NAME\n"
+ ;; 'face 'font-lock-warning-face)
+ )))
+
+(defun vc-cvs-get-entries (dir)
+ "Insert the CVS/Entries file from below DIR into the current buffer.
+This function ensures that the correct coding system is used for that,
+which may not be the one that is used for the files' contents.
+CVS/Entries should only be accessed through this function."
+ (let ((coding-system-for-read (or file-name-coding-system
+ default-file-name-coding-system)))
+ (vc-insert-file (expand-file-name "CVS/Entries" dir))))
+
+(defun vc-cvs-valid-symbolic-tag-name-p (tag)
+ "Return non-nil if TAG is a valid symbolic tag name."
+ ;; According to the CVS manual, a valid symbolic tag must start with
+ ;; an uppercase or lowercase letter and can contain uppercase and
+ ;; lowercase letters, digits, `-', and `_'.
+ (and (string-match "^[a-zA-Z]" tag)
+ (not (string-match "[^a-z0-9A-Z-_]" tag))))
+
+(defun vc-cvs-valid-revision-number-p (tag)
+ "Return non-nil if TAG is a valid revision number."
+ (and (string-match "^[0-9]" tag)
+ (not (string-match "[^0-9.]" tag))))
+
+(defun vc-cvs-parse-sticky-tag (match-type match-tag)
+ "Parse and return the sticky tag as a string.
+`match-data' is protected."
+ (let ((data (match-data))
+ (tag)
+ (type (cond ((string= match-type "D") 'date)
+ ((string= match-type "T")
+ (if (vc-cvs-valid-symbolic-tag-name-p match-tag)
+ 'symbolic-name
+ 'revision-number))
+ (t nil))))
+ (unwind-protect
+ (progn
+ (cond
+ ;; Sticky Date tag. Convert to a proper date value (`encode-time')
+ ((eq type 'date)
+ (string-match
+ "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)"
+ match-tag)
+ (let* ((year-tmp (string-to-number (match-string 1 match-tag)))
+ (month (string-to-number (match-string 2 match-tag)))
+ (day (string-to-number (match-string 3 match-tag)))
+ (hour (string-to-number (match-string 4 match-tag)))
+ (min (string-to-number (match-string 5 match-tag)))
+ (sec (string-to-number (match-string 6 match-tag)))
+ ;; Years 0..68 are 2000..2068.
+ ;; Years 69..99 are 1969..1999.
+ (year (+ (cond ((> 69 year-tmp) 2000)
+ ((> 100 year-tmp) 1900)
+ (t 0))
+ year-tmp)))
+ (setq tag (encode-time sec min hour day month year))))
+ ;; Sticky Tag name or revision number
+ ((eq type 'symbolic-name) (setq tag match-tag))
+ ((eq type 'revision-number) (setq tag match-tag))
+ ;; Default is no sticky tag at all
+ (t nil))
+ (cond ((eq vc-cvs-sticky-tag-display nil) nil)
+ ((eq vc-cvs-sticky-tag-display t)
+ (cond ((eq type 'date) (format-time-string
+ vc-cvs-sticky-date-format-string
+ tag))
+ ((eq type 'symbolic-name) tag)
+ ((eq type 'revision-number) tag)
+ (t nil)))
+ ((functionp vc-cvs-sticky-tag-display)
+ (funcall vc-cvs-sticky-tag-display tag type))
+ (t nil)))
+
+ (set-match-data data))))
+
+(defun vc-cvs-parse-entry (file &optional set-state)
+ "Parse a line from CVS/Entries.
+Compare modification time to that of the FILE, set file properties
+accordingly. However, `vc-state' is set only if optional arg SET-STATE
+is non-nil."
+ (cond
+ ;; entry for a "locally added" file (not yet committed)
+ ((looking-at "/[^/]+/0/")
+ (vc-file-setprop file 'vc-checkout-time 0)
+ (vc-file-setprop file 'vc-working-revision "0")
+ (if set-state (vc-file-setprop file 'vc-state 'added)))
+ ;; normal entry
+ ((looking-at
+ (concat "/[^/]+"
+ ;; revision
+ "/\\([^/]*\\)"
+ ;; timestamp and optional conflict field
+ "/\\([^/]*\\)/"
+ ;; options
+ "\\([^/]*\\)/"
+ ;; sticky tag
+ "\\(.\\|\\)" ;Sticky tag type (date or tag name, could be empty)
+ "\\(.*\\)")) ;Sticky tag
+ (vc-file-setprop file 'vc-working-revision (match-string 1))
+ (vc-file-setprop file 'vc-cvs-sticky-tag
+ (vc-cvs-parse-sticky-tag (match-string 4)
+ (match-string 5)))
+ ;; Compare checkout time and modification time.
+ ;; This is intentionally different from the algorithm that CVS uses
+ ;; (which is based on textual comparison), because there can be problems
+ ;; generating a time string that looks exactly like the one from CVS.
+ (let* ((time (match-string 2))
+ (mtime (nth 5 (file-attributes file)))
+ (parsed-time (progn (require 'parse-time)
+ (parse-time-string (concat time " +0000")))))
+ (cond ((and (not (string-match "\\+" time))
+ (car parsed-time)
+ (equal mtime (apply 'encode-time parsed-time)))
+ (vc-file-setprop file 'vc-checkout-time mtime)
+ (if set-state (vc-file-setprop file 'vc-state 'up-to-date)))
+ (t
+ (vc-file-setprop file 'vc-checkout-time 0)
+ (if set-state (vc-file-setprop file 'vc-state 'edited))))))))
+
+;; Completion of revision names.
+;; Just so I don't feel like I'm duplicating code from pcl-cvs, I'll use
+;; `cvs log' so I can list all the revision numbers rather than only
+;; tag names.
+
+(defun vc-cvs-revision-table (file)
+ (let (process-file-side-effects
+ (default-directory (file-name-directory file))
+ (res nil))
+ (with-temp-buffer
+ (vc-cvs-command t nil file "log")
+ (goto-char (point-min))
+ (when (re-search-forward "^symbolic names:\n" nil t)
+ (while (looking-at "^ \\(.*\\): \\(.*\\)")
+ (push (cons (match-string 1) (match-string 2)) res)
+ (forward-line 1)))
+ (while (re-search-forward "^revision \\([0-9.]+\\)" nil t)
+ (push (match-string 1) res))
+ res)))
+
+(defun vc-cvs-revision-completion-table (files)
+ (lexical-let ((files files)
+ table)
+ (setq table (lazy-completion-table
+ table (lambda () (vc-cvs-revision-table (car files)))))
+ table))
+
+
+(provide 'vc-cvs)
+
+;; arch-tag: 60e1402a-aa53-4607-927a-cf74f144b432
+;;; vc-cvs.el ends here
--- /dev/null
+;;; vc-dav.el --- vc.el support for WebDAV
+
+;; Copyright (C) 2001, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Bill Perry <wmperry@gnu.org>
+;; Maintainer: Bill Perry <wmperry@gnu.org>
+;; Keywords: url, vc
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary:
+
+;;; Todo:
+;;
+;; - Some methods need to be updated to match the current vc.el.
+;; - rename "version" -> "revision"
+;; - some methods need to take a fileset as a parameter instead of a
+;; single file.
+
+;;; Code:
+
+(require 'url)
+(require 'url-dav)
+
+;;; Required functions for a vc backend
+(defun vc-dav-registered (url)
+ "Return t if URL is registered with a DAV aware server."
+ (url-dav-vc-registered url))
+
+(defun vc-dav-state (url)
+ "Return the current version control state of URL.
+For a list of possible values, see `vc-state'."
+ ;; Things we can support for WebDAV
+ ;;
+ ;; up-to-date - use lockdiscovery
+ ;; edited - check for an active lock by us
+ ;; USER - use lockdiscovery + owner
+ ;;
+ ;; These don't make sense for WebDAV
+ ;; needs-patch
+ ;; needs-merge
+ ;; unlocked-changes
+ (let ((locks (url-dav-active-locks url)))
+ (cond
+ ((null locks) 'up-to-date)
+ ((assoc url locks)
+ ;; SOMEBODY has a lock... let's find out who.
+ (setq locks (cdr (assoc url locks)))
+ (if (rassoc url-dav-lock-identifier locks)
+ ;; _WE_ have a lock
+ 'edited
+ (cdr (car locks)))))))
+
+(defun vc-dav-checkout-model (url)
+ "Indicate whether URL needs to be \"checked out\" before it can be edited.
+See `vc-checkout-model' for a list of possible values."
+ ;; The only thing we can support with webdav is 'locking
+ 'locking)
+
+;; This should figure out the version # of the file somehow. What is
+;; the most appropriate property in WebDAV to look at for this?
+(defun vc-dav-workfile-version (url)
+ "Return the current workfile version of URL."
+ "Unknown")
+
+(defun vc-dav-register (url &optional rev comment)
+ "Register URL in the DAV backend."
+ ;; Do we need to do anything here? FIXME?
+ )
+
+(defun vc-dav-checkin (url rev comment)
+ "Commit changes in URL to WebDAV.
+If REV is non-nil, that should become the new revision number.
+COMMENT is used as a check-in comment."
+ ;; This should PUT the resource and release any locks that we hold.
+ )
+
+(defun vc-dav-checkout (url &optional editable rev destfile)
+ "Check out revision REV of URL into the working area.
+
+If EDITABLE is non-nil URL should be writable by the user and if
+locking is used for URL, a lock should also be set.
+
+If REV is non-nil, that is the revision to check out. If REV is the
+empty string, that means to check ou tht ehead of the trunk.
+
+If optional arg DESTFILE is given, it is an alternate filename to
+write the contents to.
+"
+ ;; This should LOCK the resource.
+ )
+
+(defun vc-dav-revert (url &optional contents-done)
+ "Revert URL back to the current workfile version.
+
+If optional arg CONTENTS-DONE is non-nil, then the contents of FILE
+have already been reverted from a version backup, and this function
+only needs to update the status of URL within the backend.
+"
+ ;; Should do a GET if !contents_done
+ ;; Should UNLOCK the file.
+ )
+
+(defun vc-dav-print-log (url)
+ "Insert the revision log of URL into the *vc* buffer."
+ )
+
+(defun vc-dav-diff (url &optional rev1 rev2)
+ "Insert the diff for URL into the *vc-diff* buffer.
+If REV1 and REV2 are non-nil report differences from REV1 to REV2.
+If REV1 is nil, use the current workfile version as the older version.
+If REV2 is nil, use the current workfile contents as the nwer version.
+
+It should return a status of either 0 (no differences found), or
+1 (either non-empty diff or the diff is run asynchronously).
+"
+ ;; We should do this asynchronously...
+ ;; How would we do it at all, that is the question!
+ )
+
+
+
+;;; Optional functions
+;; Should be faster than vc-dav-state - but how?
+(defun vc-dav-state-heuristic (url)
+ "Estimate the version control state of URL at visiting time."
+ (vc-dav-state url))
+
+;; This should use url-dav-get-properties with a depth of `1' to get
+;; all the properties.
+(defun vc-dav-dir-state (url)
+ "find the version control state of all files in DIR in a fast way."
+ )
+
+(defun vc-dav-workfile-unchanged-p (url)
+ "Return non-nil if URL is unchanged from its current workfile version."
+ ;; Probably impossible with webdav
+ )
+
+(defun vc-dav-responsible-p (url)
+ "Return non-nil if DAV considers itself `responsible' for URL."
+ ;; Check for DAV support on the web server.
+ t)
+
+(defun vc-dav-could-register (url)
+ "Return non-nil if URL could be registered under this backend."
+ ;; Check for DAV support on the web server.
+ t)
+
+;;; Unimplemented functions
+;;
+;; vc-dav-latest-on-branch-p(URL)
+;; Return non-nil if the current workfile version of FILE is the
+;; latest on its branch. There are no branches in webdav yet.
+;;
+;; vc-dav-mode-line-string(url)
+;; Return a dav-specific mode line string for URL. Are there any
+;; specific states that we want exposed?
+;;
+;; vc-dav-dired-state-info(url)
+;; Translate the `vc-state' property of URL into a string that can
+;; be used in a vc-dired buffer. Are there any extra states that
+;; we want exposed?
+;;
+;; vc-dav-receive-file(url rev)
+;; Let this backend `receive' a file that is already registered
+;; under another backend. The default just calls `register', which
+;; should be sufficient for WebDAV.
+;;
+;; vc-dav-unregister(url)
+;; Unregister URL. Not possible with WebDAV, other than by
+;; deleting the resource.
+
+(provide 'vc-dav)
+
+;; arch-tag: 0a0fb9fe-8190-4c0a-a179-5c291d3a467e
+;;; vc-dav.el ends here
--- /dev/null
+;;; vc-dir.el --- Directory status display under VC
+
+;; Copyright (C) 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: Dan Nicolaescu <dann@ics.uci.edu>
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Credits:
+
+;; The original VC directory status implementation was based on dired.
+;; This implementation was inspired by PCL-CVS.
+;; Many people contributed comments, ideas and code to this
+;; implementation. These include:
+;;
+;; Alexandre Julliard <julliard@winehq.org>
+;; Stefan Monnier <monnier@iro.umontreal.ca>
+;; Tom Tromey <tromey@redhat.com>
+
+;;; Commentary:
+;;
+
+;;; Todo: see vc.el.
+
+(require 'vc-hooks)
+(require 'vc)
+(require 'tool-bar)
+(require 'ewoc)
+
+;;; Code:
+(eval-when-compile
+ (require 'cl))
+
+(defcustom vc-dir-mode-hook nil
+ "Normal hook run by `vc-dir-mode'.
+See `run-hooks'."
+ :type 'hook
+ :group 'vc)
+
+;; Used to store information for the files displayed in the directory buffer.
+;; Each item displayed corresponds to one of these defstructs.
+(defstruct (vc-dir-fileinfo
+ (:copier nil)
+ (:type list) ;So we can use `member' on lists of FIs.
+ (:constructor
+ ;; We could define it as an alias for `list'.
+ vc-dir-create-fileinfo (name state &optional extra marked directory))
+ (:conc-name vc-dir-fileinfo->))
+ name ;Keep it as first, for `member'.
+ state
+ ;; For storing backend specific information.
+ extra
+ marked
+ ;; To keep track of not updated files during a global refresh
+ needs-update
+ ;; To distinguish files and directories.
+ directory)
+
+(defvar vc-ewoc nil)
+
+(defvar vc-dir-process-buffer nil
+ "The buffer used for the asynchronous call that computes status.")
+
+(defvar vc-dir-backend nil
+ "The backend used by the current *vc-dir* buffer.")
+
+(defun vc-dir-move-to-goal-column ()
+ ;; Used to keep the cursor on the file name column.
+ (beginning-of-line)
+ (unless (eolp)
+ ;; Must be in sync with vc-default-dir-printer.
+ (forward-char 25)))
+
+(defun vc-dir-prepare-status-buffer (bname dir backend &optional create-new)
+ "Find a buffer named BNAME showing DIR, or create a new one."
+ (setq dir (file-name-as-directory (expand-file-name dir)))
+ (let* ;; Look for another buffer name BNAME visiting the same directory.
+ ((buf (save-excursion
+ (unless create-new
+ (dolist (buffer vc-dir-buffers)
+ (when (buffer-live-p buffer)
+ (set-buffer buffer)
+ (when (and (derived-mode-p 'vc-dir-mode)
+ (eq vc-dir-backend backend)
+ (string= default-directory dir))
+ (return buffer))))))))
+ (or buf
+ ;; Create a new buffer named BNAME.
+ ;; We pass a filename to create-file-buffer because it is what
+ ;; the function expects, and also what uniquify needs (if active)
+ (with-current-buffer (create-file-buffer (expand-file-name bname dir))
+ (cd dir)
+ (vc-setup-buffer (current-buffer))
+ ;; Reset the vc-parent-buffer-name so that it does not appear
+ ;; in the mode-line.
+ (setq vc-parent-buffer-name nil)
+ (current-buffer)))))
+
+(defvar vc-dir-menu-map
+ (let ((map (make-sparse-keymap "VC-dir")))
+ (define-key map [quit]
+ '(menu-item "Quit" quit-window
+ :help "Quit"))
+ (define-key map [kill]
+ '(menu-item "Kill Update Command" vc-dir-kill-dir-status-process
+ :enable (vc-dir-busy)
+ :help "Kill the command that updates the directory buffer"))
+ (define-key map [refresh]
+ '(menu-item "Refresh" revert-buffer
+ :enable (not (vc-dir-busy))
+ :help "Refresh the contents of the directory buffer"))
+ (define-key map [remup]
+ '(menu-item "Hide up-to-date" vc-dir-hide-up-to-date
+ :help "Hide up-to-date items from display"))
+ ;; Movement.
+ (define-key map [sepmv] '("--"))
+ (define-key map [next-line]
+ '(menu-item "Next line" vc-dir-next-line
+ :help "Go to the next line" :keys "n"))
+ (define-key map [previous-line]
+ '(menu-item "Previous line" vc-dir-previous-line
+ :help "Go to the previous line"))
+ ;; Marking.
+ (define-key map [sepmrk] '("--"))
+ (define-key map [unmark-all]
+ '(menu-item "Unmark All" vc-dir-unmark-all-files
+ :help "Unmark all files that are in the same state as the current file\
+\nWith prefix argument unmark all files"))
+ (define-key map [unmark-previous]
+ '(menu-item "Unmark previous " vc-dir-unmark-file-up
+ :help "Move to the previous line and unmark the file"))
+
+ (define-key map [mark-all]
+ '(menu-item "Mark All" vc-dir-mark-all-files
+ :help "Mark all files that are in the same state as the current file\
+\nWith prefix argument mark all files"))
+ (define-key map [unmark]
+ '(menu-item "Unmark" vc-dir-unmark
+ :help "Unmark the current file or all files in the region"))
+
+ (define-key map [mark]
+ '(menu-item "Mark" vc-dir-mark
+ :help "Mark the current file or all files in the region"))
+
+ (define-key map [sepopn] '("--"))
+ (define-key map [qr]
+ '(menu-item "Query Replace in Files..." vc-dir-query-replace-regexp
+ :help "Replace a string in the marked files"))
+ (define-key map [se]
+ '(menu-item "Search Files..." vc-dir-search
+ :help "Search a regexp in the marked files"))
+ (define-key map [ires]
+ '(menu-item "Isearch Regexp Files..." vc-dir-isearch-regexp
+ :help "Incremental search a regexp in the marked files"))
+ (define-key map [ise]
+ '(menu-item "Isearch Files..." vc-dir-isearch
+ :help "Incremental search a string in the marked files"))
+ (define-key map [open-other]
+ '(menu-item "Open in other window" vc-dir-find-file-other-window
+ :help "Find the file on the current line, in another window"))
+ (define-key map [open]
+ '(menu-item "Open file" vc-dir-find-file
+ :help "Find the file on the current line"))
+ (define-key map [sepvcdet] '("--"))
+ ;; FIXME: This needs a key binding. And maybe a better name
+ ;; ("Insert" like PCL-CVS uses does not sound that great either)...
+ (define-key map [ins]
+ '(menu-item "Show File" vc-dir-show-fileentry
+ :help "Show a file in the VC status listing even though it might be up to date"))
+ (define-key map [annotate]
+ '(menu-item "Annotate" vc-annotate
+ :help "Display the edit history of the current file using colors"))
+ (define-key map [diff]
+ '(menu-item "Compare with Base Version" vc-diff
+ :help "Compare file set with the base version"))
+ (define-key map [logo]
+ '(menu-item "Show Outgoing Log" vc-log-outgoing
+ :help "Show a log of changes that will be sent with a push operation"))
+ (define-key map [logi]
+ '(menu-item "Show Incoming Log" vc-log-incoming
+ :help "Show a log of changes that will be received with a pull operation"))
+ (define-key map [log]
+ '(menu-item "Show history" vc-print-log
+ :help "List the change log of the current file set in a window"))
+ (define-key map [rlog]
+ '(menu-item "Show Top of the Tree History " vc-print-root-log
+ :help "List the change log for the current tree in a window"))
+ ;; VC commands.
+ (define-key map [sepvccmd] '("--"))
+ (define-key map [update]
+ '(menu-item "Update to latest version" vc-update
+ :help "Update the current fileset's files to their tip revisions"))
+ (define-key map [revert]
+ '(menu-item "Revert to base version" vc-revert
+ :help "Revert working copies of the selected fileset to their repository contents."))
+ (define-key map [next-action]
+ ;; FIXME: This really really really needs a better name!
+ ;; And a key binding too.
+ '(menu-item "Check In/Out" vc-next-action
+ :help "Do the next logical version control operation on the current fileset"))
+ (define-key map [register]
+ '(menu-item "Register" vc-register
+ :help "Register file set into the version control system"))
+ map)
+ "Menu for VC dir.")
+
+;; VC backends can use this to add mode-specific menu items to
+;; vc-dir-menu-map.
+(defun vc-dir-menu-map-filter (orig-binding)
+ (when (and (symbolp orig-binding) (fboundp orig-binding))
+ (setq orig-binding (indirect-function orig-binding)))
+ (let ((ext-binding
+ (when (derived-mode-p 'vc-dir-mode)
+ (vc-call-backend vc-dir-backend 'extra-status-menu))))
+ (if (null ext-binding)
+ orig-binding
+ (append orig-binding
+ '("----")
+ ext-binding))))
+
+(defvar vc-dir-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; VC commands
+ (define-key map "v" 'vc-next-action) ;; C-x v v
+ (define-key map "=" 'vc-diff) ;; C-x v =
+ (define-key map "i" 'vc-register) ;; C-x v i
+ (define-key map "+" 'vc-update) ;; C-x v +
+ (define-key map "l" 'vc-print-log) ;; C-x v l
+ ;; More confusing than helpful, probably
+ ;;(define-key map "R" 'vc-revert) ;; u is taken by vc-dir-unmark.
+ ;;(define-key map "A" 'vc-annotate) ;; g is taken by revert-buffer
+ ;; bound by `special-mode'.
+ ;; Marking.
+ (define-key map "m" 'vc-dir-mark)
+ (define-key map "M" 'vc-dir-mark-all-files)
+ (define-key map "u" 'vc-dir-unmark)
+ (define-key map "U" 'vc-dir-unmark-all-files)
+ (define-key map "\C-?" 'vc-dir-unmark-file-up)
+ (define-key map "\M-\C-?" 'vc-dir-unmark-all-files)
+ ;; Movement.
+ (define-key map "n" 'vc-dir-next-line)
+ (define-key map " " 'vc-dir-next-line)
+ (define-key map "\t" 'vc-dir-next-directory)
+ (define-key map "p" 'vc-dir-previous-line)
+ (define-key map [backtab] 'vc-dir-previous-directory)
+ ;;; Rebind paragraph-movement commands.
+ (define-key map "\M-}" 'vc-dir-next-directory)
+ (define-key map "\M-{" 'vc-dir-previous-directory)
+ (define-key map [C-down] 'vc-dir-next-directory)
+ (define-key map [C-up] 'vc-dir-previous-directory)
+ ;; The remainder.
+ (define-key map "f" 'vc-dir-find-file)
+ (define-key map "\C-m" 'vc-dir-find-file)
+ (define-key map "o" 'vc-dir-find-file-other-window)
+ (define-key map "\C-c\C-c" 'vc-dir-kill-dir-status-process)
+ (define-key map [down-mouse-3] 'vc-dir-menu)
+ (define-key map [mouse-2] 'vc-dir-toggle-mark)
+ (define-key map [follow-link] 'mouse-face)
+ (define-key map "x" 'vc-dir-hide-up-to-date)
+ (define-key map [?\C-k] 'vc-dir-kill-line)
+ (define-key map "S" 'vc-dir-search) ;; FIXME: Maybe use A like dired?
+ (define-key map "Q" 'vc-dir-query-replace-regexp)
+ (define-key map (kbd "M-s a C-s") 'vc-dir-isearch)
+ (define-key map (kbd "M-s a M-C-s") 'vc-dir-isearch-regexp)
+
+ ;; Hook up the menu.
+ (define-key map [menu-bar vc-dir-mode]
+ `(menu-item
+ ;; VC backends can use this to add mode-specific menu items to
+ ;; vc-dir-menu-map.
+ "VC-dir" ,vc-dir-menu-map :filter vc-dir-menu-map-filter))
+ map)
+ "Keymap for directory buffer.")
+
+(defmacro vc-dir-at-event (event &rest body)
+ "Evaluate BODY with point located at event-start of EVENT.
+If BODY uses EVENT, it should be a variable,
+ otherwise it will be evaluated twice."
+ (let ((posn (make-symbol "vc-dir-at-event-posn")))
+ `(save-excursion
+ (unless (equal ,event '(tool-bar))
+ (let ((,posn (event-start ,event)))
+ (set-buffer (window-buffer (posn-window ,posn)))
+ (goto-char (posn-point ,posn))))
+ ,@body)))
+
+(defun vc-dir-menu (e)
+ "Popup the VC dir menu."
+ (interactive "e")
+ (vc-dir-at-event e (popup-menu vc-dir-menu-map e)))
+
+(defvar vc-dir-tool-bar-map
+ (let ((map (make-sparse-keymap)))
+ (tool-bar-local-item-from-menu 'vc-dir-find-file "open"
+ map vc-dir-mode-map)
+ (tool-bar-local-item "bookmark_add"
+ 'vc-dir-toggle-mark 'vc-dir-toggle-mark map
+ :help "Toggle mark on current item"
+ :label "Toggle Mark")
+ (tool-bar-local-item-from-menu 'vc-dir-previous-line "left-arrow"
+ map vc-dir-mode-map
+ :rtl "right-arrow")
+ (tool-bar-local-item-from-menu 'vc-dir-next-line "right-arrow"
+ map vc-dir-mode-map
+ :rtl "left-arrow")
+ (tool-bar-local-item-from-menu 'vc-print-log "info"
+ map vc-dir-mode-map)
+ (tool-bar-local-item-from-menu 'revert-buffer "refresh"
+ map vc-dir-mode-map)
+ (tool-bar-local-item-from-menu 'nonincremental-search-forward
+ "search" map nil
+ :label "Search")
+ (tool-bar-local-item-from-menu 'vc-dir-query-replace-regexp
+ "search-replace" map vc-dir-mode-map
+ :label "Replace")
+ (tool-bar-local-item-from-menu 'vc-dir-kill-dir-status-process "cancel"
+ map vc-dir-mode-map
+ :label "Cancel")
+ (tool-bar-local-item-from-menu 'quit-window "exit"
+ map vc-dir-mode-map)
+ map))
+
+(defun vc-dir-node-directory (node)
+ ;; Compute the directory for NODE.
+ ;; If it's a directory node, get it from the node.
+ (let ((data (ewoc-data node)))
+ (or (vc-dir-fileinfo->directory data)
+ ;; Otherwise compute it from the file name.
+ (file-name-directory
+ (directory-file-name
+ (expand-file-name
+ (vc-dir-fileinfo->name data)))))))
+
+(defun vc-dir-update (entries buffer &optional noinsert)
+ "Update BUFFER's ewoc from the list of ENTRIES.
+If NOINSERT, ignore elements on ENTRIES which are not in the ewoc."
+ ;; Add ENTRIES to the vc-dir buffer BUFFER.
+ (with-current-buffer buffer
+ ;; Insert the entries sorted by name into the ewoc.
+ ;; We assume the ewoc is sorted too, which should be the
+ ;; case if we always add entries with vc-dir-update.
+ (setq entries
+ ;; Sort: first files and then subdirectories.
+ ;; XXX: this is VERY inefficient, it computes the directory
+ ;; names too many times
+ (sort entries
+ (lambda (entry1 entry2)
+ (let ((dir1 (file-name-directory
+ (directory-file-name (expand-file-name (car entry1)))))
+ (dir2 (file-name-directory
+ (directory-file-name (expand-file-name (car entry2))))))
+ (cond
+ ((string< dir1 dir2) t)
+ ((not (string= dir1 dir2)) nil)
+ ((string< (car entry1) (car entry2))))))))
+ ;; Insert directory entries in the right places.
+ (let ((entry (car entries))
+ (node (ewoc-nth vc-ewoc 0))
+ (to-remove nil)
+ (dotname (file-relative-name default-directory)))
+ ;; Insert . if it is not present.
+ (unless node
+ (ewoc-enter-last
+ vc-ewoc (vc-dir-create-fileinfo
+ dotname nil nil nil default-directory))
+ (setq node (ewoc-nth vc-ewoc 0)))
+
+ (while (and entry node)
+ (let* ((entryfile (car entry))
+ (entrydir (file-name-directory (directory-file-name
+ (expand-file-name entryfile))))
+ (nodedir (vc-dir-node-directory node)))
+ (cond
+ ;; First try to find the directory.
+ ((string-lessp nodedir entrydir)
+ (setq node (ewoc-next vc-ewoc node)))
+ ((string-equal nodedir entrydir)
+ ;; Found the directory, find the place for the file name.
+ (let ((nodefile (vc-dir-fileinfo->name (ewoc-data node))))
+ (cond
+ ((string= nodefile dotname)
+ (setq node (ewoc-next vc-ewoc node)))
+ ((string-lessp nodefile entryfile)
+ (setq node (ewoc-next vc-ewoc node)))
+ ((string-equal nodefile entryfile)
+ (if (nth 1 entry)
+ (progn
+ (setf (vc-dir-fileinfo->state (ewoc-data node)) (nth 1 entry))
+ (setf (vc-dir-fileinfo->extra (ewoc-data node)) (nth 2 entry))
+ (setf (vc-dir-fileinfo->needs-update (ewoc-data node)) nil)
+ (ewoc-invalidate vc-ewoc node))
+ ;; If the state is nil, the file does not exist
+ ;; anymore, so remember the entry so we can remove
+ ;; it after we are done inserting all ENTRIES.
+ (push node to-remove))
+ (setq entries (cdr entries))
+ (setq entry (car entries))
+ (setq node (ewoc-next vc-ewoc node)))
+ (t
+ (ewoc-enter-before vc-ewoc node
+ (apply 'vc-dir-create-fileinfo entry))
+ (setq entries (cdr entries))
+ (setq entry (car entries))))))
+ (t
+ ;; We might need to insert a directory node if the
+ ;; previous node was in a different directory.
+ (let* ((rd (file-relative-name entrydir))
+ (prev-node (ewoc-prev vc-ewoc node))
+ (prev-dir (vc-dir-node-directory prev-node)))
+ (unless (string-equal entrydir prev-dir)
+ (ewoc-enter-before
+ vc-ewoc node (vc-dir-create-fileinfo rd nil nil nil entrydir))))
+ ;; Now insert the node itself.
+ (ewoc-enter-before vc-ewoc node
+ (apply 'vc-dir-create-fileinfo entry))
+ (setq entries (cdr entries) entry (car entries))))))
+ ;; We're past the last node, all remaining entries go to the end.
+ (unless (or node noinsert)
+ (let ((lastdir (vc-dir-node-directory (ewoc-nth vc-ewoc -1))))
+ (dolist (entry entries)
+ (let ((entrydir (file-name-directory
+ (directory-file-name (expand-file-name (car entry))))))
+ ;; Insert a directory node if needed.
+ (unless (string-equal lastdir entrydir)
+ (setq lastdir entrydir)
+ (let ((rd (file-relative-name entrydir)))
+ (ewoc-enter-last
+ vc-ewoc (vc-dir-create-fileinfo rd nil nil nil entrydir))))
+ ;; Now insert the node itself.
+ (ewoc-enter-last vc-ewoc
+ (apply 'vc-dir-create-fileinfo entry))))))
+ (when to-remove
+ (let ((inhibit-read-only t))
+ (apply 'ewoc-delete vc-ewoc (nreverse to-remove)))))))
+
+(defun vc-dir-busy ()
+ (and (buffer-live-p vc-dir-process-buffer)
+ (get-buffer-process vc-dir-process-buffer)))
+
+(defun vc-dir-kill-dir-status-process ()
+ "Kill the temporary buffer and associated process."
+ (interactive)
+ (when (buffer-live-p vc-dir-process-buffer)
+ (let ((proc (get-buffer-process vc-dir-process-buffer)))
+ (when proc (delete-process proc))
+ (setq vc-dir-process-buffer nil)
+ (setq mode-line-process nil))))
+
+(defun vc-dir-kill-query ()
+ ;; Make sure that when the status buffer is killed the update
+ ;; process running in background is also killed.
+ (if (vc-dir-busy)
+ (when (y-or-n-p "Status update process running, really kill status buffer? ")
+ (vc-dir-kill-dir-status-process)
+ t)
+ t))
+
+(defun vc-dir-next-line (arg)
+ "Go to the next line.
+If a prefix argument is given, move by that many lines."
+ (interactive "p")
+ (with-no-warnings
+ (ewoc-goto-next vc-ewoc arg)
+ (vc-dir-move-to-goal-column)))
+
+(defun vc-dir-previous-line (arg)
+ "Go to the previous line.
+If a prefix argument is given, move by that many lines."
+ (interactive "p")
+ (ewoc-goto-prev vc-ewoc arg)
+ (vc-dir-move-to-goal-column))
+
+(defun vc-dir-next-directory ()
+ "Go to the next directory."
+ (interactive)
+ (let ((orig (point)))
+ (if
+ (catch 'foundit
+ (while t
+ (let* ((next (ewoc-next vc-ewoc (ewoc-locate vc-ewoc))))
+ (cond ((not next)
+ (throw 'foundit t))
+ (t
+ (progn
+ (ewoc-goto-node vc-ewoc next)
+ (vc-dir-move-to-goal-column)
+ (if (vc-dir-fileinfo->directory (ewoc-data next))
+ (throw 'foundit nil))))))))
+ (goto-char orig))))
+
+(defun vc-dir-previous-directory ()
+ "Go to the previous directory."
+ (interactive)
+ (let ((orig (point)))
+ (if
+ (catch 'foundit
+ (while t
+ (let* ((prev (ewoc-prev vc-ewoc (ewoc-locate vc-ewoc))))
+ (cond ((not prev)
+ (throw 'foundit t))
+ (t
+ (progn
+ (ewoc-goto-node vc-ewoc prev)
+ (vc-dir-move-to-goal-column)
+ (if (vc-dir-fileinfo->directory (ewoc-data prev))
+ (throw 'foundit nil))))))))
+ (goto-char orig))))
+
+(defun vc-dir-mark-unmark (mark-unmark-function)
+ (if (use-region-p)
+ (let ((firstl (line-number-at-pos (region-beginning)))
+ (lastl (line-number-at-pos (region-end))))
+ (save-excursion
+ (goto-char (region-beginning))
+ (while (<= (line-number-at-pos) lastl)
+ (funcall mark-unmark-function))))
+ (funcall mark-unmark-function)))
+
+(defun vc-dir-parent-marked-p (arg)
+ ;; Return nil if none of the parent directories of arg is marked.
+ (let* ((argdir (vc-dir-node-directory arg))
+ (arglen (length argdir))
+ (crt arg)
+ data dir)
+ ;; Go through the predecessors, checking if any directory that is
+ ;; a parent is marked.
+ (while (setq crt (ewoc-prev vc-ewoc crt))
+ (setq data (ewoc-data crt))
+ (setq dir (vc-dir-node-directory crt))
+ (when (and (vc-dir-fileinfo->directory data)
+ (vc-string-prefix-p dir argdir))
+ (when (vc-dir-fileinfo->marked data)
+ (error "Cannot mark `%s', parent directory `%s' marked"
+ (vc-dir-fileinfo->name (ewoc-data arg))
+ (vc-dir-fileinfo->name data)))))
+ nil))
+
+(defun vc-dir-children-marked-p (arg)
+ ;; Return nil if none of the children of arg is marked.
+ (let* ((argdir-re (concat "\\`" (regexp-quote (vc-dir-node-directory arg))))
+ (is-child t)
+ (crt arg)
+ data dir)
+ (while (and is-child (setq crt (ewoc-next vc-ewoc crt)))
+ (setq data (ewoc-data crt))
+ (setq dir (vc-dir-node-directory crt))
+ (if (string-match argdir-re dir)
+ (when (vc-dir-fileinfo->marked data)
+ (error "Cannot mark `%s', child `%s' marked"
+ (vc-dir-fileinfo->name (ewoc-data arg))
+ (vc-dir-fileinfo->name data)))
+ ;; We are done, we got to an entry that is not a child of `arg'.
+ (setq is-child nil)))
+ nil))
+
+(defun vc-dir-mark-file (&optional arg)
+ ;; Mark ARG or the current file and move to the next line.
+ (let* ((crt (or arg (ewoc-locate vc-ewoc)))
+ (file (ewoc-data crt))
+ (isdir (vc-dir-fileinfo->directory file)))
+ (when (or (and isdir (not (vc-dir-children-marked-p crt)))
+ (and (not isdir) (not (vc-dir-parent-marked-p crt))))
+ (setf (vc-dir-fileinfo->marked file) t)
+ (ewoc-invalidate vc-ewoc crt)
+ (unless (or arg (mouse-event-p last-command-event))
+ (vc-dir-next-line 1)))))
+
+(defun vc-dir-mark ()
+ "Mark the current file or all files in the region.
+If the region is active, mark all the files in the region.
+Otherwise mark the file on the current line and move to the next
+line."
+ (interactive)
+ (vc-dir-mark-unmark 'vc-dir-mark-file))
+
+(defun vc-dir-mark-all-files (arg)
+ "Mark all files with the same state as the current one.
+With a prefix argument mark all files.
+If the current entry is a directory, mark all child files.
+
+The commands operate on files that are on the same state.
+This command is intended to make it easy to select all files that
+share the same state."
+ (interactive "P")
+ (if arg
+ ;; Mark all files.
+ (progn
+ ;; First check that no directory is marked, we can't mark
+ ;; files in that case.
+ (ewoc-map
+ (lambda (filearg)
+ (when (and (vc-dir-fileinfo->directory filearg)
+ (vc-dir-fileinfo->marked filearg))
+ (error "Cannot mark all files, directory `%s' marked"
+ (vc-dir-fileinfo->name filearg))))
+ vc-ewoc)
+ (ewoc-map
+ (lambda (filearg)
+ (unless (vc-dir-fileinfo->marked filearg)
+ (setf (vc-dir-fileinfo->marked filearg) t)
+ t))
+ vc-ewoc))
+ (let ((data (ewoc-data (ewoc-locate vc-ewoc))))
+ (if (vc-dir-fileinfo->directory data)
+ ;; It's a directory, mark child files.
+ (let ((crt (ewoc-locate vc-ewoc)))
+ (unless (vc-dir-children-marked-p crt)
+ (while (setq crt (ewoc-next vc-ewoc crt))
+ (let ((crt-data (ewoc-data crt)))
+ (unless (vc-dir-fileinfo->directory crt-data)
+ (setf (vc-dir-fileinfo->marked crt-data) t)
+ (ewoc-invalidate vc-ewoc crt))))))
+ ;; It's a file
+ (let ((state (vc-dir-fileinfo->state data))
+ (crt (ewoc-nth vc-ewoc 0)))
+ (while crt
+ (let ((crt-data (ewoc-data crt)))
+ (when (and (not (vc-dir-fileinfo->marked crt-data))
+ (eq (vc-dir-fileinfo->state crt-data) state)
+ (not (vc-dir-fileinfo->directory crt-data)))
+ (vc-dir-mark-file crt)))
+ (setq crt (ewoc-next vc-ewoc crt))))))))
+
+(defun vc-dir-unmark-file ()
+ ;; Unmark the current file and move to the next line.
+ (let* ((crt (ewoc-locate vc-ewoc))
+ (file (ewoc-data crt)))
+ (setf (vc-dir-fileinfo->marked file) nil)
+ (ewoc-invalidate vc-ewoc crt)
+ (unless (mouse-event-p last-command-event)
+ (vc-dir-next-line 1))))
+
+(defun vc-dir-unmark ()
+ "Unmark the current file or all files in the region.
+If the region is active, unmark all the files in the region.
+Otherwise mark the file on the current line and move to the next
+line."
+ (interactive)
+ (vc-dir-mark-unmark 'vc-dir-unmark-file))
+
+(defun vc-dir-unmark-file-up ()
+ "Move to the previous line and unmark the file."
+ (interactive)
+ ;; If we're on the first line, we won't move up, but we will still
+ ;; remove the mark. This seems a bit odd but it is what buffer-menu
+ ;; does.
+ (let* ((prev (ewoc-goto-prev vc-ewoc 1))
+ (file (ewoc-data prev)))
+ (setf (vc-dir-fileinfo->marked file) nil)
+ (ewoc-invalidate vc-ewoc prev)
+ (vc-dir-move-to-goal-column)))
+
+(defun vc-dir-unmark-all-files (arg)
+ "Unmark all files with the same state as the current one.
+With a prefix argument unmark all files.
+If the current entry is a directory, unmark all the child files.
+
+The commands operate on files that are on the same state.
+This command is intended to make it easy to deselect all files
+that share the same state."
+ (interactive "P")
+ (if arg
+ (ewoc-map
+ (lambda (filearg)
+ (when (vc-dir-fileinfo->marked filearg)
+ (setf (vc-dir-fileinfo->marked filearg) nil)
+ t))
+ vc-ewoc)
+ (let* ((crt (ewoc-locate vc-ewoc))
+ (data (ewoc-data crt)))
+ (if (vc-dir-fileinfo->directory data)
+ ;; It's a directory, unmark child files.
+ (while (setq crt (ewoc-next vc-ewoc crt))
+ (let ((crt-data (ewoc-data crt)))
+ (unless (vc-dir-fileinfo->directory crt-data)
+ (setf (vc-dir-fileinfo->marked crt-data) nil)
+ (ewoc-invalidate vc-ewoc crt))))
+ ;; It's a file
+ (let ((crt-state (vc-dir-fileinfo->state (ewoc-data crt))))
+ (ewoc-map
+ (lambda (filearg)
+ (when (and (vc-dir-fileinfo->marked filearg)
+ (eq (vc-dir-fileinfo->state filearg) crt-state))
+ (setf (vc-dir-fileinfo->marked filearg) nil)
+ t))
+ vc-ewoc))))))
+
+(defun vc-dir-toggle-mark-file ()
+ (let* ((crt (ewoc-locate vc-ewoc))
+ (file (ewoc-data crt)))
+ (if (vc-dir-fileinfo->marked file)
+ (vc-dir-unmark-file)
+ (vc-dir-mark-file))))
+
+(defun vc-dir-toggle-mark (e)
+ (interactive "e")
+ (vc-dir-at-event e (vc-dir-mark-unmark 'vc-dir-toggle-mark-file)))
+
+(defun vc-dir-delete-file ()
+ "Delete the marked files, or the current file if no marks."
+ (interactive)
+ (mapc 'vc-delete-file (or (vc-dir-marked-files)
+ (list (vc-dir-current-file)))))
+
+(defun vc-dir-find-file ()
+ "Find the file on the current line."
+ (interactive)
+ (find-file (vc-dir-current-file)))
+
+(defun vc-dir-find-file-other-window (&optional event)
+ "Find the file on the current line, in another window."
+ (interactive (list last-nonmenu-event))
+ (if event (posn-set-point (event-end event)))
+ (find-file-other-window (vc-dir-current-file)))
+
+(defun vc-dir-isearch ()
+ "Search for a string through all marked buffers using Isearch."
+ (interactive)
+ (multi-isearch-files
+ (mapcar 'car (vc-dir-marked-only-files-and-states))))
+
+(defun vc-dir-isearch-regexp ()
+ "Search for a regexp through all marked buffers using Isearch."
+ (interactive)
+ (multi-isearch-files-regexp
+ (mapcar 'car (vc-dir-marked-only-files-and-states))))
+
+(defun vc-dir-search (regexp)
+ "Search through all marked files for a match for REGEXP.
+For marked directories, use the files displayed from those directories.
+Stops when a match is found.
+To continue searching for next match, use command \\[tags-loop-continue]."
+ (interactive "sSearch marked files (regexp): ")
+ (tags-search regexp '(mapcar 'car (vc-dir-marked-only-files-and-states))))
+
+(defun vc-dir-query-replace-regexp (from to &optional delimited)
+ "Do `query-replace-regexp' of FROM with TO, on all marked files.
+For marked directories, use the files displayed from those directories.
+If a directory is marked, then use the files displayed for that directory.
+Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
+If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
+with the command \\[tags-loop-continue]."
+ ;; FIXME: this is almost a copy of `dired-do-replace-regexp'. This
+ ;; should probably be made generic and used in both places instead of
+ ;; duplicating it here.
+ (interactive
+ (let ((common
+ (query-replace-read-args
+ "Query replace regexp in marked files" t t)))
+ (list (nth 0 common) (nth 1 common) (nth 2 common))))
+ (dolist (file (mapcar 'car (vc-dir-marked-only-files-and-states)))
+ (let ((buffer (get-file-buffer file)))
+ (if (and buffer (with-current-buffer buffer
+ buffer-read-only))
+ (error "File `%s' is visited read-only" file))))
+ (tags-query-replace from to delimited
+ '(mapcar 'car (vc-dir-marked-only-files-and-states))))
+
+(defun vc-dir-current-file ()
+ (let ((node (ewoc-locate vc-ewoc)))
+ (unless node
+ (error "No file available"))
+ (expand-file-name (vc-dir-fileinfo->name (ewoc-data node)))))
+
+(defun vc-dir-marked-files ()
+ "Return the list of marked files."
+ (mapcar
+ (lambda (elem) (expand-file-name (vc-dir-fileinfo->name elem)))
+ (ewoc-collect vc-ewoc 'vc-dir-fileinfo->marked)))
+
+(defun vc-dir-marked-only-files-and-states ()
+ "Return the list of conses (FILE . STATE) for the marked files.
+For marked directories return the corresponding conses for the
+child files."
+ (let ((crt (ewoc-nth vc-ewoc 0))
+ result)
+ (while crt
+ (let ((crt-data (ewoc-data crt)))
+ (if (vc-dir-fileinfo->marked crt-data)
+ ;; FIXME: use vc-dir-child-files-and-states here instead of duplicating it.
+ (if (vc-dir-fileinfo->directory crt-data)
+ (let* ((dir (vc-dir-fileinfo->directory crt-data))
+ (dirlen (length dir))
+ data)
+ (while
+ (and (setq crt (ewoc-next vc-ewoc crt))
+ (vc-string-prefix-p dir
+ (progn
+ (setq data (ewoc-data crt))
+ (vc-dir-node-directory crt))))
+ (unless (vc-dir-fileinfo->directory data)
+ (push
+ (cons (expand-file-name (vc-dir-fileinfo->name data))
+ (vc-dir-fileinfo->state data))
+ result))))
+ (push (cons (expand-file-name (vc-dir-fileinfo->name crt-data))
+ (vc-dir-fileinfo->state crt-data))
+ result)
+ (setq crt (ewoc-next vc-ewoc crt)))
+ (setq crt (ewoc-next vc-ewoc crt)))))
+ (nreverse result)))
+
+(defun vc-dir-child-files-and-states ()
+ "Return the list of conses (FILE . STATE) for child files of the current entry if it's a directory.
+If it is a file, return the corresponding cons for the file itself."
+ (let* ((crt (ewoc-locate vc-ewoc))
+ (crt-data (ewoc-data crt))
+ result)
+ (if (vc-dir-fileinfo->directory crt-data)
+ (let* ((dir (vc-dir-fileinfo->directory crt-data))
+ (dirlen (length dir))
+ data)
+ (while
+ (and (setq crt (ewoc-next vc-ewoc crt))
+ (vc-string-prefix-p dir (progn
+ (setq data (ewoc-data crt))
+ (vc-dir-node-directory crt))))
+ (unless (vc-dir-fileinfo->directory data)
+ (push
+ (cons (expand-file-name (vc-dir-fileinfo->name data))
+ (vc-dir-fileinfo->state data))
+ result))))
+ (push
+ (cons (expand-file-name (vc-dir-fileinfo->name crt-data))
+ (vc-dir-fileinfo->state crt-data)) result))
+ (nreverse result)))
+
+(defun vc-dir-recompute-file-state (fname def-dir)
+ (let* ((file-short (file-relative-name fname def-dir))
+ (remove-me-when-CVS-works
+ (when (eq vc-dir-backend 'CVS)
+ ;; FIXME: Warning: UGLY HACK. The CVS backend caches the state
+ ;; info, this forces the backend to update it.
+ (vc-call-backend vc-dir-backend 'registered fname)))
+ (state (vc-call-backend vc-dir-backend 'state fname))
+ (extra (vc-call-backend vc-dir-backend
+ 'status-fileinfo-extra fname)))
+ (list file-short state extra)))
+
+(defun vc-dir-find-child-files (dirname)
+ ;; Give a DIRNAME string return the list of all child files shown in
+ ;; the current *vc-dir* buffer.
+ (let ((crt (ewoc-nth vc-ewoc 0))
+ children
+ dname)
+ ;; Find DIR
+ (while (and crt (not (vc-string-prefix-p
+ dirname (vc-dir-node-directory crt))))
+ (setq crt (ewoc-next vc-ewoc crt)))
+ (while (and crt (vc-string-prefix-p
+ dirname
+ (setq dname (vc-dir-node-directory crt))))
+ (let ((data (ewoc-data crt)))
+ (unless (vc-dir-fileinfo->directory data)
+ (push (expand-file-name (vc-dir-fileinfo->name data)) children)))
+ (setq crt (ewoc-next vc-ewoc crt)))
+ children))
+
+(defun vc-dir-resync-directory-files (dirname)
+ ;; Update the entries for all the child files of DIRNAME shown in
+ ;; the current *vc-dir* buffer.
+ (let ((files (vc-dir-find-child-files dirname))
+ (ddir default-directory)
+ fileentries)
+ (when files
+ (dolist (crt files)
+ (push (vc-dir-recompute-file-state crt ddir)
+ fileentries))
+ (vc-dir-update fileentries (current-buffer)))))
+
+(defun vc-dir-resynch-file (&optional fname)
+ "Update the entries for FNAME in any directory buffers that list it."
+ (let ((file (or fname (expand-file-name buffer-file-name)))
+ (drop '()))
+ (save-current-buffer
+ ;; look for a vc-dir buffer that might show this file.
+ (dolist (status-buf vc-dir-buffers)
+ (if (not (buffer-live-p status-buf))
+ (push status-buf drop)
+ (set-buffer status-buf)
+ (if (not (derived-mode-p 'vc-dir-mode))
+ (push status-buf drop)
+ (let ((ddir default-directory))
+ (when (vc-string-prefix-p ddir file)
+ (if (file-directory-p file)
+ (progn
+ (vc-dir-resync-directory-files file)
+ (ewoc-set-hf vc-ewoc
+ (vc-dir-headers vc-dir-backend default-directory) ""))
+ (let ((state (vc-dir-recompute-file-state file ddir)))
+ (vc-dir-update
+ (list state)
+ status-buf (eq (cadr state) 'up-to-date))))))))))
+ ;; Remove out-of-date entries from vc-dir-buffers.
+ (dolist (b drop) (setq vc-dir-buffers (delq b vc-dir-buffers)))))
+
+(defvar use-vc-backend) ;; dynamically bound
+
+(define-derived-mode vc-dir-mode special-mode "VC dir"
+ "Major mode for VC directory buffers.
+Marking/Unmarking key bindings and actions:
+m - mark a file/directory
+ - if the region is active, mark all the files in region.
+ Restrictions: - a file cannot be marked if any parent directory is marked
+ - a directory cannot be marked if any child file or
+ directory is marked
+u - unmark a file/directory
+ - if the region is active, unmark all the files in region.
+M - if the cursor is on a file: mark all the files with the same state as
+ the current file
+ - if the cursor is on a directory: mark all child files
+ - with a prefix argument: mark all files
+U - if the cursor is on a file: unmark all the files with the same state
+ as the current file
+ - if the cursor is on a directory: unmark all child files
+ - with a prefix argument: unmark all files
+mouse-2 - toggles the mark state
+
+VC commands
+VC commands in the `C-x v' prefix can be used.
+VC commands act on the marked entries. If nothing is marked, VC
+commands act on the current entry.
+
+Search & Replace
+S - searches the marked files
+Q - does a query replace on the marked files
+M-s a C-s - does an isearch on the marked files
+M-s a C-M-s - does a regexp isearch on the marked files
+If nothing is marked, these commands act on the current entry.
+When a directory is current or marked, the Search & Replace
+commands act on the child files of that directory that are displayed in
+the *vc-dir* buffer.
+
+\\{vc-dir-mode-map}"
+ (set (make-local-variable 'vc-dir-backend) use-vc-backend)
+ (setq buffer-read-only t)
+ (when (boundp 'tool-bar-map)
+ (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (set (make-local-variable 'vc-dir-process-buffer) nil)
+ (set (make-local-variable 'vc-ewoc) (ewoc-create #'vc-dir-printer))
+ (set (make-local-variable 'revert-buffer-function)
+ 'vc-dir-revert-buffer-function)
+ (setq list-buffers-directory (expand-file-name "*vc-dir*" default-directory))
+ (add-to-list 'vc-dir-buffers (current-buffer))
+ ;; Make sure that if the directory buffer is killed, the update
+ ;; process running in the background is also killed.
+ (add-hook 'kill-buffer-query-functions 'vc-dir-kill-query nil t)
+ (hack-dir-local-variables-non-file-buffer)
+ (vc-dir-refresh)))
+
+(defun vc-dir-headers (backend dir)
+ "Display the headers in the *VC dir* buffer.
+It calls the `dir-extra-headers' backend method to display backend
+specific headers."
+ (concat
+ ;; First layout the common headers.
+ (propertize "VC backend : " 'face 'font-lock-type-face)
+ (propertize (format "%s\n" backend) 'face 'font-lock-variable-name-face)
+ (propertize "Working dir: " 'face 'font-lock-type-face)
+ (propertize (format "%s\n" (abbreviate-file-name dir))
+ 'face 'font-lock-variable-name-face)
+ ;; Then the backend specific ones.
+ (vc-call-backend backend 'dir-extra-headers dir)
+ "\n"))
+
+(defun vc-dir-refresh-files (files default-state)
+ "Refresh some files in the *VC-dir* buffer."
+ (let ((def-dir default-directory)
+ (backend vc-dir-backend))
+ (vc-set-mode-line-busy-indicator)
+ ;; Call the `dir-status-file' backend function.
+ ;; `dir-status-file' is supposed to be asynchronous.
+ ;; It should compute the results, and then call the function
+ ;; passed as an argument in order to update the vc-dir buffer
+ ;; with the results.
+ (unless (buffer-live-p vc-dir-process-buffer)
+ (setq vc-dir-process-buffer
+ (generate-new-buffer (format " *VC-%s* tmp status" backend))))
+ (lexical-let ((buffer (current-buffer)))
+ (with-current-buffer vc-dir-process-buffer
+ (cd def-dir)
+ (erase-buffer)
+ (vc-call-backend
+ backend 'dir-status-files def-dir files default-state
+ (lambda (entries &optional more-to-come)
+ ;; ENTRIES is a list of (FILE VC_STATE EXTRA) items.
+ ;; If MORE-TO-COME is true, then more updates will come from
+ ;; the asynchronous process.
+ (with-current-buffer buffer
+ (vc-dir-update entries buffer)
+ (unless more-to-come
+ (setq mode-line-process nil)
+ ;; Remove the ones that haven't been updated at all.
+ ;; Those not-updated are those whose state is nil because the
+ ;; file/dir doesn't exist and isn't versioned.
+ (ewoc-filter vc-ewoc
+ (lambda (info)
+ ;; The state for directory entries might
+ ;; have been changed to 'up-to-date,
+ ;; reset it, othewise it will be removed when doing 'x'
+ ;; next time.
+ ;; FIXME: There should be a more elegant way to do this.
+ (when (and (vc-dir-fileinfo->directory info)
+ (eq (vc-dir-fileinfo->state info)
+ 'up-to-date))
+ (setf (vc-dir-fileinfo->state info) nil))
+
+ (not (vc-dir-fileinfo->needs-update info))))))))))))
+
+(defun vc-dir-revert-buffer-function (&optional ignore-auto noconfirm)
+ (vc-dir-refresh))
+
+(defun vc-dir-refresh ()
+ "Refresh the contents of the *VC-dir* buffer.
+Throw an error if another update process is in progress."
+ (interactive)
+ (if (vc-dir-busy)
+ (error "Another update process is in progress, cannot run two at a time")
+ (let ((def-dir default-directory)
+ (backend vc-dir-backend))
+ (vc-set-mode-line-busy-indicator)
+ ;; Call the `dir-status' backend function.
+ ;; `dir-status' is supposed to be asynchronous.
+ ;; It should compute the results, and then call the function
+ ;; passed as an argument in order to update the vc-dir buffer
+ ;; with the results.
+
+ ;; Create a buffer that can be used by `dir-status' and call
+ ;; `dir-status' with this buffer as the current buffer. Use
+ ;; `vc-dir-process-buffer' to remember this buffer, so that
+ ;; it can be used later to kill the update process in case it
+ ;; takes too long.
+ (unless (buffer-live-p vc-dir-process-buffer)
+ (setq vc-dir-process-buffer
+ (generate-new-buffer (format " *VC-%s* tmp status" backend))))
+ ;; set the needs-update flag on all non-directory entries
+ (ewoc-map (lambda (info)
+ (unless (vc-dir-fileinfo->directory info)
+ (setf (vc-dir-fileinfo->needs-update info) t) nil))
+ vc-ewoc)
+ (lexical-let ((buffer (current-buffer)))
+ (with-current-buffer vc-dir-process-buffer
+ (cd def-dir)
+ (erase-buffer)
+ (vc-call-backend
+ backend 'dir-status def-dir
+ (lambda (entries &optional more-to-come)
+ ;; ENTRIES is a list of (FILE VC_STATE EXTRA) items.
+ ;; If MORE-TO-COME is true, then more updates will come from
+ ;; the asynchronous process.
+ (with-current-buffer buffer
+ (vc-dir-update entries buffer)
+ (unless more-to-come
+ (let ((remaining
+ (ewoc-collect
+ vc-ewoc 'vc-dir-fileinfo->needs-update)))
+ (if remaining
+ (vc-dir-refresh-files
+ (mapcar 'vc-dir-fileinfo->name remaining)
+ 'up-to-date)
+ (setq mode-line-process nil)))))))))
+ (ewoc-set-hf vc-ewoc (vc-dir-headers backend def-dir) ""))))
+
+(defun vc-dir-show-fileentry (file)
+ "Insert an entry for a specific file into the current *VC-dir* listing.
+This is typically used if the file is up-to-date (or has been added
+outside of VC) and one wants to do some operation on it."
+ (interactive "fShow file: ")
+ (vc-dir-update (list (list (file-relative-name file) (vc-state file))) (current-buffer)))
+
+(defun vc-dir-hide-up-to-date ()
+ "Hide up-to-date items from display."
+ (interactive)
+ (let ((crt (ewoc-nth vc-ewoc -1))
+ (first (ewoc-nth vc-ewoc 0)))
+ ;; Go over from the last item to the first and remove the
+ ;; up-to-date files and directories with no child files.
+ (while (not (eq crt first))
+ (let* ((data (ewoc-data crt))
+ (dir (vc-dir-fileinfo->directory data))
+ (next (ewoc-next vc-ewoc crt))
+ (prev (ewoc-prev vc-ewoc crt))
+ ;; ewoc-delete does not work without this...
+ (inhibit-read-only t))
+ (when (or
+ ;; Remove directories with no child files.
+ (and dir
+ (or
+ ;; Nothing follows this directory.
+ (not next)
+ ;; Next item is a directory.
+ (vc-dir-fileinfo->directory (ewoc-data next))))
+ ;; Remove files in the up-to-date state.
+ (eq (vc-dir-fileinfo->state data) 'up-to-date))
+ (ewoc-delete vc-ewoc crt))
+ (setq crt prev)))))
+
+(defun vc-dir-kill-line ()
+ "Remove the current line from display."
+ (interactive)
+ (let ((crt (ewoc-locate vc-ewoc))
+ (inhibit-read-only t))
+ (ewoc-delete vc-ewoc crt)))
+
+(defun vc-dir-printer (fileentry)
+ (vc-call-backend vc-dir-backend 'dir-printer fileentry))
+
+(defun vc-dir-deduce-fileset (&optional state-model-only-files)
+ (let ((marked (vc-dir-marked-files))
+ files
+ only-files-list
+ state
+ model)
+ (if marked
+ (progn
+ (setq files marked)
+ (when state-model-only-files
+ (setq only-files-list (vc-dir-marked-only-files-and-states))))
+ (let ((crt (vc-dir-current-file)))
+ (setq files (list crt))
+ (when state-model-only-files
+ (setq only-files-list (vc-dir-child-files-and-states)))))
+
+ (when state-model-only-files
+ (setq state (cdar only-files-list))
+ ;; Check that all files are in a consistent state, since we use that
+ ;; state to decide which operation to perform.
+ (dolist (crt (cdr only-files-list))
+ (unless (vc-compatible-state (cdr crt) state)
+ (error "When applying VC operations to multiple files, the files are required\nto be in similar VC states.\n%s in state %s clashes with %s in state %s"
+ (car crt) (cdr crt) (caar only-files-list) state)))
+ (setq only-files-list (mapcar 'car only-files-list))
+ (when (and state (not (eq state 'unregistered)))
+ (setq model (vc-checkout-model vc-dir-backend only-files-list))))
+ (list vc-dir-backend files only-files-list state model)))
+
+;;;###autoload
+(defun vc-dir (dir &optional backend)
+ "Show the VC status for \"interesting\" files in and below DIR.
+This allows you to mark files and perform VC operations on them.
+The list omits files which are up to date, with no changes in your copy
+or the repository, if there is nothing in particular to say about them.
+
+Preparing the list of file status takes time; when the buffer
+first appears, it has only the first few lines of summary information.
+The file lines appear later.
+
+Optional second argument BACKEND specifies the VC backend to use.
+Interactively, a prefix argument means to ask for the backend.
+
+These are the commands available for use in the file status buffer:
+
+\\{vc-dir-mode-map}"
+
+ (interactive
+ (list
+ ;; When you hit C-x v d in a visited VC file,
+ ;; the *vc-dir* buffer visits the directory under its truename;
+ ;; therefore it makes sense to always do that.
+ ;; Otherwise if you do C-x v d -> C-x C-f -> C-c v d
+ ;; you may get a new *vc-dir* buffer, different from the original
+ (file-truename (read-file-name "VC status for directory: "
+ default-directory default-directory t
+ nil #'file-directory-p))
+ (if current-prefix-arg
+ (intern
+ (completing-read
+ "Use VC backend: "
+ (mapcar (lambda (b) (list (symbol-name b)))
+ vc-handled-backends)
+ nil t nil nil)))))
+ (unless backend
+ (setq backend (vc-responsible-backend dir)))
+ (let (pop-up-windows) ; based on cvs-examine; bug#6204
+ (pop-to-buffer (vc-dir-prepare-status-buffer "*vc-dir*" dir backend)))
+ (if (derived-mode-p 'vc-dir-mode)
+ (vc-dir-refresh)
+ ;; FIXME: find a better way to pass the backend to `vc-dir-mode'.
+ (let ((use-vc-backend backend))
+ (vc-dir-mode))))
+
+(defun vc-default-dir-extra-headers (backend dir)
+ ;; Be loud by default to remind people to add code to display
+ ;; backend specific headers.
+ ;; XXX: change this to return nil before the release.
+ (concat
+ (propertize "Extra : " 'face 'font-lock-type-face)
+ (propertize "Please add backend specific headers here. It's easy!"
+ 'face 'font-lock-warning-face)))
+
+(defvar vc-dir-filename-mouse-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-2] 'vc-dir-find-file-other-window)
+ map)
+ "Local keymap for visiting a file.")
+
+(defun vc-default-dir-printer (backend fileentry)
+ "Pretty print FILEENTRY."
+ ;; If you change the layout here, change vc-dir-move-to-goal-column.
+ ;; VC backends can implement backend specific versions of this
+ ;; function. Changes here might need to be reflected in the
+ ;; vc-BACKEND-dir-printer functions.
+ (let* ((isdir (vc-dir-fileinfo->directory fileentry))
+ (state (if isdir "" (vc-dir-fileinfo->state fileentry)))
+ (filename (vc-dir-fileinfo->name fileentry)))
+ (insert
+ (propertize
+ (format "%c" (if (vc-dir-fileinfo->marked fileentry) ?* ? ))
+ 'face 'font-lock-type-face)
+ " "
+ (propertize
+ (format "%-20s" state)
+ 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
+ ((memq state '(missing conflict)) 'font-lock-warning-face)
+ (t 'font-lock-variable-name-face))
+ 'mouse-face 'highlight)
+ " "
+ (propertize
+ (format "%s" filename)
+ 'face
+ (if isdir 'font-lock-comment-delimiter-face 'font-lock-function-name-face)
+ 'help-echo
+ (if isdir
+ "Directory\nVC operations can be applied to it\nmouse-3: Pop-up menu"
+ "File\nmouse-3: Pop-up menu")
+ 'mouse-face 'highlight
+ 'keymap vc-dir-filename-mouse-map))))
+
+(defun vc-default-extra-status-menu (backend)
+ nil)
+
+(defun vc-default-status-fileinfo-extra (backend file)
+ "Default absence of extra information returned for a file."
+ nil)
+
+(provide 'vc-dir)
+
+;; arch-tag: 0274a2e3-e8e9-4b1a-a73c-e8b9129d5d15
+;;; vc-dir.el ends here
--- /dev/null
+;;; vc-dispatcher.el -- generic command-dispatcher facility.
+
+;; Copyright (C) 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see below for full credits)
+;; Maintainer: Eric S. Raymond <esr@thyrsus.com>
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Credits:
+
+;; Designed and implemented by Eric S. Raymond, originally as part of VC mode.
+;; Stefan Monnier and Dan Nicolaescu contributed substantial work on the
+;; vc-dir front end.
+
+;;; Commentary:
+
+;; Goals:
+;;
+;; There is a class of front-ending problems that Emacs might be used
+;; to address that involves selecting sets of files, or possibly
+;; directories, and passing the selection set to slave commands. The
+;; prototypical example, from which this code is derived, is talking
+;; to version-control systems.
+;;
+;; vc-dispatcher.el is written to decouple the UI issues in such front
+;; ends from their application-specific logic. It also provides a
+;; service layer for running the slave commands either synchronously
+;; or asynchronously and managing the message/error logs from the
+;; command runs.
+;;
+;; Similar UI problems can be expected to come up in applications
+;; areas other than VCSes; IDEs and document search are two obvious ones.
+;; This mode is intended to ensure that the Emacs interfaces for all such
+;; beasts are consistent and carefully designed. But even if nothing
+;; but VC ever uses it, getting the layer separation right will be
+;; a valuable thing.
+
+;; Dispatcher's universe:
+;;
+;; The universe consists of the file tree rooted at the current
+;; directory. The dispatcher's upper layer deduces some subset
+;; of the file tree from the state of the currently visited buffer
+;; and returns that subset, presumably to a client mode.
+;;
+;; The user may be looking at either of two different views; a buffer
+;; visiting a file, or a directory buffer generated by vc-dispatcher.
+;;
+;; The lower layer of this mode runs commands in subprocesses, either
+;; synchronously or asynchronously. Commands may be launched in one
+;; of two ways: they may be run immediately, or the calling mode can
+;; create a closure associated with a text-entry buffer, to be
+;; executed when the user types C-c to ship the buffer contents. In
+;; either case the command messages and error (if any) will remain
+;; available in a status buffer.
+
+;; Special behavior of dispatcher directory buffers:
+;;
+;; In dispatcher directory buffers, facilities to perform basic
+;; navigation and selection operations are provided by keymap and menu
+;; entries that dispatcher sets up itself, so they'll be uniform
+;; across all dispatcher-using client modes. Client modes are
+;; expected to append to these to provide mode-specific bindings.
+;;
+;; The standard map associates a 'state' slot (that the client mode
+;; may set) with each directory entry. The dispatcher knows nothing
+;; about the semantics of individual states, but mark and unmark commands
+;; treat all entries with the same state as the currently selected one as
+;; a unit.
+
+;; The interface:
+;;
+;; The main interface to the lower level is vc-do-command. This launches a
+;; command, synchronously or asynchronously, making the output available
+;; in a command log buffer. Two other functions, (vc-start-logentry) and
+;; (vc-finish-logentry), allow you to associate a command closure with an
+;; annotation buffer so that when the user confirms the comment the closure
+;; is run (with the comment as part of its context).
+;;
+;; The interface to the upper level has the two main entry points (vc-dir)
+;; and (vc-dispatcher-selection-set) and a couple of convenience functions.
+;; (vc-dir) sets up a dispatcher browsing buffer; (vc-dispatcher-selection-set)
+;; returns a selection set of files, either the marked files in a browsing
+;; buffer or the singleton set consisting of the file visited by the current
+;; buffer (when that is appropriate). It also does what is needed to ensure
+;; that on-disk files and the contents of their visiting Emacs buffers
+;; coincide.
+;;
+;; When the client mode adds a local vc-mode-line-hook to a buffer, it
+;; will be called with the buffer file name as argument whenever the
+;; dispatcher resynchs the buffer.
+
+;; To do:
+;;
+;; - log buffers need font-locking.
+;;
+
+;; General customization
+(defcustom vc-logentry-check-hook nil
+ "Normal hook run by `vc-finish-logentry'.
+Use this to impose your own rules on the entry in addition to any the
+dispatcher client mode imposes itself."
+ :type 'hook
+ :group 'vc)
+
+(defcustom vc-delete-logbuf-window t
+ "If non-nil, delete the log buffer and window after each logical action.
+If nil, bury that buffer instead.
+This is most useful if you have multiple windows on a frame and would like to
+preserve the setting."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-command-messages nil
+ "If non-nil, display run messages from back-end commands."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-suppress-confirm nil
+ "If non-nil, treat user as expert; suppress yes-no prompts on some things."
+ :type 'boolean
+ :group 'vc)
+
+;; Variables the user doesn't need to know about.
+
+(defvar vc-log-operation nil)
+(defvar vc-log-after-operation-hook nil)
+(defvar vc-log-fileset)
+
+;; In a log entry buffer, this is a local variable
+;; that points to the buffer for which it was made
+;; (either a file, or a directory buffer).
+(defvar vc-parent-buffer nil)
+(put 'vc-parent-buffer 'permanent-local t)
+(defvar vc-parent-buffer-name nil)
+(put 'vc-parent-buffer-name 'permanent-local t)
+
+;; Common command execution logic
+
+(defun vc-process-filter (p s)
+ "An alternative output filter for async process P.
+One difference with the default filter is that this inserts S after markers.
+Another is that undo information is not kept."
+ (let ((buffer (process-buffer p)))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (save-excursion
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t))
+ (goto-char (process-mark p))
+ (insert s)
+ (set-marker (process-mark p) (point))))))))
+
+(defun vc-setup-buffer (buf)
+ "Prepare BUF for executing a slave command and make it current."
+ (let ((camefrom (current-buffer))
+ (olddir default-directory))
+ (set-buffer (get-buffer-create buf))
+ (kill-all-local-variables)
+ (set (make-local-variable 'vc-parent-buffer) camefrom)
+ (set (make-local-variable 'vc-parent-buffer-name)
+ (concat " from " (buffer-name camefrom)))
+ (setq default-directory olddir)
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t))
+ (erase-buffer))))
+
+(defvar vc-sentinel-movepoint) ;Dynamically scoped.
+
+(defun vc-process-sentinel (p s)
+ (let ((previous (process-get p 'vc-previous-sentinel))
+ (buf (process-buffer p)))
+ ;; Impatient users sometime kill "slow" buffers; check liveness
+ ;; to avoid "error in process sentinel: Selecting deleted buffer".
+ (when (buffer-live-p buf)
+ (when previous (funcall previous p s))
+ (with-current-buffer buf
+ (setq mode-line-process
+ (let ((status (process-status p)))
+ ;; Leave mode-line uncluttered, normally.
+ (unless (eq 'exit status)
+ (format " (%s)" status))))
+ (let (vc-sentinel-movepoint)
+ ;; Normally, we want async code such as sentinels to not move point.
+ (save-excursion
+ (goto-char (process-mark p))
+ (let ((cmds (process-get p 'vc-sentinel-commands)))
+ (process-put p 'vc-sentinel-commands nil)
+ (dolist (cmd cmds)
+ ;; Each sentinel may move point and the next one should be run
+ ;; at that new point. We could get the same result by having
+ ;; each sentinel read&set process-mark, but since `cmd' needs
+ ;; to work both for async and sync processes, this would be
+ ;; difficult to achieve.
+ (vc-exec-after cmd))))
+ ;; But sometimes the sentinels really want to move point.
+ (when vc-sentinel-movepoint
+ (let ((win (get-buffer-window (current-buffer) 0)))
+ (if (not win)
+ (goto-char vc-sentinel-movepoint)
+ (with-selected-window win
+ (goto-char vc-sentinel-movepoint))))))))))
+
+(defun vc-set-mode-line-busy-indicator ()
+ (setq mode-line-process
+ (concat " " (propertize "[waiting...]"
+ 'face 'mode-line-emphasis
+ 'help-echo
+ "A command is in progress in this buffer"))))
+
+(defun vc-exec-after (code)
+ "Eval CODE when the current buffer's process is done.
+If the current buffer has no process, just evaluate CODE.
+Else, add CODE to the process' sentinel."
+ (let ((proc (get-buffer-process (current-buffer))))
+ (cond
+ ;; If there's no background process, just execute the code.
+ ;; We used to explicitly call delete-process on exited processes,
+ ;; but this led to timing problems causing process output to be
+ ;; lost. Terminated processes get deleted automatically
+ ;; anyway. -- cyd
+ ((or (null proc) (eq (process-status proc) 'exit))
+ ;; Make sure we've read the process's output before going further.
+ (when proc (accept-process-output proc))
+ (eval code))
+ ;; If a process is running, add CODE to the sentinel
+ ((eq (process-status proc) 'run)
+ (vc-set-mode-line-busy-indicator)
+ (let ((previous (process-sentinel proc)))
+ (unless (eq previous 'vc-process-sentinel)
+ (process-put proc 'vc-previous-sentinel previous))
+ (set-process-sentinel proc 'vc-process-sentinel))
+ (process-put proc 'vc-sentinel-commands
+ ;; We keep the code fragments in the order given
+ ;; so that vc-diff-finish's message shows up in
+ ;; the presence of non-nil vc-command-messages.
+ (append (process-get proc 'vc-sentinel-commands)
+ (list code))))
+ (t (error "Unexpected process state"))))
+ nil)
+
+(defvar vc-post-command-functions nil
+ "Hook run at the end of `vc-do-command'.
+Each function is called inside the buffer in which the command was run
+and is passed 3 arguments: the COMMAND, the FILES and the FLAGS.")
+
+(defvar w32-quote-process-args)
+
+(defun vc-delistify (filelist)
+ "Smash a FILELIST into a file list string suitable for info messages."
+ ;; FIXME what about file names with spaces?
+ (if (not filelist) "." (mapconcat 'identity filelist " ")))
+
+;;;###autoload
+(defun vc-do-command (buffer okstatus command file-or-list &rest flags)
+ "Execute a slave command, notifying user and checking for errors.
+Output from COMMAND goes to BUFFER, or the current buffer if
+BUFFER is t. If the destination buffer is not already current,
+set it up properly and erase it. The command is considered
+successful if its exit status does not exceed OKSTATUS (if
+OKSTATUS is nil, that means to ignore error status, if it is
+`async', that means not to wait for termination of the
+subprocess; if it is t it means to ignore all execution errors).
+FILE-OR-LIST is the name of a working file; it may be a list of
+files or be nil (to execute commands that don't expect a file
+name or set of files). If an optional list of FLAGS is present,
+that is inserted into the command line before the filename.
+Return the return value of the slave command in the synchronous
+case, and the process object in the asynchronous case."
+ ;; FIXME: file-relative-name can return a bogus result because
+ ;; it doesn't look at the actual file-system to see if symlinks
+ ;; come into play.
+ (let* ((files
+ (mapcar (lambda (f) (file-relative-name (expand-file-name f)))
+ (if (listp file-or-list) file-or-list (list file-or-list))))
+ (full-command
+ ;; What we're doing here is preparing a version of the command
+ ;; for display in a debug-progress message. If it's fewer than
+ ;; 20 characters display the entire command (without trailing
+ ;; newline). Otherwise display the first 20 followed by an ellipsis.
+ (concat (if (string= (substring command -1) "\n")
+ (substring command 0 -1)
+ command)
+ " "
+ (vc-delistify (mapcar (lambda (s) (if (> (length s) 20) (concat (substring s 0 2) "...") s)) flags))
+ " " (vc-delistify files))))
+ (save-current-buffer
+ (unless (or (eq buffer t)
+ (and (stringp buffer)
+ (string= (buffer-name) buffer))
+ (eq buffer (current-buffer)))
+ (vc-setup-buffer buffer))
+ ;; If there's some previous async process still running, just kill it.
+ (let ((oldproc (get-buffer-process (current-buffer))))
+ ;; If we wanted to wait for oldproc to finish before doing
+ ;; something, we'd have used vc-eval-after.
+ ;; Use `delete-process' rather than `kill-process' because we don't
+ ;; want any of its output to appear from now on.
+ (when oldproc (delete-process oldproc)))
+ (let ((squeezed (remq nil flags))
+ (inhibit-read-only t)
+ (status 0))
+ (when files
+ (setq squeezed (nconc squeezed files)))
+ (let (;; Since some functions need to parse the output
+ ;; from external commands, set LC_MESSAGES to C.
+ (process-environment (cons "LC_MESSAGES=C" process-environment))
+ (w32-quote-process-args t))
+ (if (eq okstatus 'async)
+ ;; Run asynchronously.
+ (let ((proc
+ (let ((process-connection-type nil))
+ (apply 'start-file-process command (current-buffer)
+ command squeezed))))
+ (when vc-command-messages
+ (message "Running %s in background..." full-command))
+ ;;(set-process-sentinel proc (lambda (p msg) (delete-process p)))
+ (set-process-filter proc 'vc-process-filter)
+ (setq status proc)
+ (when vc-command-messages
+ (vc-exec-after
+ `(message "Running %s in background... done" ',full-command))))
+ ;; Run synchronously
+ (when vc-command-messages
+ (message "Running %s in foreground..." full-command))
+ (let ((buffer-undo-list t))
+ (setq status (apply 'process-file command nil t nil squeezed)))
+ (when (and (not (eq t okstatus))
+ (or (not (integerp status))
+ (and okstatus (< okstatus status))))
+ (unless (eq ?\s (aref (buffer-name (current-buffer)) 0))
+ (pop-to-buffer (current-buffer))
+ (goto-char (point-min))
+ (shrink-window-if-larger-than-buffer))
+ (error "Running %s...FAILED (%s)" full-command
+ (if (integerp status) (format "status %d" status) status)))
+ (when vc-command-messages
+ (message "Running %s...OK = %d" full-command status))))
+ (vc-exec-after
+ `(run-hook-with-args 'vc-post-command-functions
+ ',command ',file-or-list ',flags))
+ status))))
+
+;; These functions are used to ensure that the view the user sees is up to date
+;; even if the dispatcher client mode has messed with file contents (as in,
+;; for example, VCS keyword expansion).
+
+(declare-function view-mode-exit "view" (&optional return-to-alist exit-action all-win))
+
+(defun vc-position-context (posn)
+ "Save a bit of the text around POSN in the current buffer.
+Used to help us find the corresponding position again later
+if markers are destroyed or corrupted."
+ ;; A lot of this was shamelessly lifted from Sebastian Kremer's
+ ;; rcs.el mode.
+ (list posn
+ (buffer-size)
+ (buffer-substring posn
+ (min (point-max) (+ posn 100)))))
+
+(defun vc-find-position-by-context (context)
+ "Return the position of CONTEXT in the current buffer.
+If CONTEXT cannot be found, return nil."
+ (let ((context-string (nth 2 context)))
+ (if (equal "" context-string)
+ (point-max)
+ (save-excursion
+ (let ((diff (- (nth 1 context) (buffer-size))))
+ (when (< diff 0) (setq diff (- diff)))
+ (goto-char (nth 0 context))
+ (if (or (search-forward context-string nil t)
+ ;; Can't use search-backward since the match may continue
+ ;; after point.
+ (progn (goto-char (- (point) diff (length context-string)))
+ ;; goto-char doesn't signal an error at
+ ;; beginning of buffer like backward-char would
+ (search-forward context-string nil t)))
+ ;; to beginning of OSTRING
+ (- (point) (length context-string))))))))
+
+(defun vc-context-matches-p (posn context)
+ "Return t if POSN matches CONTEXT, nil otherwise."
+ (let* ((context-string (nth 2 context))
+ (len (length context-string))
+ (end (+ posn len)))
+ (if (> end (1+ (buffer-size)))
+ nil
+ (string= context-string (buffer-substring posn end)))))
+
+(defun vc-buffer-context ()
+ "Return a list (POINT-CONTEXT MARK-CONTEXT REPARSE).
+Used by `vc-restore-buffer-context' to later restore the context."
+ (let ((point-context (vc-position-context (point)))
+ ;; Use mark-marker to avoid confusion in transient-mark-mode.
+ (mark-context (when (eq (marker-buffer (mark-marker)) (current-buffer))
+ (vc-position-context (mark-marker))))
+ ;; Make the right thing happen in transient-mark-mode.
+ (mark-active nil))
+ (list point-context mark-context nil)))
+
+(defun vc-restore-buffer-context (context)
+ "Restore point/mark, and reparse any affected compilation buffers.
+CONTEXT is that which `vc-buffer-context' returns."
+ (let ((point-context (nth 0 context))
+ (mark-context (nth 1 context)))
+ ;; if necessary, restore point and mark
+ (if (not (vc-context-matches-p (point) point-context))
+ (let ((new-point (vc-find-position-by-context point-context)))
+ (when new-point (goto-char new-point))))
+ (and mark-active
+ mark-context
+ (not (vc-context-matches-p (mark) mark-context))
+ (let ((new-mark (vc-find-position-by-context mark-context)))
+ (when new-mark (set-mark new-mark))))))
+
+(defun vc-revert-buffer-internal (&optional arg no-confirm)
+ "Revert buffer, keeping point and mark where user expects them.
+Try to be clever in the face of changes due to expanded version-control
+key words. This is important for typeahead to work as expected.
+ARG and NO-CONFIRM are passed on to `revert-buffer'."
+ (interactive "P")
+ (widen)
+ (let ((context (vc-buffer-context)))
+ ;; Use save-excursion here, because it may be able to restore point
+ ;; and mark properly even in cases where vc-restore-buffer-context
+ ;; would fail. However, save-excursion might also get it wrong --
+ ;; in this case, vc-restore-buffer-context gives it a second try.
+ (save-excursion
+ ;; t means don't call normal-mode;
+ ;; that's to preserve various minor modes.
+ (revert-buffer arg no-confirm t))
+ (vc-restore-buffer-context context)))
+
+(defvar vc-mode-line-hook nil)
+(make-variable-buffer-local 'vc-mode-line-hook)
+(put 'vc-mode-line-hook 'permanent-local t)
+
+(defun vc-resynch-window (file &optional keep noquery reset-vc-info)
+ "If FILE is in the current buffer, either revert or unvisit it.
+The choice between revert (to see expanded keywords) and unvisit
+depends on KEEP. NOQUERY if non-nil inhibits confirmation for
+reverting. NOQUERY should be t *only* if it is known the only
+difference between the buffer and the file is due to
+modifications by the dispatcher client code, rather than user
+editing!"
+ (and (string= buffer-file-name file)
+ (if keep
+ (when (file-exists-p file)
+ (when reset-vc-info
+ (vc-file-clearprops file))
+ (vc-revert-buffer-internal t noquery)
+
+ ;; VC operations might toggle the read-only state. In
+ ;; that case we need to adjust the `view-mode' status
+ ;; when `view-read-only' is non-nil.
+ (and view-read-only
+ (if (file-writable-p file)
+ (and view-mode
+ (let ((view-old-buffer-read-only nil))
+ (view-mode-exit)))
+ (and (not view-mode)
+ (not (eq (get major-mode 'mode-class) 'special))
+ (view-mode-enter))))
+
+ ;; FIXME: Why use a hook? Why pass it buffer-file-name?
+ (run-hook-with-args 'vc-mode-line-hook buffer-file-name))
+ (kill-buffer (current-buffer)))))
+
+(declare-function vc-dir-resynch-file "vc-dir" (&optional fname))
+(declare-function vc-string-prefix-p "vc" (prefix string))
+
+(defun vc-resynch-buffers-in-directory (directory &optional keep noquery reset-vc-info)
+ "Resync all buffers that visit files in DIRECTORY."
+ (dolist (buffer (buffer-list))
+ (let ((fname (buffer-file-name buffer)))
+ (when (and fname (vc-string-prefix-p directory fname))
+ (with-current-buffer buffer
+ (vc-resynch-buffer fname keep noquery reset-vc-info))))))
+
+(defun vc-resynch-buffer (file &optional keep noquery reset-vc-info)
+ "If FILE is currently visited, resynch its buffer."
+ (if (string= buffer-file-name file)
+ (vc-resynch-window file keep noquery reset-vc-info)
+ (if (file-directory-p file)
+ (vc-resynch-buffers-in-directory file keep noquery reset-vc-info)
+ (let ((buffer (get-file-buffer file)))
+ (when buffer
+ (with-current-buffer buffer
+ (vc-resynch-window file keep noquery reset-vc-info))))))
+ ;; Try to avoid unnecessary work, a *vc-dir* buffer is only present
+ ;; if this is true.
+ (when vc-dir-buffers
+ (vc-dir-resynch-file file)))
+
+(defun vc-buffer-sync (&optional not-urgent)
+ "Make sure the current buffer and its working file are in sync.
+NOT-URGENT means it is ok to continue if the user says not to save."
+ (when (buffer-modified-p)
+ (if (or vc-suppress-confirm
+ (y-or-n-p (format "Buffer %s modified; save it? " (buffer-name))))
+ (save-buffer)
+ (unless not-urgent
+ (error "Aborted")))))
+
+;; Command closures
+
+;; Set up key bindings for use while editing log messages
+
+(defun vc-log-edit (fileset mode)
+ "Set up `log-edit' for use on FILE."
+ (setq default-directory
+ (with-current-buffer vc-parent-buffer default-directory))
+ (log-edit 'vc-finish-logentry
+ nil
+ `((log-edit-listfun . (lambda ()
+ ;; FIXME: Should expand the list
+ ;; for directories.
+ (mapcar 'file-relative-name
+ ',fileset)))
+ (log-edit-diff-function . (lambda () (vc-diff nil))))
+ nil
+ mode)
+ (set (make-local-variable 'vc-log-fileset) fileset)
+ (set-buffer-modified-p nil)
+ (setq buffer-file-name nil))
+
+(defun vc-start-logentry (files comment initial-contents msg logbuf mode action &optional after-hook)
+ "Accept a comment for an operation on FILES.
+If COMMENT is nil, pop up a LOGBUF buffer, emit MSG, and set the
+action on close to ACTION. If COMMENT is a string and
+INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial
+contents of the log entry buffer. If COMMENT is a string and
+INITIAL-CONTENTS is nil, do action immediately as if the user had
+entered COMMENT. If COMMENT is t, also do action immediately with an
+empty comment. Remember the file's buffer in `vc-parent-buffer'
+\(current one if no file). Puts the log-entry buffer in major-mode
+MODE, defaulting to `log-edit-mode' if MODE is nil.
+AFTER-HOOK specifies the local value for `vc-log-after-operation-hook'."
+ (let ((parent
+ (if (vc-dispatcher-browsing)
+ ;; If we are called from a directory browser, the parent buffer is
+ ;; the current buffer.
+ (current-buffer)
+ (if (and files (equal (length files) 1))
+ (get-file-buffer (car files))
+ (current-buffer)))))
+ (if (and comment (not initial-contents))
+ (set-buffer (get-buffer-create logbuf))
+ (pop-to-buffer (get-buffer-create logbuf)))
+ (set (make-local-variable 'vc-parent-buffer) parent)
+ (set (make-local-variable 'vc-parent-buffer-name)
+ (concat " from " (buffer-name vc-parent-buffer)))
+ (vc-log-edit files mode)
+ (make-local-variable 'vc-log-after-operation-hook)
+ (when after-hook
+ (setq vc-log-after-operation-hook after-hook))
+ (setq vc-log-operation action)
+ (when comment
+ (erase-buffer)
+ (when (stringp comment) (insert comment)))
+ (if (or (not comment) initial-contents)
+ (message "%s Type C-c C-c when done" msg)
+ (vc-finish-logentry (eq comment t)))))
+
+(declare-function vc-dir-move-to-goal-column "vc-dir" ())
+;; vc-finish-logentry is typically called from a log-edit buffer (see
+;; vc-start-logentry).
+(defun vc-finish-logentry (&optional nocomment)
+ "Complete the operation implied by the current log entry.
+Use the contents of the current buffer as a check-in or registration
+comment. If the optional arg NOCOMMENT is non-nil, then don't check
+the buffer contents as a comment."
+ (interactive)
+ ;; Check and record the comment, if any.
+ (unless nocomment
+ (run-hooks 'vc-logentry-check-hook))
+ ;; Sync parent buffer in case the user modified it while editing the comment.
+ ;; But not if it is a vc-dir buffer.
+ (with-current-buffer vc-parent-buffer
+ (or (vc-dispatcher-browsing) (vc-buffer-sync)))
+ (unless vc-log-operation
+ (error "No log operation is pending"))
+
+ ;; save the parameters held in buffer-local variables
+ (let ((logbuf (current-buffer))
+ (log-operation vc-log-operation)
+ ;; FIXME: When coming from VC-Dir, we should check that the
+ ;; set of selected files is still equal to vc-log-fileset,
+ ;; to avoid surprises.
+ (log-fileset vc-log-fileset)
+ (log-entry (buffer-string))
+ (after-hook vc-log-after-operation-hook))
+ (pop-to-buffer vc-parent-buffer)
+ ;; OK, do it to it
+ (save-excursion
+ (funcall log-operation
+ log-fileset
+ log-entry))
+ ;; Remove checkin window (after the checkin so that if that fails
+ ;; we don't zap the log buffer and the typing therein).
+ ;; -- IMO this should be replaced with quit-window
+ (cond ((and logbuf vc-delete-logbuf-window)
+ (delete-windows-on logbuf (selected-frame))
+ ;; Kill buffer and delete any other dedicated windows/frames.
+ (kill-buffer logbuf))
+ (logbuf
+ (with-selected-window (or (get-buffer-window logbuf 0)
+ (selected-window))
+ (with-current-buffer logbuf
+ (bury-buffer)))))
+ ;; Now make sure we see the expanded headers
+ (when log-fileset
+ (mapc
+ (lambda (file) (vc-resynch-buffer file vc-keep-workfiles t))
+ log-fileset))
+ (when (vc-dispatcher-browsing)
+ (vc-dir-move-to-goal-column))
+ (run-hooks after-hook 'vc-finish-logentry-hook)))
+
+(defun vc-dispatcher-browsing ()
+ "Are we in a directory browser buffer?"
+ (derived-mode-p 'vc-dir-mode))
+
+;; These are unused.
+;; (defun vc-dispatcher-in-fileset-p (fileset)
+;; (let ((member nil))
+;; (while (and (not member) fileset)
+;; (let ((elem (pop fileset)))
+;; (if (if (file-directory-p elem)
+;; (eq t (compare-strings buffer-file-name nil (length elem)
+;; elem nil nil))
+;; (eq (current-buffer) (get-file-buffer elem)))
+;; (setq member t))))
+;; member))
+
+;; (defun vc-dispatcher-selection-set (&optional observer)
+;; "Deduce a set of files to which to apply an operation. Return a cons
+;; cell (SELECTION . FILESET), where SELECTION is what the user chose
+;; and FILES is the flist with any directories replaced by the listed files
+;; within them.
+
+;; If we're in a directory display, the fileset is the list of marked files (if
+;; there is one) else the file on the current line. If not in a directory
+;; display, but the current buffer visits a file, the fileset is a singleton
+;; containing that file. Otherwise, throw an error."
+;; (let ((selection
+;; (cond
+;; ;; Browsing with vc-dir
+;; ((vc-dispatcher-browsing)
+;; ;; If no files are marked, temporarily mark current file
+;; ;; and choose on that basis (so we get subordinate files)
+;; (if (not (vc-dir-marked-files))
+;; (prog2
+;; (vc-dir-mark-file)
+;; (cons (vc-dir-marked-files) (vc-dir-marked-only-files))
+;; (vc-dir-unmark-all-files t))
+;; (cons (vc-dir-marked-files) (vc-dir-marked-only-files))))
+;; ;; Visiting an eligible file
+;; ((buffer-file-name)
+;; (cons (list buffer-file-name) (list buffer-file-name)))
+;; ;; No eligible file -- if there's a parent buffer, deduce from there
+;; ((and vc-parent-buffer (or (buffer-file-name vc-parent-buffer)
+;; (with-current-buffer vc-parent-buffer
+;; (vc-dispatcher-browsing))))
+;; (with-current-buffer vc-parent-buffer
+;; (vc-dispatcher-selection-set)))
+;; ;; No good set here, throw error
+;; (t (error "No fileset is available here")))))
+;; ;; We assume, in order to avoid unpleasant surprises to the user,
+;; ;; that a fileset is not in good shape to be handed to the user if the
+;; ;; buffers visiting the fileset don't match the on-disk contents.
+;; (unless observer
+;; (save-some-buffers
+;; nil (lambda () (vc-dispatcher-in-fileset-p (cdr selection)))))
+;; selection))
+
+(provide 'vc-dispatcher)
+
+;; arch-tag: 7d08b17f-5470-4799-914b-bfb9fcf6a246
+;;; vc-dispatcher.el ends here
--- /dev/null
+;;; vc-git.el --- VC backend for the git version control system
+
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Alexandre Julliard <julliard@winehq.org>
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file contains a VC backend for the git version control
+;; system.
+;;
+
+;;; Installation:
+
+;; To install: put this file on the load-path and add Git to the list
+;; of supported backends in `vc-handled-backends'; the following line,
+;; placed in your ~/.emacs, will accomplish this:
+;;
+;; (add-to-list 'vc-handled-backends 'Git)
+
+;;; Todo:
+;; - check if more functions could use vc-git-command instead
+;; of start-process.
+;; - changelog generation
+
+;; Implement the rest of the vc interface. See the comment at the
+;; beginning of vc.el. The current status is:
+;; ("??" means: "figure out what to do about it")
+;;
+;; FUNCTION NAME STATUS
+;; BACKEND PROPERTIES
+;; * revision-granularity OK
+;; STATE-QUERYING FUNCTIONS
+;; * registered (file) OK
+;; * state (file) OK
+;; - state-heuristic (file) NOT NEEDED
+;; * working-revision (file) OK
+;; - latest-on-branch-p (file) NOT NEEDED
+;; * checkout-model (files) OK
+;; - workfile-unchanged-p (file) OK
+;; - mode-line-string (file) OK
+;; STATE-CHANGING FUNCTIONS
+;; * create-repo () OK
+;; * register (files &optional rev comment) OK
+;; - init-revision (file) NOT NEEDED
+;; - responsible-p (file) OK
+;; - could-register (file) NOT NEEDED, DEFAULT IS GOOD
+;; - receive-file (file rev) NOT NEEDED
+;; - unregister (file) OK
+;; * checkin (files rev comment) OK
+;; * find-revision (file rev buffer) OK
+;; * checkout (file &optional editable rev) OK
+;; * revert (file &optional contents-done) OK
+;; - rollback (files) COULD BE SUPPORTED
+;; - merge (file rev1 rev2) It would be possible to merge
+;; changes into a single file, but
+;; when committing they wouldn't
+;; be identified as a merge
+;; by git, so it's probably
+;; not a good idea.
+;; - merge-news (file) see `merge'
+;; - steal-lock (file &optional revision) NOT NEEDED
+;; HISTORY FUNCTIONS
+;; * print-log (files buffer &optional shortlog start-revision limit) OK
+;; - log-view-mode () OK
+;; - show-log-entry (revision) OK
+;; - comment-history (file) ??
+;; - update-changelog (files) COULD BE SUPPORTED
+;; * diff (file &optional rev1 rev2 buffer) OK
+;; - revision-completion-table (files) OK
+;; - annotate-command (file buf &optional rev) OK
+;; - annotate-time () OK
+;; - annotate-current-time () NOT NEEDED
+;; - annotate-extract-revision-at-line () OK
+;; TAG SYSTEM
+;; - create-tag (dir name branchp) OK
+;; - retrieve-tag (dir name update) OK
+;; MISCELLANEOUS
+;; - make-version-backups-p (file) NOT NEEDED
+;; - repository-hostname (dirname) NOT NEEDED
+;; - previous-revision (file rev) OK
+;; - next-revision (file rev) OK
+;; - check-headers () COULD BE SUPPORTED
+;; - clear-headers () NOT NEEDED
+;; - delete-file (file) OK
+;; - rename-file (old new) OK
+;; - find-file-hook () NOT NEEDED
+
+(eval-when-compile
+ (require 'cl)
+ (require 'vc)
+ (require 'vc-dir)
+ (require 'grep))
+
+(defcustom vc-git-diff-switches t
+ "String or list of strings specifying switches for Git diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "23.1"
+ :group 'vc)
+
+(defvar vc-git-commits-coding-system 'utf-8
+ "Default coding system for git commits.")
+
+;;; BACKEND PROPERTIES
+
+(defun vc-git-revision-granularity () 'repository)
+(defun vc-git-checkout-model (files) 'implicit)
+
+;;; STATE-QUERYING FUNCTIONS
+
+;;;###autoload (defun vc-git-registered (file)
+;;;###autoload "Return non-nil if FILE is registered with git."
+;;;###autoload (if (vc-find-root file ".git") ; Short cut.
+;;;###autoload (progn
+;;;###autoload (load "vc-git")
+;;;###autoload (vc-git-registered file))))
+
+(defun vc-git-registered (file)
+ "Check whether FILE is registered with git."
+ (let ((dir (vc-git-root file)))
+ (when dir
+ (with-temp-buffer
+ (let* (process-file-side-effects
+ ;; Do not use the `file-name-directory' here: git-ls-files
+ ;; sometimes fails to return the correct status for relative
+ ;; path specs.
+ ;; See also: http://marc.info/?l=git&m=125787684318129&w=2
+ (name (file-relative-name file dir))
+ (str (ignore-errors
+ (cd dir)
+ (vc-git--out-ok "ls-files" "-c" "-z" "--" name)
+ ;; If result is empty, use ls-tree to check for deleted
+ ;; file.
+ (when (eq (point-min) (point-max))
+ (vc-git--out-ok "ls-tree" "--name-only" "-z" "HEAD"
+ "--" name))
+ (buffer-string))))
+ (and str
+ (> (length str) (length name))
+ (string= (substring str 0 (1+ (length name)))
+ (concat name "\0"))))))))
+
+(defun vc-git--state-code (code)
+ "Convert from a string to a added/deleted/modified state."
+ (case (string-to-char code)
+ (?M 'edited)
+ (?A 'added)
+ (?D 'removed)
+ (?U 'edited) ;; FIXME
+ (?T 'edited))) ;; FIXME
+
+(defun vc-git-state (file)
+ "Git-specific version of `vc-state'."
+ ;; FIXME: This can't set 'ignored or 'conflict yet
+ ;; The 'ignored state could be detected with `git ls-files -i -o
+ ;; --exclude-standard` It also can't set 'needs-update or
+ ;; 'needs-merge. The rough equivalent would be that upstream branch
+ ;; for current branch is in fast-forward state i.e. current branch
+ ;; is direct ancestor of corresponding upstream branch, and the file
+ ;; was modified upstream. But we can't check that without a network
+ ;; operation.
+ (if (not (vc-git-registered file))
+ 'unregistered
+ (vc-git--call nil "add" "--refresh" "--" (file-relative-name file))
+ (let ((diff (vc-git--run-command-string
+ file "diff-index" "-z" "HEAD" "--")))
+ (if (and diff (string-match ":[0-7]\\{6\\} [0-7]\\{6\\} [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\([ADMUT]\\)\0[^\0]+\0"
+ diff))
+ (vc-git--state-code (match-string 1 diff))
+ (if (vc-git--empty-db-p) 'added 'up-to-date)))))
+
+(defun vc-git-working-revision (file)
+ "Git-specific version of `vc-working-revision'."
+ (let* (process-file-side-effects
+ (str (with-output-to-string
+ (with-current-buffer standard-output
+ (vc-git--out-ok "symbolic-ref" "HEAD")))))
+ (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
+ (match-string 2 str)
+ str)))
+
+(defun vc-git-workfile-unchanged-p (file)
+ (eq 'up-to-date (vc-git-state file)))
+
+(defun vc-git-mode-line-string (file)
+ "Return string for placement into the modeline for FILE."
+ (let* ((branch (vc-git-working-revision file))
+ (def-ml (vc-default-mode-line-string 'Git file))
+ (help-echo (get-text-property 0 'help-echo def-ml)))
+ (if (zerop (length branch))
+ (propertize
+ (concat def-ml "!")
+ 'help-echo (concat help-echo "\nNo current branch (detached HEAD)"))
+ (propertize def-ml
+ 'help-echo (concat help-echo "\nCurrent branch: " branch)))))
+
+(defstruct (vc-git-extra-fileinfo
+ (:copier nil)
+ (:constructor vc-git-create-extra-fileinfo
+ (old-perm new-perm &optional rename-state orig-name))
+ (:conc-name vc-git-extra-fileinfo->))
+ old-perm new-perm ;; Permission flags.
+ rename-state ;; Rename or copy state.
+ orig-name) ;; Original name for renames or copies.
+
+(defun vc-git-escape-file-name (name)
+ "Escape a file name if necessary."
+ (if (string-match "[\n\t\"\\]" name)
+ (concat "\""
+ (mapconcat (lambda (c)
+ (case c
+ (?\n "\\n")
+ (?\t "\\t")
+ (?\\ "\\\\")
+ (?\" "\\\"")
+ (t (char-to-string c))))
+ name "")
+ "\"")
+ name))
+
+(defun vc-git-file-type-as-string (old-perm new-perm)
+ "Return a string describing the file type based on its permissions."
+ (let* ((old-type (lsh (or old-perm 0) -9))
+ (new-type (lsh (or new-perm 0) -9))
+ (str (case new-type
+ (?\100 ;; File.
+ (case old-type
+ (?\100 nil)
+ (?\120 " (type change symlink -> file)")
+ (?\160 " (type change subproject -> file)")))
+ (?\120 ;; Symlink.
+ (case old-type
+ (?\100 " (type change file -> symlink)")
+ (?\160 " (type change subproject -> symlink)")
+ (t " (symlink)")))
+ (?\160 ;; Subproject.
+ (case old-type
+ (?\100 " (type change file -> subproject)")
+ (?\120 " (type change symlink -> subproject)")
+ (t " (subproject)")))
+ (?\110 nil) ;; Directory (internal, not a real git state).
+ (?\000 ;; Deleted or unknown.
+ (case old-type
+ (?\120 " (symlink)")
+ (?\160 " (subproject)")))
+ (t (format " (unknown type %o)" new-type)))))
+ (cond (str (propertize str 'face 'font-lock-comment-face))
+ ((eq new-type ?\110) "/")
+ (t ""))))
+
+(defun vc-git-rename-as-string (state extra)
+ "Return a string describing the copy or rename associated with INFO,
+or an empty string if none."
+ (let ((rename-state (when extra
+ (vc-git-extra-fileinfo->rename-state extra))))
+ (if rename-state
+ (propertize
+ (concat " ("
+ (if (eq rename-state 'copy) "copied from "
+ (if (eq state 'added) "renamed from "
+ "renamed to "))
+ (vc-git-escape-file-name
+ (vc-git-extra-fileinfo->orig-name extra))
+ ")")
+ 'face 'font-lock-comment-face)
+ "")))
+
+(defun vc-git-permissions-as-string (old-perm new-perm)
+ "Format a permission change as string."
+ (propertize
+ (if (or (not old-perm)
+ (not new-perm)
+ (eq 0 (logand ?\111 (logxor old-perm new-perm))))
+ " "
+ (if (eq 0 (logand ?\111 old-perm)) "+x" "-x"))
+ 'face 'font-lock-type-face))
+
+(defun vc-git-dir-printer (info)
+ "Pretty-printer for the vc-dir-fileinfo structure."
+ (let* ((isdir (vc-dir-fileinfo->directory info))
+ (state (if isdir "" (vc-dir-fileinfo->state info)))
+ (extra (vc-dir-fileinfo->extra info))
+ (old-perm (when extra (vc-git-extra-fileinfo->old-perm extra)))
+ (new-perm (when extra (vc-git-extra-fileinfo->new-perm extra))))
+ (insert
+ " "
+ (propertize (format "%c" (if (vc-dir-fileinfo->marked info) ?* ? ))
+ 'face 'font-lock-type-face)
+ " "
+ (propertize
+ (format "%-12s" state)
+ 'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
+ ((eq state 'missing) 'font-lock-warning-face)
+ (t 'font-lock-variable-name-face))
+ 'mouse-face 'highlight)
+ " " (vc-git-permissions-as-string old-perm new-perm)
+ " "
+ (propertize (vc-git-escape-file-name (vc-dir-fileinfo->name info))
+ 'face (if isdir 'font-lock-comment-delimiter-face
+ 'font-lock-function-name-face)
+ 'help-echo
+ (if isdir
+ "Directory\nVC operations can be applied to it\nmouse-3: Pop-up menu"
+ "File\nmouse-3: Pop-up menu")
+ 'keymap vc-dir-filename-mouse-map
+ 'mouse-face 'highlight)
+ (vc-git-file-type-as-string old-perm new-perm)
+ (vc-git-rename-as-string state extra))))
+
+(defun vc-git-after-dir-status-stage (stage files update-function)
+ "Process sentinel for the various dir-status stages."
+ (let (next-stage result)
+ (goto-char (point-min))
+ (case stage
+ (update-index
+ (setq next-stage (if (vc-git--empty-db-p) 'ls-files-added
+ (if files 'ls-files-up-to-date 'diff-index))))
+ (ls-files-added
+ (setq next-stage 'ls-files-unknown)
+ (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t)
+ (let ((new-perm (string-to-number (match-string 1) 8))
+ (name (match-string 2)))
+ (push (list name 'added (vc-git-create-extra-fileinfo 0 new-perm))
+ result))))
+ (ls-files-up-to-date
+ (setq next-stage 'diff-index)
+ (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t)
+ (let ((perm (string-to-number (match-string 1) 8))
+ (name (match-string 2)))
+ (push (list name 'up-to-date
+ (vc-git-create-extra-fileinfo perm perm))
+ result))))
+ (ls-files-unknown
+ (when files (setq next-stage 'ls-files-ignored))
+ (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
+ (push (list (match-string 1) 'unregistered
+ (vc-git-create-extra-fileinfo 0 0))
+ result)))
+ (ls-files-ignored
+ (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
+ (push (list (match-string 1) 'ignored
+ (vc-git-create-extra-fileinfo 0 0))
+ result)))
+ (diff-index
+ (setq next-stage 'ls-files-unknown)
+ (while (re-search-forward
+ ":\\([0-7]\\{6\\}\\) \\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\(\\([ADMUT]\\)\0\\([^\0]+\\)\\|\\([CR]\\)[0-9]*\0\\([^\0]+\\)\0\\([^\0]+\\)\\)\0"
+ nil t 1)
+ (let ((old-perm (string-to-number (match-string 1) 8))
+ (new-perm (string-to-number (match-string 2) 8))
+ (state (or (match-string 4) (match-string 6)))
+ (name (or (match-string 5) (match-string 7)))
+ (new-name (match-string 8)))
+ (if new-name ; Copy or rename.
+ (if (eq ?C (string-to-char state))
+ (push (list new-name 'added
+ (vc-git-create-extra-fileinfo old-perm new-perm
+ 'copy name))
+ result)
+ (push (list name 'removed
+ (vc-git-create-extra-fileinfo 0 0
+ 'rename new-name))
+ result)
+ (push (list new-name 'added
+ (vc-git-create-extra-fileinfo old-perm new-perm
+ 'rename name))
+ result))
+ (push (list name (vc-git--state-code state)
+ (vc-git-create-extra-fileinfo old-perm new-perm))
+ result))))))
+ (when result
+ (setq result (nreverse result))
+ (when files
+ (dolist (entry result) (setq files (delete (car entry) files)))
+ (unless files (setq next-stage nil))))
+ (when (or result (not next-stage))
+ (funcall update-function result next-stage))
+ (when next-stage
+ (vc-git-dir-status-goto-stage next-stage files update-function))))
+
+(defun vc-git-dir-status-goto-stage (stage files update-function)
+ (erase-buffer)
+ (case stage
+ (update-index
+ (if files
+ (vc-git-command (current-buffer) 'async files "add" "--refresh" "--")
+ (vc-git-command (current-buffer) 'async nil
+ "update-index" "--refresh")))
+ (ls-files-added
+ (vc-git-command (current-buffer) 'async files
+ "ls-files" "-z" "-c" "-s" "--"))
+ (ls-files-up-to-date
+ (vc-git-command (current-buffer) 'async files
+ "ls-files" "-z" "-c" "-s" "--"))
+ (ls-files-unknown
+ (vc-git-command (current-buffer) 'async files
+ "ls-files" "-z" "-o" "--directory"
+ "--no-empty-directory" "--exclude-standard" "--"))
+ (ls-files-ignored
+ (vc-git-command (current-buffer) 'async files
+ "ls-files" "-z" "-o" "-i" "--directory"
+ "--no-empty-directory" "--exclude-standard" "--"))
+ ;; --relative added in Git 1.5.5.
+ (diff-index
+ (vc-git-command (current-buffer) 'async files
+ "diff-index" "--relative" "-z" "-M" "HEAD" "--")))
+ (vc-exec-after
+ `(vc-git-after-dir-status-stage ',stage ',files ',update-function)))
+
+(defun vc-git-dir-status (dir update-function)
+ "Return a list of (FILE STATE EXTRA) entries for DIR."
+ ;; Further things that would have to be fixed later:
+ ;; - how to handle unregistered directories
+ ;; - how to support vc-dir on a subdir of the project tree
+ (vc-git-dir-status-goto-stage 'update-index nil update-function))
+
+(defun vc-git-dir-status-files (dir files default-state update-function)
+ "Return a list of (FILE STATE EXTRA) entries for FILES in DIR."
+ (vc-git-dir-status-goto-stage 'update-index files update-function))
+
+(defvar vc-git-stash-map
+ (let ((map (make-sparse-keymap)))
+ ;; Turn off vc-dir marking
+ (define-key map [mouse-2] 'ignore)
+
+ (define-key map [down-mouse-3] 'vc-git-stash-menu)
+ (define-key map "\C-k" 'vc-git-stash-delete-at-point)
+ (define-key map "=" 'vc-git-stash-show-at-point)
+ (define-key map "\C-m" 'vc-git-stash-show-at-point)
+ (define-key map "A" 'vc-git-stash-apply-at-point)
+ (define-key map "P" 'vc-git-stash-pop-at-point)
+ (define-key map "S" 'vc-git-stash-snapshot)
+ map))
+
+(defvar vc-git-stash-menu-map
+ (let ((map (make-sparse-keymap "Git Stash")))
+ (define-key map [de]
+ '(menu-item "Delete stash" vc-git-stash-delete-at-point
+ :help "Delete the current stash"))
+ (define-key map [ap]
+ '(menu-item "Apply stash" vc-git-stash-apply-at-point
+ :help "Apply the current stash and keep it in the stash list"))
+ (define-key map [po]
+ '(menu-item "Apply and remove stash (pop)" vc-git-stash-pop-at-point
+ :help "Apply the current stash and remove it"))
+ (define-key map [sh]
+ '(menu-item "Show stash" vc-git-stash-show-at-point
+ :help "Show the contents of the current stash"))
+ map))
+
+(defun vc-git-dir-extra-headers (dir)
+ (let ((str (with-output-to-string
+ (with-current-buffer standard-output
+ (vc-git--out-ok "symbolic-ref" "HEAD"))))
+ (stash (vc-git-stash-list))
+ (stash-help-echo "Use M-x vc-git-stash to create stashes.")
+ branch remote remote-url)
+ (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
+ (progn
+ (setq branch (match-string 2 str))
+ (setq remote
+ (with-output-to-string
+ (with-current-buffer standard-output
+ (vc-git--out-ok "config"
+ (concat "branch." branch ".remote")))))
+ (when (string-match "\\([^\n]+\\)" remote)
+ (setq remote (match-string 1 remote)))
+ (when remote
+ (setq remote-url
+ (with-output-to-string
+ (with-current-buffer standard-output
+ (vc-git--out-ok "config"
+ (concat "remote." remote ".url"))))))
+ (when (string-match "\\([^\n]+\\)" remote-url)
+ (setq remote-url (match-string 1 remote-url))))
+ (setq branch "not (detached HEAD)"))
+ ;; FIXME: maybe use a different face when nothing is stashed.
+ (concat
+ (propertize "Branch : " 'face 'font-lock-type-face)
+ (propertize branch
+ 'face 'font-lock-variable-name-face)
+ (when remote
+ (concat
+ "\n"
+ (propertize "Remote : " 'face 'font-lock-type-face)
+ (propertize remote-url
+ 'face 'font-lock-variable-name-face)))
+ "\n"
+ (if stash
+ (concat
+ (propertize "Stash :\n" 'face 'font-lock-type-face
+ 'help-echo stash-help-echo)
+ (mapconcat
+ (lambda (x)
+ (propertize x
+ 'face 'font-lock-variable-name-face
+ 'mouse-face 'highlight
+ 'help-echo "mouse-3: Show stash menu\nRET: Show stash\nA: Apply stash\nP: Apply and remove stash (pop)\nC-k: Delete stash"
+ 'keymap vc-git-stash-map))
+ stash "\n"))
+ (concat
+ (propertize "Stash : " 'face 'font-lock-type-face
+ 'help-echo stash-help-echo)
+ (propertize "Nothing stashed"
+ 'help-echo stash-help-echo
+ 'face 'font-lock-variable-name-face))))))
+
+;;; STATE-CHANGING FUNCTIONS
+
+(defun vc-git-create-repo ()
+ "Create a new Git repository."
+ (vc-git-command nil 0 nil "init"))
+
+(defun vc-git-register (files &optional rev comment)
+ "Register FILES into the git version-control system."
+ (let (flist dlist)
+ (dolist (crt files)
+ (if (file-directory-p crt)
+ (push crt dlist)
+ (push crt flist)))
+ (when flist
+ (vc-git-command nil 0 flist "update-index" "--add" "--"))
+ (when dlist
+ (vc-git-command nil 0 dlist "add"))))
+
+(defalias 'vc-git-responsible-p 'vc-git-root)
+
+(defun vc-git-unregister (file)
+ (vc-git-command nil 0 file "rm" "-f" "--cached" "--"))
+
+(declare-function log-edit-extract-headers "log-edit" (headers string))
+
+(defun vc-git-checkin (files rev comment)
+ (let ((coding-system-for-write vc-git-commits-coding-system))
+ (apply 'vc-git-command nil 0 files
+ (nconc (list "commit" "-m")
+ (log-edit-extract-headers '(("Author" . "--author")
+ ("Date" . "--date"))
+ comment)
+ (list "--only" "--")))))
+
+(defun vc-git-find-revision (file rev buffer)
+ (let* (process-file-side-effects
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (fullname (substring
+ (vc-git--run-command-string
+ file "ls-files" "-z" "--full-name" "--")
+ 0 -1)))
+ (vc-git-command
+ buffer 0
+ (concat (if rev rev "HEAD") ":" fullname) "cat-file" "blob")))
+
+(defun vc-git-checkout (file &optional editable rev)
+ (vc-git-command nil 0 file "checkout" (or rev "HEAD")))
+
+(defun vc-git-revert (file &optional contents-done)
+ "Revert FILE to the version stored in the git repository."
+ (if contents-done
+ (vc-git-command nil 0 file "update-index" "--")
+ (vc-git-command nil 0 file "reset" "-q" "--")
+ (vc-git-command nil nil file "checkout" "-q" "--")))
+
+;;; HISTORY FUNCTIONS
+
+(defun vc-git-print-log (files buffer &optional shortlog start-revision limit)
+ "Get change log associated with FILES.
+Note that using SHORTLOG requires at least Git version 1.5.6,
+for the --graph option."
+ (let ((coding-system-for-read vc-git-commits-coding-system))
+ ;; `vc-do-command' creates the buffer, but we need it before running
+ ;; the command.
+ (vc-setup-buffer buffer)
+ ;; If the buffer exists from a previous invocation it might be
+ ;; read-only.
+ (let ((inhibit-read-only t))
+ (with-current-buffer
+ buffer
+ (apply 'vc-git-command buffer
+ 'async files
+ (append
+ '("log" "--no-color")
+ (when shortlog
+ '("--graph" "--decorate" "--date=short"
+ "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"))
+ (when limit (list "-n" (format "%s" limit)))
+ (when start-revision (list start-revision))
+ '("--")))))))
+
+(defun vc-git-log-outgoing (buffer remote-location)
+ (interactive)
+ (vc-git-command
+ buffer 0 nil
+ "log"
+ "--no-color" "--graph" "--decorate" "--date=short"
+ "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"
+ (concat (if (string= remote-location "")
+ "@{upstream}"
+ remote-location)
+ "..HEAD")))
+
+(defun vc-git-log-incoming (buffer remote-location)
+ (interactive)
+ (vc-git-command nil 0 nil "fetch")
+ (vc-git-command
+ buffer 0 nil
+ "log"
+ "--no-color" "--graph" "--decorate" "--date=short"
+ "--pretty=tformat:%d%h %ad %s" "--abbrev-commit"
+ (concat "HEAD.." (if (string= remote-location "")
+ "@{upstream}"
+ remote-location))))
+
+(defvar log-view-message-re)
+(defvar log-view-file-re)
+(defvar log-view-font-lock-keywords)
+(defvar log-view-per-file-logs)
+
+(define-derived-mode vc-git-log-view-mode log-view-mode "Git-Log-View"
+ (require 'add-log) ;; We need the faces add-log.
+ ;; Don't have file markers, so use impossible regexp.
+ (set (make-local-variable 'log-view-file-re) "\\`a\\`")
+ (set (make-local-variable 'log-view-per-file-logs) nil)
+ (set (make-local-variable 'log-view-message-re)
+ (if (not (eq vc-log-view-type 'long))
+ "^\\(?:[*/\\| ]+ \\)?\\(?: ([^)]+)\\)?\\([0-9a-z]+\\) \\([-a-z0-9]+\\) \\(.*\\)"
+ "^commit *\\([0-9a-z]+\\)"))
+ (set (make-local-variable 'log-view-font-lock-keywords)
+ (if (not (eq vc-log-view-type 'long))
+ '(
+ ;; Same as log-view-message-re, except that we don't
+ ;; want the shy group for the tag name.
+ ("^\\(?:[*/\\| ]+ \\)?\\( ([^)]+)\\)?\\([0-9a-z]+\\) \\([-a-z0-9]+\\) \\(.*\\)"
+ (1 'highlight nil lax)
+ (2 'change-log-acknowledgement)
+ (3 'change-log-date)))
+ (append
+ `((,log-view-message-re (1 'change-log-acknowledgement)))
+ ;; Handle the case:
+ ;; user: foo@bar
+ '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
+ (1 'change-log-email))
+ ;; Handle the case:
+ ;; user: FirstName LastName <foo@bar>
+ ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
+ (1 'change-log-name)
+ (2 'change-log-email))
+ ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
+ (1 'change-log-name))
+ ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
+ (1 'change-log-name)
+ (2 'change-log-email))
+ ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)"
+ (1 'change-log-acknowledgement)
+ (2 'change-log-acknowledgement))
+ ("^Date: \\(.+\\)" (1 'change-log-date))
+ ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
+
+
+(defun vc-git-show-log-entry (revision)
+ "Move to the log entry for REVISION.
+REVISION may have the form BRANCH, BRANCH~N,
+or BRANCH^ (where \"^\" can be repeated)."
+ (goto-char (point-min))
+ (prog1
+ (when revision
+ (search-forward
+ (format "\ncommit %s" revision) nil t
+ (cond ((string-match "~\\([0-9]\\)\\'" revision)
+ (1+ (string-to-number (match-string 1 revision))))
+ ((string-match "\\^+\\'" revision)
+ (1+ (length (match-string 0 revision))))
+ (t nil))))
+ (beginning-of-line)))
+
+(defun vc-git-diff (files &optional rev1 rev2 buffer)
+ "Get a difference report using Git between two revisions of FILES."
+ (let (process-file-side-effects)
+ (apply #'vc-git-command (or buffer "*vc-diff*") 1 files
+ (if (and rev1 rev2) "diff-tree" "diff-index")
+ "--exit-code"
+ (append (vc-switches 'git 'diff)
+ (list "-p" (or rev1 "HEAD") rev2 "--")))))
+
+(defun vc-git-revision-table (files)
+ ;; What about `files'?!? --Stef
+ (let (process-file-side-effects
+ (table (list "HEAD")))
+ (with-temp-buffer
+ (vc-git-command t nil nil "for-each-ref" "--format=%(refname)")
+ (goto-char (point-min))
+ (while (re-search-forward "^refs/\\(heads\\|tags\\|remotes\\)/\\(.*\\)$"
+ nil t)
+ (push (match-string 2) table)))
+ table))
+
+(defun vc-git-revision-completion-table (files)
+ (lexical-let ((files files)
+ table)
+ (setq table (lazy-completion-table
+ table (lambda () (vc-git-revision-table files))))
+ table))
+
+(defun vc-git-annotate-command (file buf &optional rev)
+ (let ((name (file-relative-name file)))
+ (vc-git-command buf 'async name "blame" "--date=iso" "-C" "-C" rev)))
+
+(declare-function vc-annotate-convert-time "vc-annotate" (time))
+
+(defun vc-git-annotate-time ()
+ (and (re-search-forward "[0-9a-f]+[^()]+(.* \\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) \\([-+0-9]+\\) +[0-9]+) " nil t)
+ (vc-annotate-convert-time
+ (apply #'encode-time (mapcar (lambda (match)
+ (string-to-number (match-string match)))
+ '(6 5 4 3 2 1 7))))))
+
+(defun vc-git-annotate-extract-revision-at-line ()
+ (save-excursion
+ (move-beginning-of-line 1)
+ (when (looking-at "\\([0-9a-f^][0-9a-f]+\\) \\(\\([^(]+\\) \\)?")
+ (let ((revision (match-string-no-properties 1)))
+ (if (match-beginning 2)
+ (cons revision (expand-file-name (match-string-no-properties 3)
+ (vc-git-root default-directory)))
+ revision)))))
+
+;;; TAG SYSTEM
+
+(defun vc-git-create-tag (dir name branchp)
+ (let ((default-directory dir))
+ (and (vc-git-command nil 0 nil "update-index" "--refresh")
+ (if branchp
+ (vc-git-command nil 0 nil "checkout" "-b" name)
+ (vc-git-command nil 0 nil "tag" name)))))
+
+(defun vc-git-retrieve-tag (dir name update)
+ (let ((default-directory dir))
+ (vc-git-command nil 0 nil "checkout" name)
+ ;; FIXME: update buffers if `update' is true
+ ))
+
+
+;;; MISCELLANEOUS
+
+(defun vc-git-previous-revision (file rev)
+ "Git-specific version of `vc-previous-revision'."
+ (if file
+ (let* ((default-directory (file-name-directory (expand-file-name file)))
+ (file (file-name-nondirectory file))
+ (prev-rev (with-temp-buffer
+ (and
+ (vc-git--out-ok "rev-list" "-2" rev "--" file)
+ (goto-char (point-max))
+ (bolp)
+ (zerop (forward-line -1))
+ (not (bobp))
+ (buffer-substring-no-properties
+ (point)
+ (1- (point-max)))))))
+ (or (vc-git-symbolic-commit prev-rev) prev-rev))
+ (with-temp-buffer
+ (and
+ (vc-git--out-ok "rev-parse" (concat rev "^"))
+ (buffer-substring-no-properties (point-min) (+ (point-min) 40))))))
+
+(defun vc-git-next-revision (file rev)
+ "Git-specific version of `vc-next-revision'."
+ (let* ((default-directory (file-name-directory
+ (expand-file-name file)))
+ (file (file-name-nondirectory file))
+ (current-rev
+ (with-temp-buffer
+ (and
+ (vc-git--out-ok "rev-list" "-1" rev "--" file)
+ (goto-char (point-max))
+ (bolp)
+ (zerop (forward-line -1))
+ (bobp)
+ (buffer-substring-no-properties
+ (point)
+ (1- (point-max))))))
+ (next-rev
+ (and current-rev
+ (with-temp-buffer
+ (and
+ (vc-git--out-ok "rev-list" "HEAD" "--" file)
+ (goto-char (point-min))
+ (search-forward current-rev nil t)
+ (zerop (forward-line -1))
+ (buffer-substring-no-properties
+ (point)
+ (progn (forward-line 1) (1- (point)))))))))
+ (or (vc-git-symbolic-commit next-rev) next-rev)))
+
+(defun vc-git-delete-file (file)
+ (vc-git-command nil 0 file "rm" "-f" "--"))
+
+(defun vc-git-rename-file (old new)
+ (vc-git-command nil 0 (list old new) "mv" "-f" "--"))
+
+(defvar vc-git-extra-menu-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [git-grep]
+ '(menu-item "Git grep..." vc-git-grep
+ :help "Run the `git grep' command"))
+ (define-key map [git-sn]
+ '(menu-item "Stash a snapshot" vc-git-stash-snapshot
+ :help "Stash the current state of the tree and keep the current state"))
+ (define-key map [git-st]
+ '(menu-item "Create Stash..." vc-git-stash
+ :help "Stash away changes"))
+ (define-key map [git-ss]
+ '(menu-item "Show Stash..." vc-git-stash-show
+ :help "Show stash contents"))
+ map))
+
+(defun vc-git-extra-menu () vc-git-extra-menu-map)
+
+(defun vc-git-extra-status-menu () vc-git-extra-menu-map)
+
+(defun vc-git-root (file)
+ (vc-find-root file ".git"))
+
+;; Derived from `lgrep'.
+(defun vc-git-grep (regexp &optional files dir)
+ "Run git grep, searching for REGEXP in FILES in directory DIR.
+The search is limited to file names matching shell pattern FILES.
+FILES may use abbreviations defined in `grep-files-aliases', e.g.
+entering `ch' is equivalent to `*.[ch]'.
+
+With \\[universal-argument] prefix, you can edit the constructed shell command line
+before it is executed.
+With two \\[universal-argument] prefixes, directly edit and run `grep-command'.
+
+Collect output in a buffer. While git grep runs asynchronously, you
+can use \\[next-error] (M-x next-error), or \\<grep-mode-map>\\[compile-goto-error] \
+in the grep output buffer,
+to go to the lines where grep found matches.
+
+This command shares argument histories with \\[rgrep] and \\[grep]."
+ (interactive
+ (progn
+ (grep-compute-defaults)
+ (cond
+ ((equal current-prefix-arg '(16))
+ (list (read-from-minibuffer "Run: " "git grep"
+ nil nil 'grep-history)
+ nil))
+ (t (let* ((regexp (grep-read-regexp))
+ (files (grep-read-files regexp))
+ (dir (read-directory-name "In directory: "
+ nil default-directory t)))
+ (list regexp files dir))))))
+ (require 'grep)
+ (when (and (stringp regexp) (> (length regexp) 0))
+ (let ((command regexp))
+ (if (null files)
+ (if (string= command "git grep")
+ (setq command nil))
+ (setq dir (file-name-as-directory (expand-file-name dir)))
+ (setq command
+ (grep-expand-template "git grep -n -e <R> -- <F>" regexp files))
+ (when command
+ (if (equal current-prefix-arg '(4))
+ (setq command
+ (read-from-minibuffer "Confirm: "
+ command nil nil 'grep-history))
+ (add-to-history 'grep-history command))))
+ (when command
+ (let ((default-directory dir)
+ (compilation-environment '("PAGER=")))
+ ;; Setting process-setup-function makes exit-message-function work
+ ;; even when async processes aren't supported.
+ (compilation-start command 'grep-mode))
+ (if (eq next-error-last-buffer (current-buffer))
+ (setq default-directory dir))))))
+
+(defun vc-git-stash (name)
+ "Create a stash."
+ (interactive "sStash name: ")
+ (let ((root (vc-git-root default-directory)))
+ (when root
+ (vc-git--call nil "stash" "save" name)
+ (vc-resynch-buffer root t t))))
+
+(defun vc-git-stash-show (name)
+ "Show the contents of stash NAME."
+ (interactive "sStash name: ")
+ (vc-setup-buffer "*vc-git-stash*")
+ (vc-git-command "*vc-git-stash*" 'async nil "stash" "show" "-p" name)
+ (set-buffer "*vc-git-stash*")
+ (diff-mode)
+ (setq buffer-read-only t)
+ (pop-to-buffer (current-buffer)))
+
+(defun vc-git-stash-apply (name)
+ "Apply stash NAME."
+ (interactive "sApply stash: ")
+ (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" name)
+ (vc-resynch-buffer (vc-git-root default-directory) t t))
+
+(defun vc-git-stash-pop (name)
+ "Pop stash NAME."
+ (interactive "sPop stash: ")
+ (vc-git-command "*vc-git-stash*" 0 nil "stash" "pop" "-q" name)
+ (vc-resynch-buffer (vc-git-root default-directory) t t))
+
+(defun vc-git-stash-snapshot ()
+ "Create a stash with the current tree state."
+ (interactive)
+ (vc-git--call nil "stash" "save"
+ (let ((ct (current-time)))
+ (concat
+ (format-time-string "Snapshot on %Y-%m-%d" ct)
+ (format-time-string " at %H:%M" ct))))
+ (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" "stash@{0}")
+ (vc-resynch-buffer (vc-git-root default-directory) t t))
+
+(defun vc-git-stash-list ()
+ (delete
+ ""
+ (split-string
+ (replace-regexp-in-string
+ "^stash@" " " (vc-git--run-command-string nil "stash" "list"))
+ "\n")))
+
+(defun vc-git-stash-get-at-point (point)
+ (save-excursion
+ (goto-char point)
+ (beginning-of-line)
+ (if (looking-at "^ +\\({[0-9]+}\\):")
+ (match-string 1)
+ (error "Cannot find stash at point"))))
+
+(defun vc-git-stash-delete-at-point ()
+ (interactive)
+ (let ((stash (vc-git-stash-get-at-point (point))))
+ (when (y-or-n-p (format "Remove stash %s ? " stash))
+ (vc-git--run-command-string nil "stash" "drop" (format "stash@%s" stash))
+ (vc-dir-refresh))))
+
+(defun vc-git-stash-show-at-point ()
+ (interactive)
+ (vc-git-stash-show (format "stash@%s" (vc-git-stash-get-at-point (point)))))
+
+(defun vc-git-stash-apply-at-point ()
+ (interactive)
+ (vc-git-stash-apply (format "stash@%s" (vc-git-stash-get-at-point (point)))))
+
+(defun vc-git-stash-pop-at-point ()
+ (interactive)
+ (vc-git-stash-pop (format "stash@%s" (vc-git-stash-get-at-point (point)))))
+
+(defun vc-git-stash-menu (e)
+ (interactive "e")
+ (vc-dir-at-event e (popup-menu vc-git-stash-menu-map e)))
+
+\f
+;;; Internal commands
+
+(defun vc-git-command (buffer okstatus file-or-list &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-git.el.
+The difference to vc-do-command is that this function always invokes `git'."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus "git" file-or-list flags))
+
+(defun vc-git--empty-db-p ()
+ "Check if the git db is empty (no commit done yet)."
+ (let (process-file-side-effects)
+ (not (eq 0 (vc-git--call nil "rev-parse" "--verify" "HEAD")))))
+
+(defun vc-git--call (buffer command &rest args)
+ ;; We don't need to care the arguments. If there is a file name, it
+ ;; is always a relative one. This works also for remote
+ ;; directories.
+ (apply 'process-file "git" nil buffer nil command args))
+
+(defun vc-git--out-ok (command &rest args)
+ (zerop (apply 'vc-git--call '(t nil) command args)))
+
+(defun vc-git--run-command-string (file &rest args)
+ "Run a git command on FILE and return its output as string.
+FILE can be nil."
+ (let* ((ok t)
+ (str (with-output-to-string
+ (with-current-buffer standard-output
+ (unless (apply 'vc-git--out-ok
+ (if file
+ (append args (list (file-relative-name
+ file)))
+ args))
+ (setq ok nil))))))
+ (and ok str)))
+
+(defun vc-git-symbolic-commit (commit)
+ "Translate COMMIT string into symbolic form.
+Returns nil if not possible."
+ (and commit
+ (let ((name (with-temp-buffer
+ (and
+ (vc-git--out-ok "name-rev" "--name-only" commit)
+ (goto-char (point-min))
+ (= (forward-line 2) 1)
+ (bolp)
+ (buffer-substring-no-properties (point-min)
+ (1- (point-max)))))))
+ (and name (not (string= name "undefined")) name))))
+
+(provide 'vc-git)
+
+;; arch-tag: bd10664a-0e5b-48f5-a877-6c17b135be12
+;;; vc-git.el ends here
--- /dev/null
+;;; vc-hg.el --- VC backend for the mercurial version control system
+
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Ivan Kanis
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is a mercurial version control backend
+
+;;; Thanks:
+
+;;; Bugs:
+
+;;; Installation:
+
+;;; Todo:
+
+;; 1) Implement the rest of the vc interface. See the comment at the
+;; beginning of vc.el. The current status is:
+
+;; FUNCTION NAME STATUS
+;; BACKEND PROPERTIES
+;; * revision-granularity OK
+;; STATE-QUERYING FUNCTIONS
+;; * registered (file) OK
+;; * state (file) OK
+;; - state-heuristic (file) NOT NEEDED
+;; - dir-status (dir update-function) OK
+;; - dir-status-files (dir files ds uf) OK
+;; - dir-extra-headers (dir) OK
+;; - dir-printer (fileinfo) OK
+;; * working-revision (file) OK
+;; - latest-on-branch-p (file) ??
+;; * checkout-model (files) OK
+;; - workfile-unchanged-p (file) OK
+;; - mode-line-string (file) NOT NEEDED
+;; STATE-CHANGING FUNCTIONS
+;; * register (files &optional rev comment) OK
+;; * create-repo () OK
+;; - init-revision () NOT NEEDED
+;; - responsible-p (file) OK
+;; - could-register (file) OK
+;; - receive-file (file rev) ?? PROBABLY NOT NEEDED
+;; - unregister (file) COMMENTED OUT, MAY BE INCORRECT
+;; * checkin (files rev comment) OK
+;; * find-revision (file rev buffer) OK
+;; * checkout (file &optional editable rev) OK
+;; * revert (file &optional contents-done) OK
+;; - rollback (files) ?? PROBABLY NOT NEEDED
+;; - merge (file rev1 rev2) NEEDED
+;; - merge-news (file) NEEDED
+;; - steal-lock (file &optional revision) NOT NEEDED
+;; HISTORY FUNCTIONS
+;; * print-log (files buffer &optional shortlog start-revision limit) OK
+;; - log-view-mode () OK
+;; - show-log-entry (revision) NOT NEEDED, DEFAULT IS GOOD
+;; - comment-history (file) NOT NEEDED
+;; - update-changelog (files) NOT NEEDED
+;; * diff (files &optional rev1 rev2 buffer) OK
+;; - revision-completion-table (files) OK?
+;; - annotate-command (file buf &optional rev) OK
+;; - annotate-time () OK
+;; - annotate-current-time () NOT NEEDED
+;; - annotate-extract-revision-at-line () OK
+;; TAG SYSTEM
+;; - create-tag (dir name branchp) NEEDED
+;; - retrieve-tag (dir name update) NEEDED
+;; MISCELLANEOUS
+;; - make-version-backups-p (file) ??
+;; - repository-hostname (dirname) ??
+;; - previous-revision (file rev) OK
+;; - next-revision (file rev) OK
+;; - check-headers () ??
+;; - clear-headers () ??
+;; - delete-file (file) TEST IT
+;; - rename-file (old new) OK
+;; - find-file-hook () PROBABLY NOT NEEDED
+
+;; 2) Implement Stefan Monnier's advice:
+;; vc-hg-registered and vc-hg-state
+;; Both of those functions should be super extra careful to fail gracefully in
+;; unexpected circumstances. The reason this is important is that any error
+;; there will prevent the user from even looking at the file :-(
+;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
+;; mercurial's control and extracting the current revision should be done
+;; without even using `hg' (this way even if you don't have `hg' installed,
+;; Emacs is able to tell you this file is under mercurial's control).
+
+;;; History:
+;;
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl)
+ (require 'vc)
+ (require 'vc-dir))
+
+;;; Customization options
+
+(defcustom vc-hg-global-switches nil
+ "Global switches to pass to any Hg command."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "22.2"
+ :group 'vc)
+
+(defcustom vc-hg-diff-switches t ; Hg doesn't support common args like -u
+ "String or list of strings specifying switches for Hg diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "23.1"
+ :group 'vc)
+
+\f
+;;; Properties of the backend
+
+(defun vc-hg-revision-granularity () 'repository)
+(defun vc-hg-checkout-model (files) 'implicit)
+
+;;; State querying functions
+
+;;;###autoload (defun vc-hg-registered (file)
+;;;###autoload "Return non-nil if FILE is registered with hg."
+;;;###autoload (if (vc-find-root file ".hg") ; short cut
+;;;###autoload (progn
+;;;###autoload (load "vc-hg")
+;;;###autoload (vc-hg-registered file))))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-registered (file)
+ "Return non-nil if FILE is registered with hg."
+ (when (vc-hg-root file) ; short cut
+ (let ((state (vc-hg-state file))) ; expensive
+ (and state (not (memq state '(ignored unregistered)))))))
+
+(defun vc-hg-state (file)
+ "Hg-specific version of `vc-state'."
+ (let*
+ ((status nil)
+ (default-directory (file-name-directory file))
+ (out
+ (with-output-to-string
+ (with-current-buffer
+ standard-output
+ (setq status
+ (condition-case nil
+ ;; Ignore all errors.
+ (let ((process-environment
+ ;; Avoid localization of messages so we
+ ;; can parse the output.
+ (append (list "TERM=dumb" "LANGUAGE=C" "HGRCPATH=")
+ process-environment)))
+ (process-file
+ "hg" nil t nil
+ "status" "-A" (file-relative-name file)))
+ ;; Some problem happened. E.g. We can't find an `hg'
+ ;; executable.
+ (error nil)))))))
+ (when (eq 0 status)
+ (when (null (string-match ".*: No such file or directory$" out))
+ (let ((state (aref out 0)))
+ (cond
+ ((eq state ?=) 'up-to-date)
+ ((eq state ?A) 'added)
+ ((eq state ?M) 'edited)
+ ((eq state ?I) 'ignored)
+ ((eq state ?R) 'removed)
+ ((eq state ?!) 'missing)
+ ((eq state ??) 'unregistered)
+ ((eq state ?C) 'up-to-date) ;; Older mercurials use this
+ (t 'up-to-date)))))))
+
+(defun vc-hg-working-revision (file)
+ "Hg-specific version of `vc-working-revision'."
+ (let*
+ ((status nil)
+ (default-directory (file-name-directory file))
+ ;; Avoid localization of messages so we can parse the output.
+ (avoid-local-env (append (list "TERM=dumb" "LANGUAGE=C" "HGRCPATH=")
+ process-environment))
+ (out
+ (with-output-to-string
+ (with-current-buffer
+ standard-output
+ (setq status
+ (condition-case nil
+ (let ((process-environment avoid-local-env))
+ ;; Ignore all errors.
+ (process-file
+ "hg" nil t nil
+ "parents" "--template" "{rev}" (file-relative-name file)))
+ ;; Some problem happened. E.g. We can't find an `hg'
+ ;; executable.
+ (error nil)))))))
+ (if (eq 0 status)
+ out
+ ;; Check if the file is in the 'added state, the above hg
+ ;; command does not distinguish between 'added and 'unregistered.
+ (setq status
+ (condition-case nil
+ (let ((process-environment avoid-local-env))
+ (process-file
+ "hg" nil nil nil
+ ;; We use "log" here, if there's a faster command
+ ;; that returns true for an 'added file and false
+ ;; for an 'unregistered one, we could use that.
+ "log" "-l1" (file-relative-name file)))
+ ;; Some problem happened. E.g. We can't find an `hg'
+ ;; executable.
+ (error nil)))
+ (when (eq 0 status) "0"))))
+
+;;; History functions
+
+(defcustom vc-hg-log-switches nil
+ "String or list of strings specifying switches for hg log under VC."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :group 'vc-hg)
+
+(defun vc-hg-print-log (files buffer &optional shortlog start-revision limit)
+ "Get change log associated with FILES."
+ ;; `vc-do-command' creates the buffer, but we need it before running
+ ;; the command.
+ (vc-setup-buffer buffer)
+ ;; If the buffer exists from a previous invocation it might be
+ ;; read-only.
+ (let ((inhibit-read-only t))
+ (with-current-buffer
+ buffer
+ (apply 'vc-hg-command buffer 0 files "log"
+ (nconc
+ (when start-revision (list (format "-r%s:" start-revision)))
+ (when limit (list "-l" (format "%s" limit)))
+ (when shortlog (list "--style" "compact"))
+ vc-hg-log-switches)))))
+
+(defvar log-view-message-re)
+(defvar log-view-file-re)
+(defvar log-view-font-lock-keywords)
+(defvar log-view-per-file-logs)
+
+(define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
+ (require 'add-log) ;; we need the add-log faces
+ (set (make-local-variable 'log-view-file-re) "\\`a\\`")
+ (set (make-local-variable 'log-view-per-file-logs) nil)
+ (set (make-local-variable 'log-view-message-re)
+ (if (eq vc-log-view-type 'short)
+ "^\\([0-9]+\\)\\(\\[.*\\]\\)? +\\([0-9a-z]\\{12\\}\\) +\\(\\(?:[0-9]+\\)-\\(?:[0-9]+\\)-\\(?:[0-9]+\\) \\(?:[0-9]+\\):\\(?:[0-9]+\\) \\(?:[-+0-9]+\\)\\) +\\(.*\\)$"
+ "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
+ (set (make-local-variable 'log-view-font-lock-keywords)
+ (if (eq vc-log-view-type 'short)
+ (append `((,log-view-message-re
+ (1 'log-view-message-face)
+ (2 'highlight nil lax)
+ (3 'log-view-message-face)
+ (4 'change-log-date)
+ (5 'change-log-name))))
+ (append
+ log-view-font-lock-keywords
+ '(
+ ;; Handle the case:
+ ;; user: FirstName LastName <foo@bar>
+ ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
+ (1 'change-log-name)
+ (2 'change-log-email))
+ ;; Handle the cases:
+ ;; user: foo@bar
+ ;; and
+ ;; user: foo
+ ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
+ (1 'change-log-email))
+ ("^date: \\(.+\\)" (1 'change-log-date))
+ ("^tag: +\\([^ ]+\\)$" (1 'highlight))
+ ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
+
+(defun vc-hg-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using hg between two revisions of FILES."
+ (let* ((firstfile (car files))
+ (working (and firstfile (vc-working-revision firstfile))))
+ (when (and (equal oldvers working) (not newvers))
+ (setq oldvers nil))
+ (when (and (not oldvers) newvers)
+ (setq oldvers working))
+ (apply #'vc-hg-command (or buffer "*vc-diff*") nil files "diff"
+ (append
+ (vc-switches 'hg 'diff)
+ (when oldvers
+ (if newvers
+ (list "-r" oldvers "-r" newvers)
+ (list "-r" oldvers)))))))
+
+(defun vc-hg-revision-table (files)
+ (let ((default-directory (file-name-directory (car files))))
+ (with-temp-buffer
+ (vc-hg-command t nil files "log" "--template" "{rev} ")
+ (split-string
+ (buffer-substring-no-properties (point-min) (point-max))))))
+
+;; Modeled after the similar function in vc-cvs.el
+(defun vc-hg-revision-completion-table (files)
+ (lexical-let ((files files)
+ table)
+ (setq table (lazy-completion-table
+ table (lambda () (vc-hg-revision-table files))))
+ table))
+
+(defun vc-hg-annotate-command (file buffer &optional revision)
+ "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
+Optional arg REVISION is a revision to annotate from."
+ (vc-hg-command buffer 0 file "annotate" "-d" "-n" "--follow"
+ (when revision (concat "-r" revision))))
+
+(declare-function vc-annotate-convert-time "vc-annotate" (time))
+
+;; The format for one line output by "hg annotate -d -n" looks like this:
+;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
+;; i.e: VERSION_NUMBER DATE: CONTENTS
+;; If the user has set the "--follow" option, the output looks like:
+;;215 Wed Jun 20 21:22:58 2007 -0700 foo.c: CONTENTS
+;; i.e. VERSION_NUMBER DATE FILENAME: CONTENTS
+(defconst vc-hg-annotate-re
+ "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\)\\(?:\\(: \\)\\|\\(?: +\\(.+\\): \\)\\)")
+
+(defun vc-hg-annotate-time ()
+ (when (looking-at vc-hg-annotate-re)
+ (goto-char (match-end 0))
+ (vc-annotate-convert-time
+ (date-to-time (match-string-no-properties 2)))))
+
+(defun vc-hg-annotate-extract-revision-at-line ()
+ (save-excursion
+ (beginning-of-line)
+ (when (looking-at vc-hg-annotate-re)
+ (if (match-beginning 3)
+ (match-string-no-properties 1)
+ (cons (match-string-no-properties 1)
+ (expand-file-name (match-string-no-properties 4)
+ (vc-hg-root default-directory)))))))
+
+(defun vc-hg-previous-revision (file rev)
+ (let ((newrev (1- (string-to-number rev))))
+ (when (>= newrev 0)
+ (number-to-string newrev))))
+
+(defun vc-hg-next-revision (file rev)
+ (let ((newrev (1+ (string-to-number rev)))
+ (tip-revision
+ (with-temp-buffer
+ (vc-hg-command t 0 nil "tip")
+ (goto-char (point-min))
+ (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
+ (string-to-number (match-string-no-properties 1)))))
+ ;; We don't want to exceed the maximum possible revision number, ie
+ ;; the tip revision.
+ (when (<= newrev tip-revision)
+ (number-to-string newrev))))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-delete-file (file)
+ "Delete FILE and delete it in the hg repository."
+ (condition-case ()
+ (delete-file file)
+ (file-error nil))
+ (vc-hg-command nil 0 file "remove" "--after" "--force"))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-rename-file (old new)
+ "Rename file from OLD to NEW using `hg mv'."
+ (vc-hg-command nil 0 new "mv" old))
+
+(defun vc-hg-register (files &optional rev comment)
+ "Register FILES under hg.
+REV is ignored.
+COMMENT is ignored."
+ (vc-hg-command nil 0 files "add"))
+
+(defun vc-hg-create-repo ()
+ "Create a new Mercurial repository."
+ (vc-hg-command nil 0 nil "init"))
+
+(defalias 'vc-hg-responsible-p 'vc-hg-root)
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-could-register (file)
+ "Return non-nil if FILE could be registered under hg."
+ (and (vc-hg-responsible-p file) ; shortcut
+ (condition-case ()
+ (with-temp-buffer
+ (vc-hg-command t nil file "add" "--dry-run"))
+ ;; The command succeeds with no output if file is
+ ;; registered.
+ (error))))
+
+;; FIXME: This would remove the file. Is that correct?
+;; (defun vc-hg-unregister (file)
+;; "Unregister FILE from hg."
+;; (vc-hg-command nil nil file "remove"))
+
+(declare-function log-edit-extract-headers "log-edit" (headers string))
+
+(defun vc-hg-checkin (files rev comment)
+ "Hg-specific version of `vc-backend-checkin'.
+REV is ignored."
+ (apply 'vc-hg-command nil 0 files
+ (nconc (list "commit" "-m")
+ (log-edit-extract-headers '(("Author" . "--user")
+ ("Date" . "--date"))
+ comment))))
+
+(defun vc-hg-find-revision (file rev buffer)
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (if rev
+ (vc-hg-command buffer 0 file "cat" "-r" rev)
+ (vc-hg-command buffer 0 file "cat"))))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-checkout (file &optional editable rev)
+ "Retrieve a revision of FILE.
+EDITABLE is ignored.
+REV is the revision to check out into WORKFILE."
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (with-current-buffer (or (get-file-buffer file) (current-buffer))
+ (if rev
+ (vc-hg-command t 0 file "cat" "-r" rev)
+ (vc-hg-command t 0 file "cat")))))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-workfile-unchanged-p (file)
+ (eq 'up-to-date (vc-hg-state file)))
+
+;; Modeled after the similar function in vc-bzr.el
+(defun vc-hg-revert (file &optional contents-done)
+ (unless contents-done
+ (with-temp-buffer (vc-hg-command t 0 file "revert"))))
+
+;;; Hg specific functionality.
+
+(defvar vc-hg-extra-menu-map
+ (let ((map (make-sparse-keymap)))
+ map))
+
+(defun vc-hg-extra-menu () vc-hg-extra-menu-map)
+
+(defun vc-hg-extra-status-menu () vc-hg-extra-menu-map)
+
+(defvar log-view-vc-backend)
+
+(defstruct (vc-hg-extra-fileinfo
+ (:copier nil)
+ (:constructor vc-hg-create-extra-fileinfo (rename-state extra-name))
+ (:conc-name vc-hg-extra-fileinfo->))
+ rename-state ;; rename or copy state
+ extra-name) ;; original name for copies and rename targets, new name for
+
+(declare-function vc-default-dir-printer "vc-dir" (backend fileentry))
+
+(defun vc-hg-dir-printer (info)
+ "Pretty-printer for the vc-dir-fileinfo structure."
+ (let ((extra (vc-dir-fileinfo->extra info)))
+ (vc-default-dir-printer 'Hg info)
+ (when extra
+ (insert (propertize
+ (format " (%s %s)"
+ (case (vc-hg-extra-fileinfo->rename-state extra)
+ ('copied "copied from")
+ ('renamed-from "renamed from")
+ ('renamed-to "renamed to"))
+ (vc-hg-extra-fileinfo->extra-name extra))
+ 'face 'font-lock-comment-face)))))
+
+(defun vc-hg-after-dir-status (update-function)
+ (let ((status-char nil)
+ (file nil)
+ (translation '((?= . up-to-date)
+ (?C . up-to-date)
+ (?A . added)
+ (?R . removed)
+ (?M . edited)
+ (?I . ignored)
+ (?! . missing)
+ (? . copy-rename-line)
+ (?? . unregistered)))
+ (translated nil)
+ (result nil)
+ (last-added nil)
+ (last-line-copy nil))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq translated (cdr (assoc (char-after) translation)))
+ (setq file
+ (buffer-substring-no-properties (+ (point) 2)
+ (line-end-position)))
+ (cond ((not translated)
+ (setq last-line-copy nil))
+ ((eq translated 'up-to-date)
+ (setq last-line-copy nil))
+ ((eq translated 'copy-rename-line)
+ ;; For copied files the output looks like this:
+ ;; A COPIED_FILE_NAME
+ ;; ORIGINAL_FILE_NAME
+ (setf (nth 2 last-added)
+ (vc-hg-create-extra-fileinfo 'copied file))
+ (setq last-line-copy t))
+ ((and last-line-copy (eq translated 'removed))
+ ;; For renamed files the output looks like this:
+ ;; A NEW_FILE_NAME
+ ;; ORIGINAL_FILE_NAME
+ ;; R ORIGINAL_FILE_NAME
+ ;; We need to adjust the previous entry to not think it is a copy.
+ (setf (vc-hg-extra-fileinfo->rename-state (nth 2 last-added))
+ 'renamed-from)
+ (push (list file translated
+ (vc-hg-create-extra-fileinfo
+ 'renamed-to (nth 0 last-added))) result)
+ (setq last-line-copy nil))
+ (t
+ (setq last-added (list file translated nil))
+ (push last-added result)
+ (setq last-line-copy nil)))
+ (forward-line))
+ (funcall update-function result)))
+
+(defun vc-hg-dir-status (dir update-function)
+ (vc-hg-command (current-buffer) 'async dir "status" "-C")
+ (vc-exec-after
+ `(vc-hg-after-dir-status (quote ,update-function))))
+
+(defun vc-hg-dir-status-files (dir files default-state update-function)
+ (apply 'vc-hg-command (current-buffer) 'async dir "status" "-C" files)
+ (vc-exec-after
+ `(vc-hg-after-dir-status (quote ,update-function))))
+
+(defun vc-hg-dir-extra-header (name &rest commands)
+ (concat (propertize name 'face 'font-lock-type-face)
+ (propertize
+ (with-temp-buffer
+ (apply 'vc-hg-command (current-buffer) 0 nil commands)
+ (buffer-substring-no-properties (point-min) (1- (point-max))))
+ 'face 'font-lock-variable-name-face)))
+
+(defun vc-hg-dir-extra-headers (dir)
+ "Generate extra status headers for a Mercurial tree."
+ (let ((default-directory dir))
+ (concat
+ (vc-hg-dir-extra-header "Root : " "root") "\n"
+ (vc-hg-dir-extra-header "Branch : " "id" "-b") "\n"
+ (vc-hg-dir-extra-header "Tags : " "id" "-t") ; "\n"
+ ;; these change after each commit
+ ;; (vc-hg-dir-extra-header "Local num : " "id" "-n") "\n"
+ ;; (vc-hg-dir-extra-header "Global id : " "id" "-i")
+ )))
+
+(defun vc-hg-log-incoming (buffer remote-location)
+ (vc-hg-command buffer 1 nil "incoming" "-n" (unless (string= remote-location "")
+ remote-location)))
+
+(defun vc-hg-log-outgoing (buffer remote-location)
+ (vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "")
+ remote-location)))
+
+(declare-function log-view-get-marked "log-view" ())
+
+;; XXX maybe also add key bindings for these functions.
+(defun vc-hg-push ()
+ (interactive)
+ (let ((marked-list (log-view-get-marked)))
+ (if marked-list
+ (apply #'vc-hg-command
+ nil 0 nil
+ "push"
+ (apply 'nconc
+ (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
+ (error "No log entries selected for push"))))
+
+(defun vc-hg-pull ()
+ (interactive)
+ (let ((marked-list (log-view-get-marked)))
+ (if marked-list
+ (apply #'vc-hg-command
+ nil 0 nil
+ "pull"
+ (apply 'nconc
+ (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
+ (error "No log entries selected for pull"))))
+
+;;; Internal functions
+
+(defun vc-hg-command (buffer okstatus file-or-list &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-hg.el.
+The difference to vc-do-command is that this function always invokes `hg',
+and that it passes `vc-hg-global-switches' to it before FLAGS."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus "hg" file-or-list
+ (if (stringp vc-hg-global-switches)
+ (cons vc-hg-global-switches flags)
+ (append vc-hg-global-switches
+ flags))))
+
+(defun vc-hg-root (file)
+ (vc-find-root file ".hg"))
+
+(provide 'vc-hg)
+
+;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
+;;; vc-hg.el ends here
--- /dev/null
+;;; vc-hooks.el --- resident support for version-control
+
+;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
+;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is the always-loaded portion of VC. It takes care of
+;; VC-related activities that are done when you visit a file, so that
+;; vc.el itself is loaded only when you use a VC command. See the
+;; commentary of vc.el.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+;; Customization Variables (the rest is in vc.el)
+
+(defvar vc-ignore-vc-files nil)
+(make-obsolete-variable 'vc-ignore-vc-files
+ "set `vc-handled-backends' to nil to disable VC."
+ "21.1")
+
+(defvar vc-master-templates ())
+(make-obsolete-variable 'vc-master-templates
+ "to define master templates for a given BACKEND, use
+vc-BACKEND-master-templates. To enable or disable VC for a given
+BACKEND, use `vc-handled-backends'."
+ "21.1")
+
+(defvar vc-header-alist ())
+(make-obsolete-variable 'vc-header-alist 'vc-BACKEND-header "21.1")
+
+(defcustom vc-ignore-dir-regexp
+ ;; Stop SMB, automounter, AFS, and DFS host lookups.
+ locate-dominating-stop-dir-regexp
+ "Regexp matching directory names that are not under VC's control.
+The default regexp prevents fruitless and time-consuming attempts
+to determine the VC status in directories in which filenames are
+interpreted as hostnames."
+ :type 'regexp
+ :group 'vc)
+
+(defcustom vc-handled-backends '(RCS CVS SVN SCCS Bzr Git Hg Mtn Arch)
+ ;; RCS, CVS, SVN and SCCS come first because they are per-dir
+ ;; rather than per-tree. RCS comes first because of the multibackend
+ ;; support intended to use RCS for local commits (with a remote CVS server).
+ "List of version control backends for which VC will be used.
+Entries in this list will be tried in order to determine whether a
+file is under that sort of version control.
+Removing an entry from the list prevents VC from being activated
+when visiting a file managed by that backend.
+An empty list disables VC altogether."
+ :type '(repeat symbol)
+ :version "23.1"
+ :group 'vc)
+
+;; Note: we don't actually have a darcs back end yet.
+;; Also, Meta-CVS (corresponsding to MCVS) is unsupported.
+(defcustom vc-directory-exclusion-list (purecopy '("SCCS" "RCS" "CVS" "MCVS"
+ ".svn" ".git" ".hg" ".bzr"
+ "_MTN" "_darcs" "{arch}"))
+ "List of directory names to be ignored when walking directory trees."
+ :type '(repeat string)
+ :group 'vc)
+
+(defcustom vc-make-backup-files nil
+ "If non-nil, backups of registered files are made as with other files.
+If nil (the default), files covered by version control don't get backups."
+ :type 'boolean
+ :group 'vc
+ :group 'backup)
+
+(defcustom vc-follow-symlinks 'ask
+ "What to do if visiting a symbolic link to a file under version control.
+Editing such a file through the link bypasses the version control system,
+which is dangerous and probably not what you want.
+
+If this variable is t, VC follows the link and visits the real file,
+telling you about it in the echo area. If it is `ask', VC asks for
+confirmation whether it should follow the link. If nil, the link is
+visited and a warning displayed."
+ :type '(choice (const :tag "Ask for confirmation" ask)
+ (const :tag "Visit link and warn" nil)
+ (const :tag "Follow link" t))
+ :group 'vc)
+
+(defcustom vc-display-status t
+ "If non-nil, display revision number and lock status in modeline.
+Otherwise, not displayed."
+ :type 'boolean
+ :group 'vc)
+
+
+(defcustom vc-consult-headers t
+ "If non-nil, identify work files by searching for version headers."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-keep-workfiles t
+ "If non-nil, don't delete working files after registering changes.
+If the back-end is CVS, workfiles are always kept, regardless of the
+value of this flag."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-mistrust-permissions nil
+ "If non-nil, don't assume permissions/ownership track version-control status.
+If nil, do rely on the permissions.
+See also variable `vc-consult-headers'."
+ :type 'boolean
+ :group 'vc)
+
+(defun vc-mistrust-permissions (file)
+ "Internal access function to variable `vc-mistrust-permissions' for FILE."
+ (or (eq vc-mistrust-permissions 't)
+ (and vc-mistrust-permissions
+ (funcall vc-mistrust-permissions
+ (vc-backend-subdirectory-name file)))))
+
+(defcustom vc-stay-local 'only-file
+ "Non-nil means use local operations when possible for remote repositories.
+This avoids slow queries over the network and instead uses heuristics
+and past information to determine the current status of a file.
+
+If value is the symbol `only-file' `vc-dir' will connect to the
+server, but heuristics will be used to determine the status for
+all other VC operations.
+
+The value can also be a regular expression or list of regular
+expressions to match against the host name of a repository; then VC
+only stays local for hosts that match it. Alternatively, the value
+can be a list of regular expressions where the first element is the
+symbol `except'; then VC always stays local except for hosts matched
+by these regular expressions."
+ :type '(choice
+ (const :tag "Always stay local" t)
+ (const :tag "Only for file operations" only-file)
+ (const :tag "Don't stay local" nil)
+ (list :format "\nExamine hostname and %v" :tag "Examine hostname ..."
+ (set :format "%v" :inline t (const :format "%t" :tag "don't" except))
+ (regexp :format " stay local,\n%t: %v" :tag "if it matches")
+ (repeat :format "%v%i\n" :inline t (regexp :tag "or"))))
+ :version "23.1"
+ :group 'vc)
+
+(defun vc-stay-local-p (file &optional backend)
+ "Return non-nil if VC should stay local when handling FILE.
+This uses the `repository-hostname' backend operation.
+If FILE is a list of files, return non-nil if any of them
+individually should stay local."
+ (if (listp file)
+ (delq nil (mapcar (lambda (arg) (vc-stay-local-p arg backend)) file))
+ (setq backend (or backend (vc-backend file)))
+ (let* ((sym (vc-make-backend-sym backend 'stay-local))
+ (stay-local (if (boundp sym) (symbol-value sym) vc-stay-local)))
+ (if (symbolp stay-local) stay-local
+ (let ((dirname (if (file-directory-p file)
+ (directory-file-name file)
+ (file-name-directory file))))
+ (eq 'yes
+ (or (vc-file-getprop dirname 'vc-stay-local-p)
+ (vc-file-setprop
+ dirname 'vc-stay-local-p
+ (let ((hostname (vc-call-backend
+ backend 'repository-hostname dirname)))
+ (if (not hostname)
+ 'no
+ (let ((default t))
+ (if (eq (car-safe stay-local) 'except)
+ (setq default nil stay-local (cdr stay-local)))
+ (when (consp stay-local)
+ (setq stay-local
+ (mapconcat 'identity stay-local "\\|")))
+ (if (if (string-match stay-local hostname)
+ default (not default))
+ 'yes 'no))))))))))))
+
+;;; This is handled specially now.
+;; Tell Emacs about this new kind of minor mode
+;; (add-to-list 'minor-mode-alist '(vc-mode vc-mode))
+
+;;;###autoload
+(put 'vc-mode 'risky-local-variable t)
+(make-variable-buffer-local 'vc-mode)
+(put 'vc-mode 'permanent-local t)
+
+(defun vc-mode (&optional arg)
+ ;; Dummy function for C-h m
+ "Version Control minor mode.
+This minor mode is automatically activated whenever you visit a file under
+control of one of the revision control systems in `vc-handled-backends'.
+VC commands are globally reachable under the prefix `\\[vc-prefix-map]':
+\\{vc-prefix-map}")
+
+(defmacro vc-error-occurred (&rest body)
+ `(condition-case nil (progn ,@body nil) (error t)))
+
+;; We need a notion of per-file properties because the version
+;; control state of a file is expensive to derive --- we compute
+;; them when the file is initially found, keep them up to date
+;; during any subsequent VC operations, and forget them when
+;; the buffer is killed.
+
+(defvar vc-file-prop-obarray (make-vector 17 0)
+ "Obarray for per-file properties.")
+
+(defvar vc-touched-properties nil)
+
+(defun vc-file-setprop (file property value)
+ "Set per-file VC PROPERTY for FILE to VALUE."
+ (if (and vc-touched-properties
+ (not (memq property vc-touched-properties)))
+ (setq vc-touched-properties (append (list property)
+ vc-touched-properties)))
+ (put (intern file vc-file-prop-obarray) property value))
+
+(defun vc-file-getprop (file property)
+ "Get per-file VC PROPERTY for FILE."
+ (get (intern file vc-file-prop-obarray) property))
+
+(defun vc-file-clearprops (file)
+ "Clear all VC properties of FILE."
+ (setplist (intern file vc-file-prop-obarray) nil))
+
+\f
+;; We keep properties on each symbol naming a backend as follows:
+;; * `vc-functions': an alist mapping vc-FUNCTION to vc-BACKEND-FUNCTION.
+
+(defun vc-make-backend-sym (backend sym)
+ "Return BACKEND-specific version of VC symbol SYM."
+ (intern (concat "vc-" (downcase (symbol-name backend))
+ "-" (symbol-name sym))))
+
+(defun vc-find-backend-function (backend fun)
+ "Return BACKEND-specific implementation of FUN.
+If there is no such implementation, return the default implementation;
+if that doesn't exist either, return nil."
+ (let ((f (vc-make-backend-sym backend fun)))
+ (if (fboundp f) f
+ ;; Load vc-BACKEND.el if needed.
+ (require (intern (concat "vc-" (downcase (symbol-name backend)))))
+ (if (fboundp f) f
+ (let ((def (vc-make-backend-sym 'default fun)))
+ (if (fboundp def) (cons def backend) nil))))))
+
+(defun vc-call-backend (backend function-name &rest args)
+ "Call for BACKEND the implementation of FUNCTION-NAME with the given ARGS.
+Calls
+
+ (apply 'vc-BACKEND-FUN ARGS)
+
+if vc-BACKEND-FUN exists (after trying to find it in vc-BACKEND.el)
+and else calls
+
+ (apply 'vc-default-FUN BACKEND ARGS)
+
+It is usually called via the `vc-call' macro."
+ (let ((f (assoc function-name (get backend 'vc-functions))))
+ (if f (setq f (cdr f))
+ (setq f (vc-find-backend-function backend function-name))
+ (push (cons function-name f) (get backend 'vc-functions)))
+ (cond
+ ((null f)
+ (error "Sorry, %s is not implemented for %s" function-name backend))
+ ((consp f) (apply (car f) (cdr f) args))
+ (t (apply f args)))))
+
+(defmacro vc-call (fun file &rest args)
+ "A convenience macro for calling VC backend functions.
+Functions called by this macro must accept FILE as the first argument.
+ARGS specifies any additional arguments. FUN should be unquoted.
+BEWARE!! FILE is evaluated twice!!"
+ `(vc-call-backend (vc-backend ,file) ',fun ,file ,@args))
+\f
+(defsubst vc-parse-buffer (pattern i)
+ "Find PATTERN in the current buffer and return its Ith submatch."
+ (goto-char (point-min))
+ (if (re-search-forward pattern nil t)
+ (match-string i)))
+
+(defun vc-insert-file (file &optional limit blocksize)
+ "Insert the contents of FILE into the current buffer.
+
+Optional argument LIMIT is a regexp. If present, the file is inserted
+in chunks of size BLOCKSIZE (default 8 kByte), until the first
+occurrence of LIMIT is found. Anything from the start of that occurrence
+to the end of the buffer is then deleted. The function returns
+non-nil if FILE exists and its contents were successfully inserted."
+ (erase-buffer)
+ (when (file-exists-p file)
+ (if (not limit)
+ (insert-file-contents file)
+ (unless blocksize (setq blocksize 8192))
+ (let ((filepos 0))
+ (while
+ (and (< 0 (cadr (insert-file-contents
+ file nil filepos (incf filepos blocksize))))
+ (progn (beginning-of-line)
+ (let ((pos (re-search-forward limit nil 'move)))
+ (when pos (delete-region (match-beginning 0)
+ (point-max)))
+ (not pos)))))))
+ (set-buffer-modified-p nil)
+ t))
+
+(defun vc-find-root (file witness)
+ "Find the root of a checked out project.
+The function walks up the directory tree from FILE looking for WITNESS.
+If WITNESS if not found, return nil, otherwise return the root."
+ (let ((locate-dominating-stop-dir-regexp
+ (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp)))
+ (locate-dominating-file file witness)))
+
+;; Access functions to file properties
+;; (Properties should be _set_ using vc-file-setprop, but
+;; _retrieved_ only through these functions, which decide
+;; if the property is already known or not. A property should
+;; only be retrieved by vc-file-getprop if there is no
+;; access function.)
+
+;; properties indicating the backend being used for FILE
+
+(defun vc-registered (file)
+ "Return non-nil if FILE is registered in a version control system.
+
+This function performs the check each time it is called. To rely
+on the result of a previous call, use `vc-backend' instead. If the
+file was previously registered under a certain backend, then that
+backend is tried first."
+ (let (handler)
+ (cond
+ ((and (file-name-directory file)
+ (string-match vc-ignore-dir-regexp (file-name-directory file)))
+ nil)
+ ((and (boundp 'file-name-handler-alist)
+ (setq handler (find-file-name-handler file 'vc-registered)))
+ ;; handler should set vc-backend and return t if registered
+ (funcall handler 'vc-registered file))
+ (t
+ ;; There is no file name handler.
+ ;; Try vc-BACKEND-registered for each handled BACKEND.
+ (catch 'found
+ (let ((backend (vc-file-getprop file 'vc-backend)))
+ (mapc
+ (lambda (b)
+ (and (vc-call-backend b 'registered file)
+ (vc-file-setprop file 'vc-backend b)
+ (throw 'found t)))
+ (if (or (not backend) (eq backend 'none))
+ vc-handled-backends
+ (cons backend vc-handled-backends))))
+ ;; File is not registered.
+ (vc-file-setprop file 'vc-backend 'none)
+ nil)))))
+
+(defun vc-backend (file-or-list)
+ "Return the version control type of FILE-OR-LIST, nil if it's not registered.
+If the argument is a list, the files must all have the same back end."
+ ;; `file' can be nil in several places (typically due to the use of
+ ;; code like (vc-backend buffer-file-name)).
+ (cond ((stringp file-or-list)
+ (let ((property (vc-file-getprop file-or-list 'vc-backend)))
+ ;; Note that internally, Emacs remembers unregistered
+ ;; files by setting the property to `none'.
+ (cond ((eq property 'none) nil)
+ (property)
+ ;; vc-registered sets the vc-backend property
+ (t (if (vc-registered file-or-list)
+ (vc-file-getprop file-or-list 'vc-backend)
+ nil)))))
+ ((and file-or-list (listp file-or-list))
+ (vc-backend (car file-or-list)))
+ (t
+ nil)))
+
+
+(defun vc-backend-subdirectory-name (file)
+ "Return where the repository for the current directory is kept."
+ (symbol-name (vc-backend file)))
+
+(defun vc-name (file)
+ "Return the master name of FILE.
+If the file is not registered, or the master name is not known, return nil."
+ ;; TODO: This should ultimately become obsolete, at least up here
+ ;; in vc-hooks.
+ (or (vc-file-getprop file 'vc-name)
+ ;; force computation of the property by calling
+ ;; vc-BACKEND-registered explicitly
+ (let ((backend (vc-backend file)))
+ (if (and backend
+ (vc-call-backend backend 'registered file))
+ (vc-file-getprop file 'vc-name)))))
+
+(defun vc-checkout-model (backend files)
+ "Indicate how FILES are checked out.
+
+If FILES are not registered, this function always returns nil.
+For registered files, the possible values are:
+
+ 'implicit FILES are always writable, and checked out `implicitly'
+ when the user saves the first changes to the file.
+
+ 'locking FILES are read-only if up-to-date; user must type
+ \\[vc-next-action] before editing. Strict locking
+ is assumed.
+
+ 'announce FILES are read-only if up-to-date; user must type
+ \\[vc-next-action] before editing. But other users
+ may be editing at the same time."
+ (vc-call-backend backend 'checkout-model files))
+
+(defun vc-user-login-name (file)
+ "Return the name under which the user accesses the given FILE."
+ (or (and (eq (string-match tramp-file-name-regexp file) 0)
+ ;; tramp case: execute "whoami" via tramp
+ (let ((default-directory (file-name-directory file))
+ process-file-side-effects)
+ (with-temp-buffer
+ (if (not (zerop (process-file "whoami" nil t)))
+ ;; fall through if "whoami" didn't work
+ nil
+ ;; remove trailing newline
+ (delete-region (1- (point-max)) (point-max))
+ (buffer-string)))))
+ ;; normal case
+ (user-login-name)
+ ;; if user-login-name is nil, return the UID as a string
+ (number-to-string (user-uid))))
+
+(defun vc-state (file &optional backend)
+ "Return the version control state of FILE.
+
+If FILE is not registered, this function always returns nil.
+For registered files, the value returned is one of:
+
+ 'up-to-date The working file is unmodified with respect to the
+ latest version on the current branch, and not locked.
+
+ 'edited The working file has been edited by the user. If
+ locking is used for the file, this state means that
+ the current version is locked by the calling user.
+ This status should *not* be reported for files
+ which have a changed mtime but the same content
+ as the repo copy.
+
+ USER The current version of the working file is locked by
+ some other USER (a string).
+
+ 'needs-update The file has not been edited by the user, but there is
+ a more recent version on the current branch stored
+ in the repository.
+
+ 'needs-merge The file has been edited by the user, and there is also
+ a more recent version on the current branch stored in
+ the repository. This state can only occur if locking
+ is not used for the file.
+
+ 'unlocked-changes The working version of the file is not locked,
+ but the working file has been changed with respect
+ to that version. This state can only occur for files
+ with locking; it represents an erroneous condition that
+ should be resolved by the user (vc-next-action will
+ prompt the user to do it).
+
+ 'added Scheduled to go into the repository on the next commit.
+ Often represented by vc-working-revision = \"0\" in VCSes
+ with monotonic IDs like Subversion and Mercurial.
+
+ 'removed Scheduled to be deleted from the repository on next commit.
+
+ 'conflict The file contains conflicts as the result of a merge.
+ For now the conflicts are text conflicts. In the
+ future this might be extended to deal with metadata
+ conflicts too.
+
+ 'missing The file is not present in the file system, but the VC
+ system still tracks it.
+
+ 'ignored The file showed up in a dir-status listing with a flag
+ indicating the version-control system is ignoring it,
+ Note: This property is not set reliably (some VCSes
+ don't have useful directory-status commands) so assume
+ that any file with vc-state nil might be ignorable
+ without VC knowing it.
+
+ 'unregistered The file is not under version control.
+
+A return of nil from this function means we have no information on the
+status of this file."
+ ;; Note: in Emacs 22 and older, return of nil meant the file was
+ ;; unregistered. This is potentially a source of
+ ;; backward-compatibility bugs.
+
+ ;; FIXME: New (sub)states needed (?):
+ ;; - `copied' and `moved' (might be handled by `removed' and `added')
+ (or (vc-file-getprop file 'vc-state)
+ (when (> (length file) 0) ;Why?? --Stef
+ (setq backend (or backend (vc-backend file)))
+ (when backend
+ (vc-state-refresh file backend)))))
+
+(defun vc-state-refresh (file backend)
+ "Quickly recompute the `state' of FILE."
+ (vc-file-setprop
+ file 'vc-state
+ (vc-call-backend backend 'state-heuristic file)))
+
+(defsubst vc-up-to-date-p (file)
+ "Convenience function that checks whether `vc-state' of FILE is `up-to-date'."
+ (eq (vc-state file) 'up-to-date))
+
+(defun vc-default-state-heuristic (backend file)
+ "Default implementation of vc-BACKEND-state-heuristic.
+It simply calls the real state computation function `vc-BACKEND-state'
+and does not employ any heuristic at all."
+ (vc-call-backend backend 'state file))
+
+(defun vc-workfile-unchanged-p (file)
+ "Return non-nil if FILE has not changed since the last checkout."
+ (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
+ (lastmod (nth 5 (file-attributes file))))
+ ;; This is a shortcut for determining when the workfile is
+ ;; unchanged. It can fail under some circumstances; see the
+ ;; discussion in bug#694.
+ (if (and checkout-time
+ ;; Tramp and Ange-FTP return this when they don't know the time.
+ (not (equal lastmod '(0 0))))
+ (equal checkout-time lastmod)
+ (let ((unchanged (vc-call workfile-unchanged-p file)))
+ (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0))
+ unchanged))))
+
+(defun vc-default-workfile-unchanged-p (backend file)
+ "Check if FILE is unchanged by diffing against the repository version.
+Return non-nil if FILE is unchanged."
+ (zerop (condition-case err
+ ;; If the implementation supports it, let the output
+ ;; go to *vc*, not *vc-diff*, since this is an internal call.
+ (vc-call-backend backend 'diff (list file) nil nil "*vc*")
+ (wrong-number-of-arguments
+ ;; If this error came from the above call to vc-BACKEND-diff,
+ ;; try again without the optional buffer argument (for
+ ;; backward compatibility). Otherwise, resignal.
+ (if (or (not (eq (cadr err)
+ (indirect-function
+ (vc-find-backend-function backend 'diff))))
+ (not (eq (caddr err) 4)))
+ (signal (car err) (cdr err))
+ (vc-call-backend backend 'diff (list file)))))))
+
+(defun vc-working-revision (file &optional backend)
+ "Return the repository version from which FILE was checked out.
+If FILE is not registered, this function always returns nil."
+ (or (vc-file-getprop file 'vc-working-revision)
+ (progn
+ (setq backend (or backend (vc-backend file)))
+ (when backend
+ (vc-file-setprop file 'vc-working-revision
+ (vc-call-backend backend 'working-revision file))))))
+
+;; Backward compatibility.
+(define-obsolete-function-alias
+ 'vc-workfile-version 'vc-working-revision "23.1")
+(defun vc-default-working-revision (backend file)
+ (message
+ "`working-revision' not found: using the old `workfile-version' instead")
+ (vc-call-backend backend 'workfile-version file))
+
+(defun vc-default-registered (backend file)
+ "Check if FILE is registered in BACKEND using vc-BACKEND-master-templates."
+ (let ((sym (vc-make-backend-sym backend 'master-templates)))
+ (unless (get backend 'vc-templates-grabbed)
+ (put backend 'vc-templates-grabbed t)
+ (set sym (append (delq nil
+ (mapcar
+ (lambda (template)
+ (and (consp template)
+ (eq (cdr template) backend)
+ (car template)))
+ (with-no-warnings
+ vc-master-templates)))
+ (symbol-value sym))))
+ (let ((result (vc-check-master-templates file (symbol-value sym))))
+ (if (stringp result)
+ (vc-file-setprop file 'vc-name result)
+ nil)))) ; Not registered
+
+(defun vc-possible-master (s dirname basename)
+ (cond
+ ((stringp s) (format s dirname basename))
+ ((functionp s)
+ ;; The template is a function to invoke. If the
+ ;; function returns non-nil, that means it has found a
+ ;; master. For backward compatibility, we also handle
+ ;; the case that the function throws a 'found atom
+ ;; and a pair (cons MASTER-FILE BACKEND).
+ (let ((result (catch 'found (funcall s dirname basename))))
+ (if (consp result) (car result) result)))))
+
+(defun vc-check-master-templates (file templates)
+ "Return non-nil if there is a master corresponding to FILE.
+
+TEMPLATES is a list of strings or functions. If an element is a
+string, it must be a control string as required by `format', with two
+string placeholders, such as \"%sRCS/%s,v\". The directory part of
+FILE is substituted for the first placeholder, the basename of FILE
+for the second. If a file with the resulting name exists, it is taken
+as the master of FILE, and returned.
+
+If an element of TEMPLATES is a function, it is called with the
+directory part and the basename of FILE as arguments. It should
+return non-nil if it finds a master; that value is then returned by
+this function."
+ (let ((dirname (or (file-name-directory file) ""))
+ (basename (file-name-nondirectory file)))
+ (catch 'found
+ (mapcar
+ (lambda (s)
+ (let ((trial (vc-possible-master s dirname basename)))
+ (when (and trial (file-exists-p trial)
+ ;; Make sure the file we found with name
+ ;; TRIAL is not the source file itself.
+ ;; That can happen with RCS-style names if
+ ;; the file name is truncated (e.g. to 14
+ ;; chars). See if either directory or
+ ;; attributes differ.
+ (or (not (string= dirname
+ (file-name-directory trial)))
+ (not (equal (file-attributes file)
+ (file-attributes trial)))))
+ (throw 'found trial))))
+ templates))))
+
+(defun vc-toggle-read-only (&optional verbose)
+ "Change read-only status of current buffer, perhaps via version control.
+
+If the buffer is visiting a file registered with version control,
+throw an error, because this is not a safe or really meaningful operation
+on any version-control system newer than RCS.
+
+Otherwise, just change the read-only flag of the buffer.
+
+If you bind this function to \\[toggle-read-only], then Emacs
+will properly intercept all attempts to toggle the read-only flag
+on version-controlled buffer."
+ (interactive "P")
+ (if (vc-backend buffer-file-name)
+ (error "Toggling the readability of a version controlled file is likely to wreak havoc")
+ (toggle-read-only)))
+
+(defun vc-default-make-version-backups-p (backend file)
+ "Return non-nil if unmodified versions should be backed up locally.
+The default is to switch off this feature."
+ nil)
+
+(defun vc-version-backup-file-name (file &optional rev manual regexp)
+ "Return a backup file name for REV or the current version of FILE.
+If MANUAL is non-nil it means that a name for backups created by
+the user should be returned; if REGEXP is non-nil that means to return
+a regexp for matching all such backup files, regardless of the version."
+ (if regexp
+ (concat (regexp-quote (file-name-nondirectory file))
+ "\\.~.+" (unless manual "\\.") "~")
+ (expand-file-name (concat (file-name-nondirectory file)
+ ".~" (subst-char-in-string
+ ?/ ?_ (or rev (vc-working-revision file)))
+ (unless manual ".") "~")
+ (file-name-directory file))))
+
+(defun vc-delete-automatic-version-backups (file)
+ "Delete all existing automatic version backups for FILE."
+ (condition-case nil
+ (mapc
+ 'delete-file
+ (directory-files (or (file-name-directory file) default-directory) t
+ (vc-version-backup-file-name file nil nil t)))
+ ;; Don't fail when the directory doesn't exist.
+ (file-error nil)))
+
+(defun vc-make-version-backup (file)
+ "Make a backup copy of FILE, which is assumed in sync with the repository.
+Before doing that, check if there are any old backups and get rid of them."
+ (unless (and (fboundp 'msdos-long-file-names)
+ (not (with-no-warnings (msdos-long-file-names))))
+ (vc-delete-automatic-version-backups file)
+ (condition-case nil
+ (copy-file file (vc-version-backup-file-name file)
+ nil 'keep-date)
+ ;; It's ok if it doesn't work (e.g. directory not writable),
+ ;; since this is just for efficiency.
+ (file-error
+ (message
+ (concat "Warning: Cannot make version backup; "
+ "diff/revert therefore not local"))))))
+
+(defun vc-before-save ()
+ "Function to be called by `basic-save-buffer' (in files.el)."
+ ;; If the file on disk is still in sync with the repository,
+ ;; and version backups should be made, copy the file to
+ ;; another name. This enables local diffs and local reverting.
+ (let ((file buffer-file-name)
+ backend)
+ (ignore-errors ;Be careful not to prevent saving the file.
+ (and (setq backend (vc-backend file))
+ (vc-up-to-date-p file)
+ (eq (vc-checkout-model backend (list file)) 'implicit)
+ (vc-call-backend backend 'make-version-backups-p file)
+ (vc-make-version-backup file)))))
+
+(declare-function vc-dir-resynch-file "vc-dir" (&optional fname))
+
+(defvar vc-dir-buffers nil "List of vc-dir buffers.")
+
+(defun vc-after-save ()
+ "Function to be called by `basic-save-buffer' (in files.el)."
+ ;; If the file in the current buffer is under version control,
+ ;; up-to-date, and locking is not used for the file, set
+ ;; the state to 'edited and redisplay the mode line.
+ (let* ((file buffer-file-name)
+ (backend (vc-backend file)))
+ (and backend
+ (or (and (equal (vc-file-getprop file 'vc-checkout-time)
+ (nth 5 (file-attributes file)))
+ ;; File has been saved in the same second in which
+ ;; it was checked out. Clear the checkout-time
+ ;; to avoid confusion.
+ (vc-file-setprop file 'vc-checkout-time nil))
+ t)
+ (eq (vc-checkout-model backend (list file)) 'implicit)
+ (vc-state-refresh file backend)
+ (vc-mode-line file backend))
+ ;; Try to avoid unnecessary work, a *vc-dir* buffer is
+ ;; present if this is true.
+ (when vc-dir-buffers
+ (vc-dir-resynch-file file))))
+
+(defvar vc-menu-entry
+ `(menu-item ,(purecopy "Version Control") vc-menu-map
+ :filter vc-menu-map-filter))
+
+(when (boundp 'menu-bar-tools-menu)
+ ;; We do not need to worry here about the placement of this entry
+ ;; because menu-bar.el has already created the proper spot for us
+ ;; and this will simply use it.
+ (define-key menu-bar-tools-menu [vc] vc-menu-entry))
+
+(defconst vc-mode-line-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mode-line down-mouse-1] vc-menu-entry)
+ map))
+
+(defun vc-mode-line (file &optional backend)
+ "Set `vc-mode' to display type of version control for FILE.
+The value is set in the current buffer, which should be the buffer
+visiting FILE.
+If BACKEND is passed use it as the VC backend when computing the result."
+ (interactive (list buffer-file-name))
+ (setq backend (or backend (vc-backend file)))
+ (if (not backend)
+ (setq vc-mode nil)
+ (let* ((ml-string (vc-call-backend backend 'mode-line-string file))
+ (ml-echo (get-text-property 0 'help-echo ml-string)))
+ (setq vc-mode
+ (concat
+ " "
+ (if (null vc-display-status)
+ (symbol-name backend)
+ (propertize
+ ml-string
+ 'mouse-face 'mode-line-highlight
+ 'help-echo
+ (concat (or ml-echo
+ (format "File under the %s version control system"
+ backend))
+ "\nmouse-1: Version Control menu")
+ 'local-map vc-mode-line-map)))))
+ ;; If the user is root, and the file is not owner-writable,
+ ;; then pretend that we can't write it
+ ;; even though we can (because root can write anything).
+ ;; This way, even root cannot modify a file that isn't locked.
+ (and (equal file buffer-file-name)
+ (not buffer-read-only)
+ (zerop (user-real-uid))
+ (zerop (logand (file-modes buffer-file-name) 128))
+ (setq buffer-read-only t)))
+ (force-mode-line-update)
+ backend)
+
+(defun vc-default-mode-line-string (backend file)
+ "Return string for placement in modeline by `vc-mode-line' for FILE.
+Format:
+
+ \"BACKEND-REV\" if the file is up-to-date
+ \"BACKEND:REV\" if the file is edited (or locked by the calling user)
+ \"BACKEND:LOCKER:REV\" if the file is locked by somebody else
+
+This function assumes that the file is registered."
+ (let* ((backend-name (symbol-name backend))
+ (state (vc-state file backend))
+ (state-echo nil)
+ (rev (vc-working-revision file backend)))
+ (propertize
+ (cond ((or (eq state 'up-to-date)
+ (eq state 'needs-update))
+ (setq state-echo "Up to date file")
+ (concat backend-name "-" rev))
+ ((stringp state)
+ (setq state-echo (concat "File locked by" state))
+ (concat backend-name ":" state ":" rev))
+ ((eq state 'added)
+ (setq state-echo "Locally added file")
+ (concat backend-name "@" rev))
+ ((eq state 'conflict)
+ (setq state-echo "File contains conflicts after the last merge")
+ (concat backend-name "!" rev))
+ ((eq state 'removed)
+ (setq state-echo "File removed from the VC system")
+ (concat backend-name "!" rev))
+ ((eq state 'missing)
+ (setq state-echo "File tracked by the VC system, but missing from the file system")
+ (concat backend-name "?" rev))
+ (t
+ ;; Not just for the 'edited state, but also a fallback
+ ;; for all other states. Think about different symbols
+ ;; for 'needs-update and 'needs-merge.
+ (setq state-echo "Locally modified file")
+ (concat backend-name ":" rev)))
+ 'help-echo (concat state-echo " under the " backend-name
+ " version control system"))))
+
+(defun vc-follow-link ()
+ "If current buffer visits a symbolic link, visit the real file.
+If the real file is already visited in another buffer, make that buffer
+current, and kill the buffer that visits the link."
+ (let* ((true-buffer (find-buffer-visiting buffer-file-truename))
+ (this-buffer (current-buffer)))
+ (if (eq true-buffer this-buffer)
+ (let ((truename buffer-file-truename))
+ (kill-buffer this-buffer)
+ ;; In principle, we could do something like set-visited-file-name.
+ ;; However, it can't be exactly the same as set-visited-file-name.
+ ;; I'm not going to work out the details right now. -- rms.
+ (set-buffer (find-file-noselect truename)))
+ (set-buffer true-buffer)
+ (kill-buffer this-buffer))))
+
+(defun vc-default-find-file-hook (backend)
+ nil)
+
+(defun vc-find-file-hook ()
+ "Function for `find-file-hook' activating VC mode if appropriate."
+ ;; Recompute whether file is version controlled,
+ ;; if user has killed the buffer and revisited.
+ (when vc-mode
+ (setq vc-mode nil))
+ (when buffer-file-name
+ (vc-file-clearprops buffer-file-name)
+ ;; FIXME: Why use a hook? Why pass it buffer-file-name?
+ (add-hook 'vc-mode-line-hook 'vc-mode-line nil t)
+ (let (backend)
+ (cond
+ ((setq backend (with-demoted-errors (vc-backend buffer-file-name)))
+ ;; Compute the state and put it in the modeline.
+ (vc-mode-line buffer-file-name backend)
+ (unless vc-make-backup-files
+ ;; Use this variable, not make-backup-files,
+ ;; because this is for things that depend on the file name.
+ (set (make-local-variable 'backup-inhibited) t))
+ ;; Let the backend setup any buffer-local things he needs.
+ (vc-call-backend backend 'find-file-hook))
+ ((let ((link-type (and (not (equal buffer-file-name buffer-file-truename))
+ (vc-backend buffer-file-truename))))
+ (cond ((not link-type) nil) ;Nothing to do.
+ ((eq vc-follow-symlinks nil)
+ (message
+ "Warning: symbolic link to %s-controlled source file" link-type))
+ ((or (not (eq vc-follow-symlinks 'ask))
+ ;; If we already visited this file by following
+ ;; the link, don't ask again if we try to visit
+ ;; it again. GUD does that, and repeated questions
+ ;; are painful.
+ (get-file-buffer
+ (abbreviate-file-name
+ (file-chase-links buffer-file-name))))
+
+ (vc-follow-link)
+ (message "Followed link to %s" buffer-file-name)
+ (vc-find-file-hook))
+ (t
+ (if (yes-or-no-p (format
+ "Symbolic link to %s-controlled source file; follow link? " link-type))
+ (progn (vc-follow-link)
+ (message "Followed link to %s" buffer-file-name)
+ (vc-find-file-hook))
+ (message
+ "Warning: editing through the link bypasses version control")
+ )))))))))
+
+(add-hook 'find-file-hook 'vc-find-file-hook)
+
+(defun vc-kill-buffer-hook ()
+ "Discard VC info about a file when we kill its buffer."
+ (when buffer-file-name (vc-file-clearprops buffer-file-name)))
+
+(add-hook 'kill-buffer-hook 'vc-kill-buffer-hook)
+
+;; Now arrange for (autoloaded) bindings of the main package.
+;; Bindings for this have to go in the global map, as we'll often
+;; want to call them from random buffers.
+
+;; Autoloading works fine, but it prevents shortcuts from appearing
+;; in the menu because they don't exist yet when the menu is built.
+;; (autoload 'vc-prefix-map "vc" nil nil 'keymap)
+(defvar vc-prefix-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "a" 'vc-update-change-log)
+ (define-key map "b" 'vc-switch-backend)
+ (define-key map "c" 'vc-rollback)
+ (define-key map "d" 'vc-dir)
+ (define-key map "g" 'vc-annotate)
+ (define-key map "h" 'vc-insert-headers)
+ (define-key map "i" 'vc-register)
+ (define-key map "l" 'vc-print-log)
+ (define-key map "L" 'vc-print-root-log)
+ (define-key map "I" 'vc-log-incoming)
+ (define-key map "O" 'vc-log-outgoing)
+ (define-key map "m" 'vc-merge)
+ (define-key map "r" 'vc-retrieve-tag)
+ (define-key map "s" 'vc-create-tag)
+ (define-key map "u" 'vc-revert)
+ (define-key map "v" 'vc-next-action)
+ (define-key map "+" 'vc-update)
+ (define-key map "=" 'vc-diff)
+ (define-key map "D" 'vc-root-diff)
+ (define-key map "~" 'vc-revision-other-window)
+ map))
+(fset 'vc-prefix-map vc-prefix-map)
+(define-key global-map "\C-xv" 'vc-prefix-map)
+
+(defvar vc-menu-map
+ (let ((map (make-sparse-keymap "Version Control")))
+ ;;(define-key map [show-files]
+ ;; '("Show Files under VC" . (vc-directory t)))
+ (define-key map [vc-retrieve-tag]
+ `(menu-item ,(purecopy "Retrieve Tag") vc-retrieve-tag
+ :help ,(purecopy "Retrieve tagged version or branch")))
+ (define-key map [vc-create-tag]
+ `(menu-item ,(purecopy "Create Tag") vc-create-tag
+ :help ,(purecopy "Create version tag")))
+ (define-key map [separator1] menu-bar-separator)
+ (define-key map [vc-annotate]
+ `(menu-item ,(purecopy "Annotate") vc-annotate
+ :help ,(purecopy "Display the edit history of the current file using colors")))
+ (define-key map [vc-rename-file]
+ `(menu-item ,(purecopy "Rename File") vc-rename-file
+ :help ,(purecopy "Rename file")))
+ (define-key map [vc-revision-other-window]
+ `(menu-item ,(purecopy "Show Other Version") vc-revision-other-window
+ :help ,(purecopy "Visit another version of the current file in another window")))
+ (define-key map [vc-diff]
+ `(menu-item ,(purecopy "Compare with Base Version") vc-diff
+ :help ,(purecopy "Compare file set with the base version")))
+ (define-key map [vc-root-diff]
+ `(menu-item ,(purecopy "Compare Tree with Base Version") vc-root-diff
+ :help ,(purecopy "Compare current tree with the base version")))
+ (define-key map [vc-update-change-log]
+ `(menu-item ,(purecopy "Update ChangeLog") vc-update-change-log
+ :help ,(purecopy "Find change log file and add entries from recent version control logs")))
+ (define-key map [vc-log-out]
+ `(menu-item ,(purecopy "Show Outgoing Log") vc-log-outgoing
+ :help ,(purecopy "Show a log of changes that will be sent with a push operation")))
+ (define-key map [vc-log-in]
+ `(menu-item ,(purecopy "Show Incoming Log") vc-log-incoming
+ :help ,(purecopy "Show a log of changes that will be received with a pull operation")))
+ (define-key map [vc-print-log]
+ `(menu-item ,(purecopy "Show History") vc-print-log
+ :help ,(purecopy "List the change log of the current file set in a window")))
+ (define-key map [vc-print-root-log]
+ `(menu-item ,(purecopy "Show Top of the Tree History ") vc-print-root-log
+ :help ,(purecopy "List the change log for the current tree in a window")))
+ (define-key map [separator2] menu-bar-separator)
+ (define-key map [vc-insert-header]
+ `(menu-item ,(purecopy "Insert Header") vc-insert-headers
+ :help ,(purecopy "Insert headers into a file for use with a version control system.
+")))
+ (define-key map [undo]
+ `(menu-item ,(purecopy "Undo Last Check-In") vc-rollback
+ :help ,(purecopy "Remove the most recent changeset committed to the repository")))
+ (define-key map [vc-revert]
+ `(menu-item ,(purecopy "Revert to Base Version") vc-revert
+ :help ,(purecopy "Revert working copies of the selected file set to their repository contents")))
+ (define-key map [vc-update]
+ `(menu-item ,(purecopy "Update to Latest Version") vc-update
+ :help ,(purecopy "Update the current fileset's files to their tip revisions")))
+ (define-key map [vc-next-action]
+ `(menu-item ,(purecopy "Check In/Out") vc-next-action
+ :help ,(purecopy "Do the next logical version control operation on the current fileset")))
+ (define-key map [vc-register]
+ `(menu-item ,(purecopy "Register") vc-register
+ :help ,(purecopy "Register file set into a version control system")))
+ (define-key map [vc-dir]
+ `(menu-item ,(purecopy "VC Dir") vc-dir
+ :help ,(purecopy "Show the VC status of files in a directory")))
+ map))
+
+(defalias 'vc-menu-map vc-menu-map)
+
+(declare-function vc-responsible-backend "vc" (file))
+
+(defun vc-menu-map-filter (orig-binding)
+ (if (and (symbolp orig-binding) (fboundp orig-binding))
+ (setq orig-binding (indirect-function orig-binding)))
+ (let ((ext-binding
+ (when vc-mode
+ (vc-call-backend
+ (if buffer-file-name
+ (vc-backend buffer-file-name)
+ (vc-responsible-backend default-directory))
+ 'extra-menu))))
+ ;; Give the VC backend a chance to add menu entries
+ ;; specific for that backend.
+ (if (null ext-binding)
+ orig-binding
+ (append orig-binding
+ '((ext-menu-separator "--"))
+ ext-binding))))
+
+(defun vc-default-extra-menu (backend)
+ nil)
+
+(provide 'vc-hooks)
+
+;; arch-tag: 2e5a6fa7-1d30-48e2-8bd0-e3d335f04f32
+;;; vc-hooks.el ends here
--- /dev/null
+;;; vc-mtn.el --- VC backend for Monotone
+
+;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords:
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; TODO:
+
+;; - The `previous-version' VC method needs to be supported, 'D' in
+;; log-view-mode uses it.
+
+;;; Code:
+
+(eval-when-compile (require 'cl) (require 'vc))
+
+(defcustom vc-mtn-diff-switches t
+ "String or list of strings specifying switches for monotone diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "23.1"
+ :group 'vc)
+
+(define-obsolete-variable-alias 'vc-mtn-command 'vc-mtn-program "23.1")
+(defcustom vc-mtn-program "mtn"
+ "Name of the monotone executable."
+ :type 'string
+ :group 'vc)
+
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'Mtn 'vc-functions nil)
+
+(unless (executable-find vc-mtn-program)
+ ;; vc-mtn.el is 100% non-functional without the `mtn' executable.
+ (setq vc-handled-backends (delq 'Mtn vc-handled-backends)))
+
+;;;###autoload
+(defconst vc-mtn-admin-dir "_MTN")
+;;;###autoload
+(defconst vc-mtn-admin-format (concat vc-mtn-admin-dir "/format"))
+
+;;;###autoload (defun vc-mtn-registered (file)
+;;;###autoload (if (vc-find-root file vc-mtn-admin-format)
+;;;###autoload (progn
+;;;###autoload (load "vc-mtn")
+;;;###autoload (vc-mtn-registered file))))
+
+(defun vc-mtn-revision-granularity () 'repository)
+(defun vc-mtn-checkout-model (files) 'implicit)
+
+(defun vc-mtn-root (file)
+ (setq file (if (file-directory-p file)
+ (file-name-as-directory file)
+ (file-name-directory file)))
+ (or (vc-file-getprop file 'vc-mtn-root)
+ (vc-file-setprop file 'vc-mtn-root
+ (vc-find-root file vc-mtn-admin-format))))
+
+
+(defun vc-mtn-registered (file)
+ (let ((root (vc-mtn-root file)))
+ (when root
+ (vc-mtn-state file))))
+
+(defun vc-mtn-command (buffer okstatus files &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-mtn.el."
+ (let ((process-environment
+ ;; Avoid localization of messages so we can parse the output.
+ (cons "LC_MESSAGES=C" process-environment)))
+ (apply 'vc-do-command (or buffer "*vc*") okstatus vc-mtn-program
+ files flags)))
+
+(defun vc-mtn-state (file)
+ ;; If `mtn' fails or returns status>0, or if the search files, just
+ ;; return nil.
+ (ignore-errors
+ (with-temp-buffer
+ (vc-mtn-command t 0 file "status")
+ (goto-char (point-min))
+ (re-search-forward
+ "^ \\(?:\\(patched\\)\\|\\(added\\) \\(?:.*\\)\\)\\|no changes$")
+ (cond ((match-end 1) 'edited)
+ ((match-end 2) 'added)
+ (t 'up-to-date)))))
+
+(defun vc-mtn-after-dir-status (update-function)
+ (let (result)
+ (goto-char (point-min))
+ (re-search-forward "Current branch: \\(.*\\)\nChanges against parent \\(.*\\)" nil t)
+ (while (re-search-forward
+ "^ \\(?:\\(patched \\)\\|\\(added \\)\\)\\(.*\\)$" nil t)
+ (cond ((match-end 1) (push (list (match-string 3) 'edited) result))
+ ((match-end 2) (push (list (match-string 3) 'added) result))))
+ (funcall update-function result)))
+
+(defun vc-mtn-dir-status (dir update-function)
+ (vc-mtn-command (current-buffer) 'async dir "status")
+ (vc-exec-after
+ `(vc-mtn-after-dir-status (quote ,update-function))))
+
+(defun vc-mtn-working-revision (file)
+ ;; If `mtn' fails or returns status>0, or if the search fails, just
+ ;; return nil.
+ (ignore-errors
+ (with-temp-buffer
+ (vc-mtn-command t 0 file "status")
+ (goto-char (point-min))
+ (re-search-forward "Current branch: \\(.*\\)\nChanges against parent \\(.*\\)")
+ (match-string 2))))
+
+(defun vc-mtn-workfile-branch (file)
+ ;; If `mtn' fails or returns status>0, or if the search files, just
+ ;; return nil.
+ (ignore-errors
+ (with-temp-buffer
+ (vc-mtn-command t 0 file "status")
+ (goto-char (point-min))
+ (re-search-forward "Current branch: \\(.*\\)\nChanges against parent \\(.*\\)")
+ (match-string 1))))
+
+(defun vc-mtn-workfile-unchanged-p (file)
+ (not (eq (vc-mtn-state file) 'edited)))
+
+;; Mode-line rewrite code copied from vc-arch.el.
+
+(defcustom vc-mtn-mode-line-rewrite
+ '(("\\`[^:/#]*[:/#]" . "")) ;Drop the host part.
+ "Rewrite rules to shorten Mtn's revision names on the mode-line."
+ :type '(repeat (cons regexp string))
+ :version "22.2"
+ :group 'vc)
+
+(defun vc-mtn-mode-line-string (file)
+ "Return string for placement in modeline by `vc-mode-line' for FILE."
+ (let ((branch (vc-mtn-workfile-branch file)))
+ (dolist (rule vc-mtn-mode-line-rewrite)
+ (if (string-match (car rule) branch)
+ (setq branch (replace-match (cdr rule) t nil branch))))
+ (format "Mtn%c%s"
+ (case (vc-state file)
+ ((up-to-date needs-update) ?-)
+ (added ?@)
+ (t ?:))
+ branch)))
+
+(defun vc-mtn-register (files &optional rev comment)
+ (vc-mtn-command nil 0 files "add"))
+
+(defun vc-mtn-responsible-p (file) (vc-mtn-root file))
+(defun vc-mtn-could-register (file) (vc-mtn-root file))
+
+(declare-function log-edit-extract-headers "log-edit" (headers string))
+
+(defun vc-mtn-checkin (files rev comment &optional extra-args-ignored)
+ (apply 'vc-mtn-command nil 0 files
+ (nconc (list "commit" "-m")
+ (log-edit-extract-headers '(("Author" . "--author")
+ ("Date" . "--date"))
+ comment))))
+
+(defun vc-mtn-find-revision (file rev buffer)
+ (vc-mtn-command buffer 0 file "cat" "-r" rev))
+
+;; (defun vc-mtn-checkout (file &optional editable rev)
+;; )
+
+(defun vc-mtn-revert (file &optional contents-done)
+ (unless contents-done
+ (vc-mtn-command nil 0 file "revert")))
+
+;; (defun vc-mtn-roolback (files)
+;; )
+
+(defun vc-mtn-print-log (files buffer &optional shortlog start-revision limit)
+ (apply 'vc-mtn-command buffer 0 files "log"
+ (append
+ (when start-revision (list "--from" (format "%s" start-revision)))
+ (when limit (list "--last" (format "%s" limit))))))
+
+(defvar log-view-message-re)
+(defvar log-view-file-re)
+(defvar log-view-font-lock-keywords)
+(defvar log-view-per-file-logs)
+
+(define-derived-mode vc-mtn-log-view-mode log-view-mode "Mtn-Log-View"
+ ;; Don't match anything.
+ (set (make-local-variable 'log-view-file-re) "\\`a\\`")
+ (set (make-local-variable 'log-view-per-file-logs) nil)
+ ;; TODO: Use a more precise regexp than "[ |/]+" to avoid false positives
+ ;; in the ChangeLog text.
+ (set (make-local-variable 'log-view-message-re)
+ "^[ |/]+Revision: \\([0-9a-f]+\\)")
+ (require 'add-log) ;For change-log faces.
+ (set (make-local-variable 'log-view-font-lock-keywords)
+ (append log-view-font-lock-keywords
+ '(("^[ |]+Author: \\(.*\\)" (1 'change-log-email))
+ ("^[ |]+Date: \\(.*\\)" (1 'change-log-date-face))))))
+
+;; (defun vc-mtn-show-log-entry (revision)
+;; )
+
+(defun vc-mtn-diff (files &optional rev1 rev2 buffer)
+ "Get a difference report using monotone between two revisions of FILES."
+ (apply 'vc-mtn-command (or buffer "*vc-diff*") 1 files "diff"
+ (append
+ (vc-switches 'mtn 'diff)
+ (if rev1 (list "-r" rev1)) (if rev2 (list "-r" rev2)))))
+
+(defun vc-mtn-annotate-command (file buf &optional rev)
+ (apply 'vc-mtn-command buf 'async file "annotate"
+ (if rev (list "-r" rev))))
+
+(declare-function vc-annotate-convert-time "vc-annotate" (time))
+
+(defconst vc-mtn-annotate-full-re
+ "^ *\\([0-9a-f]+\\)\\.* by [^ ]+ \\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\): ")
+(defconst vc-mtn-annotate-any-re
+ (concat "^\\(?: +: \\|" vc-mtn-annotate-full-re "\\)"))
+
+(defun vc-mtn-annotate-time ()
+ (when (looking-at vc-mtn-annotate-any-re)
+ (goto-char (match-end 0))
+ (let ((year (match-string 2)))
+ (if (not year)
+ ;; Look for the date on a previous line.
+ (save-excursion
+ (get-text-property (1- (previous-single-property-change
+ (point) 'vc-mtn-time nil (point-min)))
+ 'vc-mtn-time))
+ (let ((time (vc-annotate-convert-time
+ (encode-time 0 0 0
+ (string-to-number (match-string 4))
+ (string-to-number (match-string 3))
+ (string-to-number year)
+ t))))
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'vc-mtn-time time))
+ time)))))
+
+(defun vc-mtn-annotate-extract-revision-at-line ()
+ (save-excursion
+ (when (or (looking-at vc-mtn-annotate-full-re)
+ (re-search-backward vc-mtn-annotate-full-re nil t))
+ (match-string 1))))
+
+;;; Revision completion.
+
+(defun vc-mtn-list-tags ()
+ (with-temp-buffer
+ (vc-mtn-command t 0 nil "list" "tags")
+ (goto-char (point-min))
+ (let ((tags ()))
+ (while (re-search-forward "^[^ ]+" nil t)
+ (push (match-string 0) tags))
+ tags)))
+
+(defun vc-mtn-list-branches ()
+ (with-temp-buffer
+ (vc-mtn-command t 0 nil "list" "branches")
+ (goto-char (point-min))
+ (let ((branches ()))
+ (while (re-search-forward "^.+" nil t)
+ (push (match-string 0) branches))
+ branches)))
+
+(defun vc-mtn-list-revision-ids (prefix)
+ (with-temp-buffer
+ (vc-mtn-command t 0 nil "complete" "revision" prefix)
+ (goto-char (point-min))
+ (let ((ids ()))
+ (while (re-search-forward "^.+" nil t)
+ (push (match-string 0) ids))
+ ids)))
+
+(defun vc-mtn-revision-completion-table (files)
+ ;; TODO: Implement completion for for selectors
+ ;; TODO: Implement completion for composite selectors.
+ (lexical-let ((files files))
+ ;; What about using `files'?!? --Stef
+ (lambda (string pred action)
+ (cond
+ ;; "Tag" selectors.
+ ((string-match "\\`t:" string)
+ (complete-with-action action
+ (mapcar (lambda (tag) (concat "t:" tag))
+ (vc-mtn-list-tags))
+ string pred))
+ ;; "Branch" selectors.
+ ((string-match "\\`b:" string)
+ (complete-with-action action
+ (mapcar (lambda (tag) (concat "b:" tag))
+ (vc-mtn-list-branches))
+ string pred))
+ ;; "Head" selectors. Not sure how they differ from "branch" selectors.
+ ((string-match "\\`h:" string)
+ (complete-with-action action
+ (mapcar (lambda (tag) (concat "h:" tag))
+ (vc-mtn-list-branches))
+ string pred))
+ ;; "ID" selectors.
+ ((string-match "\\`i:" string)
+ (complete-with-action action
+ (mapcar (lambda (tag) (concat "i:" tag))
+ (vc-mtn-list-revision-ids
+ (substring string (match-end 0))))
+ string pred))
+ (t
+ (complete-with-action action
+ '("t:" "b:" "h:" "i:"
+ ;; Completion not implemented for these.
+ "a:" "c:" "d:" "e:" "l:")
+ string pred))))))
+
+
+
+(provide 'vc-mtn)
+
+;; arch-tag: 2b89ffbc-cbb8-405a-9080-2eafd4becb70
+;;; vc-mtn.el ends here
--- /dev/null
+;;; vc-rcs.el --- support for RCS version-control
+
+;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; See vc.el
+
+;; Some features will not work with old RCS versions. Where
+;; appropriate, VC finds out which version you have, and allows or
+;; disallows those features (stealing locks, for example, works only
+;; from 5.6.2 onwards).
+;; Even initial checkins will fail if your RCS version is so old that ci
+;; doesn't understand -t-; this has been known to happen to people running
+;; NExTSTEP 3.0.
+;;
+;; You can support the RCS -x option by customizing vc-rcs-master-templates.
+
+;;; Code:
+
+;;;
+;;; Customization options
+;;;
+
+(eval-when-compile
+ (require 'cl)
+ (require 'vc))
+
+(defcustom vc-rcs-release nil
+ "The release number of your RCS installation, as a string.
+If nil, VC itself computes this value when it is first needed."
+ :type '(choice (const :tag "Auto" nil)
+ (string :tag "Specified")
+ (const :tag "Unknown" unknown))
+ :group 'vc)
+
+(defcustom vc-rcs-register-switches nil
+ "Switches for registering a file in RCS.
+A string or list of strings passed to the checkin program by
+\\[vc-register]. If nil, use the value of `vc-register-switches'.
+If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-rcs-diff-switches nil
+ "String or list of strings specifying switches for RCS diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-rcs-header (or (cdr (assoc 'RCS vc-header-alist)) '("\$Id\$"))
+ "Header keywords to be inserted by `vc-insert-headers'."
+ :type '(repeat string)
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-rcsdiff-knows-brief nil
+ "Indicates whether rcsdiff understands the --brief option.
+The value is either `yes', `no', or nil. If it is nil, VC tries
+to use --brief and sets this variable to remember whether it worked."
+ :type '(choice (const :tag "Work out" nil) (const yes) (const no))
+ :group 'vc)
+
+;;;###autoload
+(defcustom vc-rcs-master-templates
+ (purecopy '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s"))
+ "Where to look for RCS master files.
+For a description of possible values, see `vc-check-master-templates'."
+ :type '(choice (const :tag "Use standard RCS file names"
+ '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s"))
+ (repeat :tag "User-specified"
+ (choice string
+ function)))
+ :version "21.1"
+ :group 'vc)
+
+\f
+;;; Properties of the backend
+
+(defun vc-rcs-revision-granularity () 'file)
+
+(defun vc-rcs-checkout-model (files)
+ "RCS-specific version of `vc-checkout-model'."
+ (let ((file (if (consp files) (car files) files))
+ result)
+ (when vc-consult-headers
+ (vc-file-setprop file 'vc-checkout-model nil)
+ (vc-rcs-consult-headers file)
+ (setq result (vc-file-getprop file 'vc-checkout-model)))
+ (or result
+ (progn (vc-rcs-fetch-master-state file)
+ (vc-file-getprop file 'vc-checkout-model)))))
+
+;;;
+;;; State-querying functions
+;;;
+
+;; The autoload cookie below places vc-rcs-registered directly into
+;; loaddefs.el, so that vc-rcs.el does not need to be loaded for
+;; every file that is visited.
+;;;###autoload
+(progn
+(defun vc-rcs-registered (f) (vc-default-registered 'RCS f)))
+
+(defun vc-rcs-state (file)
+ "Implementation of `vc-state' for RCS."
+ (if (not (vc-rcs-registered file))
+ 'unregistered
+ (or (boundp 'vc-rcs-headers-result)
+ (and vc-consult-headers
+ (vc-rcs-consult-headers file)))
+ (let ((state
+ ;; vc-working-revision might not be known; in that case the
+ ;; property is nil. vc-rcs-fetch-master-state knows how to
+ ;; handle that.
+ (vc-rcs-fetch-master-state file
+ (vc-file-getprop file
+ 'vc-working-revision))))
+ (if (not (eq state 'up-to-date))
+ state
+ (if (vc-workfile-unchanged-p file)
+ 'up-to-date
+ (if (eq (vc-rcs-checkout-model (list file)) 'locking)
+ 'unlocked-changes
+ 'edited))))))
+
+(defun vc-rcs-state-heuristic (file)
+ "State heuristic for RCS."
+ (let (vc-rcs-headers-result)
+ (if (and vc-consult-headers
+ (setq vc-rcs-headers-result
+ (vc-rcs-consult-headers file))
+ (eq vc-rcs-headers-result 'rev-and-lock))
+ (let ((state (vc-file-getprop file 'vc-state)))
+ ;; If the headers say that the file is not locked, the
+ ;; permissions can tell us whether locking is used for
+ ;; the file or not.
+ (if (and (eq state 'up-to-date)
+ (not (vc-mistrust-permissions file))
+ (file-exists-p file))
+ (cond
+ ((string-match ".rw..-..-." (nth 8 (file-attributes file)))
+ (vc-file-setprop file 'vc-checkout-model 'implicit)
+ (setq state
+ (if (vc-rcs-workfile-is-newer file)
+ 'edited
+ 'up-to-date)))
+ ((string-match ".r-..-..-." (nth 8 (file-attributes file)))
+ (vc-file-setprop file 'vc-checkout-model 'locking))))
+ state)
+ (if (not (vc-mistrust-permissions file))
+ (let* ((attributes (file-attributes file 'string))
+ (owner-name (nth 2 attributes))
+ (permissions (nth 8 attributes)))
+ (cond ((and permissions (string-match ".r-..-..-." permissions))
+ (vc-file-setprop file 'vc-checkout-model 'locking)
+ 'up-to-date)
+ ((and permissions (string-match ".rw..-..-." permissions))
+ (if (eq (vc-rcs-checkout-model file) 'locking)
+ (if (file-ownership-preserved-p file)
+ 'edited
+ owner-name)
+ (if (vc-rcs-workfile-is-newer file)
+ 'edited
+ 'up-to-date)))
+ (t
+ ;; Strange permissions. Fall through to
+ ;; expensive state computation.
+ (vc-rcs-state file))))
+ (vc-rcs-state file)))))
+
+(defun vc-rcs-dir-status (dir update-function)
+ ;; FIXME: this function should be rewritten or `vc-expand-dirs'
+ ;; should be changed to take a backend parameter. Using
+ ;; `vc-expand-dirs' is not TRTD because it returns files from
+ ;; multiple backends. It should also return 'unregistered files.
+
+ ;; Doing individual vc-state calls is painful but there
+ ;; is no better way in RCS-land.
+ (let ((flist (vc-expand-dirs (list dir)))
+ (result nil))
+ (dolist (file flist)
+ (let ((state (vc-state file))
+ (frel (file-relative-name file)))
+ (when (and (eq (vc-backend file) 'RCS)
+ (not (eq state 'up-to-date)))
+ (push (list frel state) result))))
+ (funcall update-function result)))
+
+(defun vc-rcs-working-revision (file)
+ "RCS-specific version of `vc-working-revision'."
+ (or (and vc-consult-headers
+ (vc-rcs-consult-headers file)
+ (vc-file-getprop file 'vc-working-revision))
+ (progn
+ (vc-rcs-fetch-master-state file)
+ (vc-file-getprop file 'vc-working-revision))))
+
+(defun vc-rcs-latest-on-branch-p (file &optional version)
+ "Return non-nil if workfile version of FILE is the latest on its branch.
+When VERSION is given, perform check for that version."
+ (unless version (setq version (vc-working-revision file)))
+ (with-temp-buffer
+ (string= version
+ (if (vc-rcs-trunk-p version)
+ (progn
+ ;; Compare VERSION to the head version number.
+ (vc-insert-file (vc-name file) "^[0-9]")
+ (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
+ ;; If we are not on the trunk, we need to examine the
+ ;; whole current branch.
+ (vc-insert-file (vc-name file) "^desc")
+ (vc-rcs-find-most-recent-rev (vc-branch-part version))))))
+
+(defun vc-rcs-workfile-unchanged-p (file)
+ "RCS-specific implementation of `vc-workfile-unchanged-p'."
+ ;; Try to use rcsdiff --brief. If rcsdiff does not understand that,
+ ;; do a double take and remember the fact for the future
+ (let* ((version (concat "-r" (vc-working-revision file)))
+ (status (if (eq vc-rcsdiff-knows-brief 'no)
+ (vc-do-command "*vc*" 1 "rcsdiff" file version)
+ (vc-do-command "*vc*" 2 "rcsdiff" file "--brief" version))))
+ (if (eq status 2)
+ (if (not vc-rcsdiff-knows-brief)
+ (setq vc-rcsdiff-knows-brief 'no
+ status (vc-do-command "*vc*" 1 "rcsdiff" file version))
+ (error "rcsdiff failed"))
+ (if (not vc-rcsdiff-knows-brief) (setq vc-rcsdiff-knows-brief 'yes)))
+ ;; The workfile is unchanged if rcsdiff found no differences.
+ (zerop status)))
+
+\f
+;;;
+;;; State-changing functions
+;;;
+
+(defun vc-rcs-create-repo ()
+ "Create a new RCS repository."
+ ;; RCS is totally file-oriented, so all we have to do is make the directory.
+ (make-directory "RCS"))
+
+(defun vc-rcs-register (files &optional rev comment)
+ "Register FILES into the RCS version-control system.
+REV is the optional revision number for the files. COMMENT can be used
+to provide an initial description for each FILES.
+Passes either `vc-rcs-register-switches' or `vc-register-switches'
+to the RCS command.
+
+Automatically retrieve a read-only version of the file with keywords
+expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
+ (let (subdir name)
+ ;; When REV is specified, we need to force using "-t-".
+ (when rev (unless comment (setq comment "")))
+ (dolist (file files)
+ (and (not (file-exists-p
+ (setq subdir (expand-file-name "RCS"
+ (file-name-directory file)))))
+ (not (directory-files (file-name-directory file)
+ nil ".*,v$" t))
+ (yes-or-no-p "Create RCS subdirectory? ")
+ (make-directory subdir))
+ (apply 'vc-do-command "*vc*" 0 "ci" file
+ ;; if available, use the secure registering option
+ (and (vc-rcs-release-p "5.6.4") "-i")
+ (concat (if vc-keep-workfiles "-u" "-r") rev)
+ (and comment (concat "-t-" comment))
+ (vc-switches 'RCS 'register))
+ ;; parse output to find master file name and workfile version
+ (with-current-buffer "*vc*"
+ (goto-char (point-min))
+ (if (not (setq name
+ (if (looking-at (concat "^\\(.*\\) <-- "
+ (file-name-nondirectory file)))
+ (match-string 1))))
+ ;; if we couldn't find the master name,
+ ;; run vc-rcs-registered to get it
+ ;; (will be stored into the vc-name property)
+ (vc-rcs-registered file)
+ (vc-file-setprop file 'vc-name
+ (if (file-name-absolute-p name)
+ name
+ (expand-file-name
+ name
+ (file-name-directory file))))))
+ (vc-file-setprop file 'vc-working-revision
+ (if (re-search-forward
+ "^initial revision: \\([0-9.]+\\).*\n"
+ nil t)
+ (match-string 1))))))
+
+(defun vc-rcs-responsible-p (file)
+ "Return non-nil if RCS thinks it would be responsible for registering FILE."
+ ;; TODO: check for all the patterns in vc-rcs-master-templates
+ (file-directory-p (expand-file-name "RCS" (file-name-directory file))))
+
+(defun vc-rcs-receive-file (file rev)
+ "Implementation of receive-file for RCS."
+ (let ((checkout-model (vc-rcs-checkout-model (list file))))
+ (vc-rcs-register file rev "")
+ (when (eq checkout-model 'implicit)
+ (vc-rcs-set-non-strict-locking file))
+ (vc-rcs-set-default-branch file (concat rev ".1"))))
+
+(defun vc-rcs-unregister (file)
+ "Unregister FILE from RCS.
+If this leaves the RCS subdirectory empty, ask the user
+whether to remove it."
+ (let* ((master (vc-name file))
+ (dir (file-name-directory master))
+ (backup-info (find-backup-file-name master)))
+ (if (not backup-info)
+ (delete-file master)
+ (rename-file master (car backup-info) 'ok-if-already-exists)
+ (dolist (f (cdr backup-info)) (ignore-errors (delete-file f))))
+ (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS")
+ ;; check whether RCS dir is empty, i.e. it does not
+ ;; contain any files except "." and ".."
+ (not (directory-files dir nil
+ "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*"))
+ (yes-or-no-p (format "Directory %s is empty; remove it? " dir))
+ (delete-directory dir))))
+
+(defun vc-rcs-checkin (files rev comment &optional extra-args-ignored)
+ "RCS-specific version of `vc-backend-checkin'."
+ (let ((switches (vc-switches 'RCS 'checkin)))
+ ;; Now operate on the files
+ (dolist (file (vc-expand-dirs files))
+ (let ((old-version (vc-working-revision file)) new-version
+ (default-branch (vc-file-getprop file 'vc-rcs-default-branch)))
+ ;; Force branch creation if an appropriate
+ ;; default branch has been set.
+ (and (not rev)
+ default-branch
+ (string-match (concat "^" (regexp-quote old-version) "\\.")
+ default-branch)
+ (setq rev default-branch)
+ (setq switches (cons "-f" switches)))
+ (if (and (not rev) old-version)
+ (setq rev (vc-branch-part old-version)))
+ (apply 'vc-do-command "*vc*" 0 "ci" (vc-name file)
+ ;; if available, use the secure check-in option
+ (and (vc-rcs-release-p "5.6.4") "-j")
+ (concat (if vc-keep-workfiles "-u" "-r") rev)
+ (concat "-m" comment)
+ switches)
+ (vc-file-setprop file 'vc-working-revision nil)
+
+ ;; determine the new workfile version
+ (set-buffer "*vc*")
+ (goto-char (point-min))
+ (when (or (re-search-forward
+ "new revision: \\([0-9.]+\\);" nil t)
+ (re-search-forward
+ "reverting to previous revision \\([0-9.]+\\)" nil t))
+ (setq new-version (match-string 1))
+ (vc-file-setprop file 'vc-working-revision new-version))
+
+ ;; if we got to a different branch, adjust the default
+ ;; branch accordingly
+ (cond
+ ((and old-version new-version
+ (not (string= (vc-branch-part old-version)
+ (vc-branch-part new-version))))
+ (vc-rcs-set-default-branch file
+ (if (vc-rcs-trunk-p new-version) nil
+ (vc-branch-part new-version)))
+ ;; If this is an old RCS release, we might have
+ ;; to remove a remaining lock.
+ (if (not (vc-rcs-release-p "5.6.2"))
+ ;; exit status of 1 is also accepted.
+ ;; It means that the lock was removed before.
+ (vc-do-command "*vc*" 1 "rcs" (vc-name file)
+ (concat "-u" old-version)))))))))
+
+(defun vc-rcs-find-revision (file rev buffer)
+ (apply 'vc-do-command
+ (or buffer "*vc*") 0 "co" (vc-name file)
+ "-q" ;; suppress diagnostic output
+ (concat "-p" rev)
+ (vc-switches 'RCS 'checkout)))
+
+(defun vc-rcs-checkout (file &optional editable rev)
+ "Retrieve a copy of a saved version of FILE. If FILE is a directory,
+attempt the checkout for all registered files beneath it."
+ (if (file-directory-p file)
+ (mapc 'vc-rcs-checkout (vc-expand-dirs (list file)))
+ (let ((file-buffer (get-file-buffer file))
+ switches)
+ (message "Checking out %s..." file)
+ (save-excursion
+ ;; Change buffers to get local value of vc-checkout-switches.
+ (if file-buffer (set-buffer file-buffer))
+ (setq switches (vc-switches 'RCS 'checkout))
+ ;; Save this buffer's default-directory
+ ;; and use save-excursion to make sure it is restored
+ ;; in the same buffer it was saved in.
+ (let ((default-directory default-directory))
+ (save-excursion
+ ;; Adjust the default-directory so that the check-out creates
+ ;; the file in the right place.
+ (setq default-directory (file-name-directory file))
+ (let (new-version)
+ ;; if we should go to the head of the trunk,
+ ;; clear the default branch first
+ (and rev (string= rev "")
+ (vc-rcs-set-default-branch file nil))
+ ;; now do the checkout
+ (apply 'vc-do-command
+ "*vc*" 0 "co" (vc-name file)
+ ;; If locking is not strict, force to overwrite
+ ;; the writable workfile.
+ (if (eq (vc-rcs-checkout-model (list file)) 'implicit) "-f")
+ (if editable "-l")
+ (if (stringp rev)
+ ;; a literal revision was specified
+ (concat "-r" rev)
+ (let ((workrev (vc-working-revision file)))
+ (if workrev
+ (concat "-r"
+ (if (not rev)
+ ;; no revision specified:
+ ;; use current workfile version
+ workrev
+ ;; REV is t ...
+ (if (not (vc-rcs-trunk-p workrev))
+ ;; ... go to head of current branch
+ (vc-branch-part workrev)
+ ;; ... go to head of trunk
+ (vc-rcs-set-default-branch file
+ nil)
+ ""))))))
+ switches)
+ ;; determine the new workfile version
+ (with-current-buffer "*vc*"
+ (setq new-version
+ (vc-parse-buffer "^revision \\([0-9.]+\\).*\n" 1)))
+ (vc-file-setprop file 'vc-working-revision new-version)
+ ;; if necessary, adjust the default branch
+ (and rev (not (string= rev ""))
+ (vc-rcs-set-default-branch
+ file
+ (if (vc-rcs-latest-on-branch-p file new-version)
+ (if (vc-rcs-trunk-p new-version) nil
+ (vc-branch-part new-version))
+ new-version)))))
+ (message "Checking out %s...done" file))))))
+
+(defun vc-rcs-rollback (files)
+ "Roll back, undoing the most recent checkins of FILES. Directories are
+expanded to all registered subfiles in them."
+ (if (not files)
+ (error "RCS backend doesn't support directory-level rollback"))
+ (dolist (file (vc-expand-dirs files))
+ (let* ((discard (vc-working-revision file))
+ (previous (if (vc-rcs-trunk-p discard) "" (vc-branch-part discard)))
+ (config (current-window-configuration))
+ (done nil))
+ (if (null (yes-or-no-p (format "Remove version %s from %s history? "
+ discard file)))
+ (error "Aborted"))
+ (message "Removing revision %s from %s." discard file)
+ (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-o" discard))
+ ;; Check out the most recent remaining version. If it
+ ;; fails, because the whole branch got deleted, do a
+ ;; double-take and check out the version where the branch
+ ;; started.
+ (while (not done)
+ (condition-case err
+ (progn
+ (vc-do-command "*vc*" 0 "co" (vc-name file) "-f"
+ (concat "-u" previous))
+ (setq done t))
+ (error (set-buffer "*vc*")
+ (goto-char (point-min))
+ (if (search-forward "no side branches present for" nil t)
+ (progn (setq previous (vc-branch-part previous))
+ (vc-rcs-set-default-branch file previous)
+ ;; vc-do-command popped up a window with
+ ;; the error message. Get rid of it, by
+ ;; restoring the old window configuration.
+ (set-window-configuration config))
+ ;; No, it was some other error: re-signal it.
+ (signal (car err) (cdr err)))))))))
+
+(defun vc-rcs-revert (file &optional contents-done)
+ "Revert FILE to the version it was based on. If FILE is a directory,
+revert all registered files beneath it."
+ (if (file-directory-p file)
+ (mapc 'vc-rcs-revert (vc-expand-dirs (list file)))
+ (vc-do-command "*vc*" 0 "co" (vc-name file) "-f"
+ (concat (if (eq (vc-state file) 'edited) "-u" "-r")
+ (vc-working-revision file)))))
+
+(defun vc-rcs-merge (file first-version &optional second-version)
+ "Merge changes into current working copy of FILE.
+The changes are between FIRST-VERSION and SECOND-VERSION."
+ (vc-do-command "*vc*" 1 "rcsmerge" (vc-name file)
+ "-kk" ; ignore keyword conflicts
+ (concat "-r" first-version)
+ (if second-version (concat "-r" second-version))))
+
+(defun vc-rcs-steal-lock (file &optional rev)
+ "Steal the lock on the current workfile for FILE and revision REV.
+If FILE is a directory, steal the lock on all registered files beneath it.
+Needs RCS 5.6.2 or later for -M."
+ (if (file-directory-p file)
+ (mapc 'vc-rcs-steal-lock (vc-expand-dirs (list file)))
+ (vc-do-command "*vc*" 0 "rcs" (vc-name file) "-M" (concat "-u" rev))
+ ;; Do a real checkout after stealing the lock, so that we see
+ ;; expanded headers.
+ (vc-do-command "*vc*" 0 "co" (vc-name file) "-f" (concat "-l" rev))))
+
+(defun vc-rcs-modify-change-comment (files rev comment)
+ "Modify the change comments change on FILES on a specified REV. If FILE is a
+directory the operation is applied to all registered files beneath it."
+ (dolist (file (vc-expand-dirs files))
+ (vc-do-command "*vc*" 0 "rcs" (vc-name file)
+ (concat "-m" rev ":" comment))))
+
+\f
+;;;
+;;; History functions
+;;;
+
+(defun vc-rcs-print-log-cleanup ()
+ (let ((inhibit-read-only t))
+ (goto-char (point-max))
+ (forward-line -1)
+ (while (looking-at "=*\n")
+ (delete-char (- (match-end 0) (match-beginning 0)))
+ (forward-line -1))
+ (goto-char (point-min))
+ (when (looking-at "[\b\t\n\v\f\r ]+")
+ (delete-char (- (match-end 0) (match-beginning 0))))))
+
+(defun vc-rcs-print-log (files buffer &optional shortlog start-revision-ignored limit)
+ "Get change log associated with FILE. If FILE is a
+directory the operation is applied to all registered files beneath it."
+ (vc-do-command (or buffer "*vc*") 0 "rlog" (mapcar 'vc-name (vc-expand-dirs files)))
+ (with-current-buffer (or buffer "*vc*")
+ (vc-rcs-print-log-cleanup))
+ (when limit 'limit-unsupported))
+
+(defun vc-rcs-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using RCS between two sets of files."
+ (apply 'vc-do-command (or buffer "*vc-diff*")
+ 1 ;; Always go synchronous, the repo is local
+ "rcsdiff" (vc-expand-dirs files)
+ (append (list "-q"
+ (and oldvers (concat "-r" oldvers))
+ (and newvers (concat "-r" newvers)))
+ (vc-switches 'RCS 'diff))))
+
+(defun vc-rcs-comment-history (file)
+ "Return a string with all log entries stored in BACKEND for FILE."
+ (with-current-buffer "*vc*"
+ ;; Has to be written this way, this function is used by the CVS backend too
+ (vc-call-backend (vc-backend file) 'print-log (list file))
+ ;; Remove cruft
+ (let ((separator (concat "^-+\nrevision [0-9.]+\ndate: .*\n"
+ "\\(branches: .*;\n\\)?"
+ "\\(\\*\\*\\* empty log message \\*\\*\\*\n\\)?")))
+ (goto-char (point-max)) (forward-line -1)
+ (while (looking-at "=*\n")
+ (delete-char (- (match-end 0) (match-beginning 0)))
+ (forward-line -1))
+ (goto-char (point-min))
+ (if (looking-at "[\b\t\n\v\f\r ]+")
+ (delete-char (- (match-end 0) (match-beginning 0))))
+ (goto-char (point-min))
+ (re-search-forward separator nil t)
+ (delete-region (point-min) (point))
+ (while (re-search-forward separator nil t)
+ (delete-region (match-beginning 0) (match-end 0))))
+ ;; Return the de-crufted comment list
+ (buffer-string)))
+
+(defun vc-rcs-annotate-command (file buffer &optional revision)
+ "Annotate FILE, inserting the results in BUFFER.
+Optional arg REVISION is a revision to annotate from."
+ (vc-setup-buffer buffer)
+ ;; Aside from the "head revision on the trunk", the instructions for
+ ;; each revision on the trunk are an ordered list of kill and insert
+ ;; commands necessary to go from the chronologically-following
+ ;; revision to this one. That is, associated with revision N are
+ ;; edits that applied to revision N+1 would result in revision N.
+ ;;
+ ;; On a branch, however, (some) things are inverted: the commands
+ ;; listed are those necessary to go from the chronologically-preceding
+ ;; revision to this one. That is, associated with revision N are
+ ;; edits that applied to revision N-1 would result in revision N.
+ ;;
+ ;; So, to get per-line history info, we apply reverse-chronological
+ ;; edits, starting with the head revision on the trunk, all the way
+ ;; back through the initial revision (typically "1.1" or similar),
+ ;; then apply forward-chronological edits -- keeping track of which
+ ;; revision is associated with each inserted line -- until we reach
+ ;; the desired revision for display (which may be either on the trunk
+ ;; or on a branch).
+ (let* ((tree (with-temp-buffer
+ (insert-file-contents (vc-rcs-registered file))
+ (vc-rcs-parse)))
+ (revisions (cdr (assq 'revisions tree)))
+ ;; The revision N whose instructions we currently are processing.
+ (cur (cdr (assq 'head (cdr (assq 'headers tree)))))
+ ;; Alist from the parse tree for N.
+ (meta (cdr (assoc cur revisions)))
+ ;; Point and temporary string, respectively.
+ p s
+ ;; "Next-branch list". Nil means the desired revision to
+ ;; display lives on the trunk. Non-nil means it lives on a
+ ;; branch, in which case the value is a list of revision pairs
+ ;; (PARENT . CHILD), the first PARENT being on the trunk, that
+ ;; links each series of revisions in the path from the initial
+ ;; revision to the desired revision to display.
+ nbls
+ ;; "Path-accumulate-predicate plus revision/date/author".
+ ;; Until set, forward-chronological edits are not accumulated.
+ ;; Once set, its value (updated every revision) is used for
+ ;; the text property `:vc-rcs-r/d/a' for inserts during
+ ;; processing of forward-chronological instructions for N.
+ ;; See internal func `r/d/a'.
+ prda
+ ;; List of forward-chronological instructions, each of the
+ ;; form: (POS . ACTION), where POS is a buffer position. If
+ ;; ACTION is a string, it is inserted, otherwise it is taken as
+ ;; the number of characters to be deleted.
+ path
+ ;; N+1. When `cur' is "", this is the initial revision.
+ pre)
+ (unless revision
+ (setq revision cur))
+ (unless (assoc revision revisions)
+ (error "No such revision: %s" revision))
+ ;; Find which branches (if any) must be included in the edits.
+ (let ((par revision)
+ bpt kids)
+ (while (setq bpt (vc-branch-part par)
+ par (vc-branch-part bpt))
+ (setq kids (cdr (assq 'branches (cdr (assoc par revisions)))))
+ ;; A branchpoint may have multiple children. Find the right one.
+ (while (not (string= bpt (vc-branch-part (car kids))))
+ (setq kids (cdr kids)))
+ (push (cons par (car kids)) nbls)))
+ ;; Start with the full text.
+ (set-buffer buffer)
+ (insert (cdr (assq 'text meta)))
+ ;; Apply reverse-chronological edits on the trunk, computing and
+ ;; accumulating forward-chronological edits after some point, for
+ ;; later.
+ (flet ((r/d/a () (vector pre
+ (cdr (assq 'date meta))
+ (cdr (assq 'author meta)))))
+ (while (when (setq pre cur cur (cdr (assq 'next meta)))
+ (not (string= "" cur)))
+ (setq
+ ;; Start accumulating the forward-chronological edits when N+1
+ ;; on the trunk is either the desired revision to display, or
+ ;; the appropriate branchpoint for it. Do this before
+ ;; updating `meta' since `r/d/a' uses N+1's `meta' value.
+ prda (when (or prda (string= (if nbls (caar nbls) revision) pre))
+ (r/d/a))
+ meta (cdr (assoc cur revisions)))
+ ;; Edits in the parse tree specify a line number (in the buffer
+ ;; *BEFORE* editing occurs) to start from, but line numbers
+ ;; change as a result of edits. To DTRT, we apply edits in
+ ;; order of descending buffer position so that edits further
+ ;; down in the buffer occur first w/o corrupting specified
+ ;; buffer positions of edits occurring towards the beginning of
+ ;; the buffer. In this way we avoid using markers. A pleasant
+ ;; property of this approach is ability to push instructions
+ ;; onto `path' directly, w/o need to maintain rev boundaries.
+ (dolist (insn (cdr (assq :insn meta)))
+ (goto-char (point-min))
+ (forward-line (1- (pop insn)))
+ (setq p (point))
+ (case (pop insn)
+ (k (setq s (buffer-substring-no-properties
+ p (progn (forward-line (car insn))
+ (point))))
+ (when prda
+ (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path))
+ (delete-region p (point)))
+ (i (setq s (car insn))
+ (when prda
+ (push `(,p . ,(length s)) path))
+ (insert s)))))
+ ;; For the initial revision, setting `:vc-rcs-r/d/a' directly is
+ ;; equivalent to pushing an insert instruction (of the entire buffer
+ ;; contents) onto `path' then erasing the buffer, but less wasteful.
+ (put-text-property (point-min) (point-max) :vc-rcs-r/d/a (r/d/a))
+ ;; Now apply the forward-chronological edits for the trunk.
+ (dolist (insn path)
+ (goto-char (pop insn))
+ (if (stringp insn)
+ (insert insn)
+ (delete-char insn)))
+ ;; Now apply the forward-chronological edits (directly from the
+ ;; parse-tree) for the branch(es), if necessary. We re-use vars
+ ;; `pre' and `meta' for the sake of internal func `r/d/a'.
+ (while nbls
+ (setq pre (cdr (pop nbls)))
+ (while (progn
+ (setq meta (cdr (assoc pre revisions))
+ prda nil)
+ (dolist (insn (cdr (assq :insn meta)))
+ (goto-char (point-min))
+ (forward-line (1- (pop insn)))
+ (case (pop insn)
+ (k (delete-region
+ (point) (progn (forward-line (car insn))
+ (point))))
+ (i (insert (propertize
+ (car insn)
+ :vc-rcs-r/d/a
+ (or prda (setq prda (r/d/a))))))))
+ (prog1 (not (string= (if nbls (caar nbls) revision) pre))
+ (setq pre (cdr (assq 'next meta)))))))))
+ ;; Lastly, for each line, insert at bol nicely-formatted history info.
+ ;; We do two passes to collect summary information used to minimize
+ ;; the annotation's usage of screen real-estate: (1) Consider rendered
+ ;; width of revision plus author together as a unit; and (2) Omit
+ ;; author entirely if all authors are the same as the user.
+ (let ((ht (make-hash-table :test 'eq))
+ (me (user-login-name))
+ (maxw 0)
+ (all-me t)
+ rda w a)
+ (goto-char (point-max))
+ (while (not (bobp))
+ (forward-line -1)
+ (setq rda (get-text-property (point) :vc-rcs-r/d/a))
+ (unless (gethash rda ht)
+ (setq a (aref rda 2)
+ all-me (and all-me (string= a me)))
+ (puthash rda (setq w (+ (length (aref rda 0))
+ (length a)))
+ ht)
+ (setq maxw (max w maxw))))
+ (let ((padding (make-string maxw 32)))
+ (flet ((pad (w) (substring-no-properties padding w))
+ (render (rda &rest ls)
+ (propertize
+ (apply 'concat
+ (format-time-string "%Y-%m-%d" (aref rda 1))
+ " "
+ (aref rda 0)
+ ls)
+ :vc-annotate-prefix t
+ :vc-rcs-r/d/a rda)))
+ (maphash
+ (if all-me
+ (lambda (rda w)
+ (puthash rda (render rda (pad w) ": ") ht))
+ (lambda (rda w)
+ (puthash rda (render rda " " (pad w) " " (aref rda 2) ": ") ht)))
+ ht)))
+ (while (not (eobp))
+ (insert (gethash (get-text-property (point) :vc-rcs-r/d/a) ht))
+ (forward-line 1))))
+
+(declare-function vc-annotate-convert-time "vc-annotate" (time))
+
+(defun vc-rcs-annotate-current-time ()
+ "Return the current time, based at midnight of the current day, and
+encoded as fractional days."
+ (vc-annotate-convert-time
+ (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time))))))
+
+(defun vc-rcs-annotate-time ()
+ "Return the time of the next annotation (as fraction of days)
+systime, or nil if there is none. Also, reposition point."
+ (unless (eobp)
+ (prog1 (vc-annotate-convert-time
+ (aref (get-text-property (point) :vc-rcs-r/d/a) 1))
+ (goto-char (next-single-property-change (point) :vc-annotate-prefix)))))
+
+(defun vc-rcs-annotate-extract-revision-at-line ()
+ (aref (get-text-property (point) :vc-rcs-r/d/a) 0))
+
+\f
+;;;
+;;; Tag system
+;;;
+
+(defun vc-rcs-create-tag (backend dir name branchp)
+ (when branchp
+ (error "RCS backend %s does not support module branches" backend))
+ (let ((result (vc-tag-precondition dir)))
+ (if (stringp result)
+ (error "File %s is not up-to-date" result)
+ (vc-file-tree-walk
+ dir
+ (lambda (f)
+ (vc-do-command "*vc*" 0 "rcs" (vc-name f) (concat "-n" name ":")))))))
+
+\f
+;;;
+;;; Miscellaneous
+;;;
+
+(defun vc-rcs-trunk-p (rev)
+ "Return t if REV is a revision on the trunk."
+ (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev))))
+
+(defun vc-rcs-minor-part (rev)
+ "Return the minor revision number of a revision number REV."
+ (string-match "[0-9]+\\'" rev)
+ (substring rev (match-beginning 0) (match-end 0)))
+
+(defun vc-rcs-previous-revision (file rev)
+ "Return the revision number immediately preceding REV for FILE,
+or nil if there is no previous revision. This default
+implementation works for MAJOR.MINOR-style revision numbers as
+used by RCS and CVS."
+ (let ((branch (vc-branch-part rev))
+ (minor-num (string-to-number (vc-rcs-minor-part rev))))
+ (when branch
+ (if (> minor-num 1)
+ ;; revision does probably not start a branch or release
+ (concat branch "." (number-to-string (1- minor-num)))
+ (if (vc-rcs-trunk-p rev)
+ ;; we are at the beginning of the trunk --
+ ;; don't know anything to return here
+ nil
+ ;; we are at the beginning of a branch --
+ ;; return revision of starting point
+ (vc-branch-part branch))))))
+
+(defun vc-rcs-next-revision (file rev)
+ "Return the revision number immediately following REV for FILE,
+or nil if there is no next revision. This default implementation
+works for MAJOR.MINOR-style revision numbers as used by RCS
+and CVS."
+ (when (not (string= rev (vc-working-revision file)))
+ (let ((branch (vc-branch-part rev))
+ (minor-num (string-to-number (vc-rcs-minor-part rev))))
+ (concat branch "." (number-to-string (1+ minor-num))))))
+
+(defun vc-rcs-update-changelog (files)
+ "Default implementation of update-changelog.
+Uses `rcs2log' which only works for RCS and CVS."
+ ;; FIXME: We (c|sh)ould add support for cvs2cl
+ (let ((odefault default-directory)
+ (changelog (find-change-log))
+ ;; Presumably not portable to non-Unixy systems, along with rcs2log:
+ (tempfile (make-temp-file
+ (expand-file-name "vc"
+ (or small-temporary-file-directory
+ temporary-file-directory))))
+ (login-name (or user-login-name
+ (format "uid%d" (number-to-string (user-uid)))))
+ (full-name (or add-log-full-name
+ (user-full-name)
+ (user-login-name)
+ (format "uid%d" (number-to-string (user-uid)))))
+ (mailing-address (or add-log-mailing-address
+ user-mail-address)))
+ (find-file-other-window changelog)
+ (barf-if-buffer-read-only)
+ (vc-buffer-sync)
+ (undo-boundary)
+ (goto-char (point-min))
+ (push-mark)
+ (message "Computing change log entries...")
+ (message "Computing change log entries... %s"
+ (unwind-protect
+ (progn
+ (setq default-directory odefault)
+ (if (eq 0 (apply 'call-process
+ (expand-file-name "rcs2log"
+ exec-directory)
+ nil (list t tempfile) nil
+ "-c" changelog
+ "-u" (concat login-name
+ "\t" full-name
+ "\t" mailing-address)
+ (mapcar
+ (lambda (f)
+ (file-relative-name
+ (expand-file-name f odefault)))
+ files)))
+ "done"
+ (pop-to-buffer (get-buffer-create "*vc*"))
+ (erase-buffer)
+ (insert-file-contents tempfile)
+ "failed"))
+ (setq default-directory (file-name-directory changelog))
+ (delete-file tempfile)))))
+
+(defun vc-rcs-check-headers ()
+ "Check if the current file has any headers in it."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))
+
+(defun vc-rcs-clear-headers ()
+ "Implementation of vc-clear-headers for RCS."
+ (let ((case-fold-search nil))
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|"
+ "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$")
+ nil t)
+ (replace-match "$\\1$"))))
+
+(defun vc-rcs-rename-file (old new)
+ ;; Just move the master file (using vc-rcs-master-templates).
+ (vc-rename-master (vc-name old) new vc-rcs-master-templates))
+
+(defun vc-rcs-find-file-hook ()
+ ;; If the file is locked by some other user, make
+ ;; the buffer read-only. Like this, even root
+ ;; cannot modify a file that someone else has locked.
+ (and (stringp (vc-state buffer-file-name 'RCS))
+ (setq buffer-read-only t)))
+
+\f
+;;;
+;;; Internal functions
+;;;
+
+(defun vc-rcs-workfile-is-newer (file)
+ "Return non-nil if FILE is newer than its RCS master.
+This likely means that FILE has been changed with respect
+to its master version."
+ (let ((file-time (nth 5 (file-attributes file)))
+ (master-time (nth 5 (file-attributes (vc-name file)))))
+ (or (> (nth 0 file-time) (nth 0 master-time))
+ (and (= (nth 0 file-time) (nth 0 master-time))
+ (> (nth 1 file-time) (nth 1 master-time))))))
+
+(defun vc-rcs-find-most-recent-rev (branch)
+ "Find most recent revision on BRANCH."
+ (goto-char (point-min))
+ (let ((latest-rev -1) value)
+ (while (re-search-forward (concat "^\\(" (regexp-quote branch)
+ "\\.\\([0-9]+\\)\\)\ndate[ \t]+[0-9.]+;")
+ nil t)
+ (let ((rev (string-to-number (match-string 2))))
+ (when (< latest-rev rev)
+ (setq latest-rev rev)
+ (setq value (match-string 1)))))
+ (or value
+ (vc-branch-part branch))))
+
+(defun vc-rcs-fetch-master-state (file &optional working-revision)
+ "Compute the master file's idea of the state of FILE.
+If a WORKING-REVISION is given, compute the state of that version,
+otherwise determine the workfile version based on the master file.
+This function sets the properties `vc-working-revision' and
+`vc-checkout-model' to their correct values, based on the master
+file."
+ (with-temp-buffer
+ (if (or (not (vc-insert-file (vc-name file) "^[0-9]"))
+ (progn (goto-char (point-min))
+ (not (looking-at "^head[ \t\n]+[^;]+;$"))))
+ (error "File %s is not an RCS master file" (vc-name file)))
+ (let ((workfile-is-latest nil)
+ (default-branch (vc-parse-buffer "^branch[ \t\n]+\\([^;]*\\);" 1)))
+ (vc-file-setprop file 'vc-rcs-default-branch default-branch)
+ (unless working-revision
+ ;; Workfile version not known yet. Determine that first. It
+ ;; is either the head of the trunk, the head of the default
+ ;; branch, or the "default branch" itself, if that is a full
+ ;; revision number.
+ (cond
+ ;; no default branch
+ ((or (not default-branch) (string= "" default-branch))
+ (setq working-revision
+ (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
+ (setq workfile-is-latest t))
+ ;; default branch is actually a revision
+ ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$"
+ default-branch)
+ (setq working-revision default-branch))
+ ;; else, search for the head of the default branch
+ (t (vc-insert-file (vc-name file) "^desc")
+ (setq working-revision
+ (vc-rcs-find-most-recent-rev default-branch))
+ (setq workfile-is-latest t)))
+ (vc-file-setprop file 'vc-working-revision working-revision))
+ ;; Check strict locking
+ (goto-char (point-min))
+ (vc-file-setprop file 'vc-checkout-model
+ (if (re-search-forward ";[ \t\n]*strict;" nil t)
+ 'locking 'implicit))
+ ;; Compute state of workfile version
+ (goto-char (point-min))
+ (let ((locking-user
+ (vc-parse-buffer (concat "^locks[ \t\n]+[^;]*[ \t\n]+\\([^:]+\\):"
+ (regexp-quote working-revision)
+ "[^0-9.]")
+ 1)))
+ (cond
+ ;; not locked
+ ((not locking-user)
+ (if (or workfile-is-latest
+ (vc-rcs-latest-on-branch-p file working-revision))
+ ;; workfile version is latest on branch
+ 'up-to-date
+ ;; workfile version is not latest on branch
+ 'needs-update))
+ ;; locked by the calling user
+ ((and (stringp locking-user)
+ (string= locking-user (vc-user-login-name file)))
+ ;; Don't call `vc-rcs-checkout-model' to avoid inf-looping.
+ (if (or (eq (vc-file-getprop file 'vc-checkout-model) 'locking)
+ workfile-is-latest
+ (vc-rcs-latest-on-branch-p file working-revision))
+ 'edited
+ ;; Locking is not used for the file, but the owner does
+ ;; have a lock, and there is a higher version on the current
+ ;; branch. Not sure if this can occur, and if it is right
+ ;; to use `needs-merge' in this case.
+ 'needs-merge))
+ ;; locked by somebody else
+ ((stringp locking-user)
+ locking-user)
+ (t
+ (error "Error getting state of RCS file")))))))
+
+(defun vc-rcs-consult-headers (file)
+ "Search for RCS headers in FILE, and set properties accordingly.
+
+Returns: nil if no headers were found
+ 'rev if a workfile revision was found
+ 'rev-and-lock if revision and lock info was found"
+ (cond
+ ((not (get-file-buffer file)) nil)
+ ((let (status version locking-user)
+ (with-current-buffer (get-file-buffer file)
+ (save-excursion
+ (goto-char (point-min))
+ (cond
+ ;; search for $Id or $Header
+ ;; -------------------------
+ ;; The `\ 's below avoid an RCS 5.7 bug when checking in this file.
+ ((or (and (search-forward "$Id\ : " nil t)
+ (looking-at "[^ ]+ \\([0-9.]+\\) "))
+ (and (progn (goto-char (point-min))
+ (search-forward "$Header\ : " nil t))
+ (looking-at "[^ ]+ \\([0-9.]+\\) ")))
+ (goto-char (match-end 0))
+ ;; if found, store the revision number ...
+ (setq version (match-string-no-properties 1))
+ ;; ... and check for the locking state
+ (cond
+ ((looking-at
+ (concat "[0-9]+[/-][01][0-9][/-][0-3][0-9] " ; date
+ "[0-2][0-9]:[0-5][0-9]+:[0-6][0-9]+\\([+-][0-9:]+\\)? " ; time
+ "[^ ]+ [^ ]+ ")) ; author & state
+ (goto-char (match-end 0)) ; [0-6] in regexp handles leap seconds
+ (cond
+ ;; unlocked revision
+ ((looking-at "\\$")
+ (setq locking-user 'none)
+ (setq status 'rev-and-lock))
+ ;; revision is locked by some user
+ ((looking-at "\\([^ ]+\\) \\$")
+ (setq locking-user (match-string-no-properties 1))
+ (setq status 'rev-and-lock))
+ ;; everything else: false
+ (nil)))
+ ;; unexpected information in
+ ;; keyword string --> quit
+ (nil)))
+ ;; search for $Revision
+ ;; --------------------
+ ((re-search-forward (concat "\\$"
+ "Revision: \\([0-9.]+\\) \\$")
+ nil t)
+ ;; if found, store the revision number ...
+ (setq version (match-string-no-properties 1))
+ ;; and see if there's any lock information
+ (goto-char (point-min))
+ (if (re-search-forward (concat "\\$" "Locker:") nil t)
+ (cond ((looking-at " \\([^ ]+\\) \\$")
+ (setq locking-user (match-string-no-properties 1))
+ (setq status 'rev-and-lock))
+ ((looking-at " *\\$")
+ (setq locking-user 'none)
+ (setq status 'rev-and-lock))
+ (t
+ (setq locking-user 'none)
+ (setq status 'rev-and-lock)))
+ (setq status 'rev)))
+ ;; else: nothing found
+ ;; -------------------
+ (t nil))))
+ (if status (vc-file-setprop file 'vc-working-revision version))
+ (and (eq status 'rev-and-lock)
+ (vc-file-setprop file 'vc-state
+ (cond
+ ((eq locking-user 'none) 'up-to-date)
+ ((string= locking-user (vc-user-login-name file))
+ 'edited)
+ (t locking-user)))
+ ;; If the file has headers, we don't want to query the
+ ;; master file, because that would eliminate all the
+ ;; performance gain the headers brought us. We therefore
+ ;; use a heuristic now to find out whether locking is used
+ ;; for this file. If we trust the file permissions, and the
+ ;; file is not locked, then if the file is read-only we
+ ;; assume that locking is used for the file, otherwise
+ ;; locking is not used.
+ (not (vc-mistrust-permissions file))
+ (vc-up-to-date-p file)
+ (if (string-match ".r-..-..-." (nth 8 (file-attributes file)))
+ (vc-file-setprop file 'vc-checkout-model 'locking)
+ (vc-file-setprop file 'vc-checkout-model 'implicit)))
+ status))))
+
+(defun vc-release-greater-or-equal (r1 r2)
+ "Compare release numbers, represented as strings.
+Release components are assumed cardinal numbers, not decimal fractions
+\(5.10 is a higher release than 5.9\). Omitted fields are considered
+lower \(5.6.7 is earlier than 5.6.7.1\). Comparison runs till the end
+of the string is found, or a non-numeric component shows up \(5.6.7 is
+earlier than \"5.6.7 beta\", which is probably not what you want in
+some cases\). This code is suitable for existing RCS release numbers.
+CVS releases are handled reasonably, too \(1.3 < 1.4* < 1.5\)."
+ (let (v1 v2 i1 i2)
+ (catch 'done
+ (or (and (string-match "^\\.?\\([0-9]+\\)" r1)
+ (setq i1 (match-end 0))
+ (setq v1 (string-to-number (match-string 1 r1)))
+ (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
+ (setq i2 (match-end 0))
+ (setq v2 (string-to-number (match-string 1 r2)))
+ (if (> v1 v2) (throw 'done t)
+ (if (< v1 v2) (throw 'done nil)
+ (throw 'done
+ (vc-release-greater-or-equal
+ (substring r1 i1)
+ (substring r2 i2)))))))
+ (throw 'done t)))
+ (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
+ (throw 'done nil))
+ (throw 'done t)))))
+
+(defun vc-rcs-release-p (release)
+ "Return t if we have RELEASE or better."
+ (let ((installation (vc-rcs-system-release)))
+ (if (and installation
+ (not (eq installation 'unknown)))
+ (vc-release-greater-or-equal installation release))))
+
+(defun vc-rcs-system-release ()
+ "Return the RCS release installed on this system, as a string.
+Return symbol `unknown' if the release cannot be deducted. The user can
+override this using variable `vc-rcs-release'.
+
+If the user has not set variable `vc-rcs-release' and it is nil,
+variable `vc-rcs-release' is set to the returned value."
+ (or vc-rcs-release
+ (setq vc-rcs-release
+ (or (and (zerop (vc-do-command "*vc*" nil "rcs" nil "-V"))
+ (with-current-buffer (get-buffer "*vc*")
+ (vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1)))
+ 'unknown))))
+
+(defun vc-rcs-set-non-strict-locking (file)
+ (vc-do-command "*vc*" 0 "rcs" file "-U")
+ (vc-file-setprop file 'vc-checkout-model 'implicit)
+ (set-file-modes file (logior (file-modes file) 128)))
+
+(defun vc-rcs-set-default-branch (file branch)
+ (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-b" branch))
+ (vc-file-setprop file 'vc-rcs-default-branch branch))
+
+(defun vc-rcs-parse (&optional buffer)
+ "Parse current buffer, presumed to be in RCS-style masterfile format.
+Optional arg BUFFER specifies another buffer to parse. Return an alist
+of two elements, w/ keys `headers' and `revisions' and values in turn
+sub-alists. For `headers', the values unless otherwise specified are
+strings and the keys are:
+
+ desc -- description
+ head -- latest revision
+ branch -- the branch the \"head revision\" lies on;
+ absent if the head revision lies on the trunk
+ access -- ???
+ symbols -- sub-alist of (SYMBOL . REVISION) elements
+ locks -- if file is checked out, something like \"ttn:1.7\"
+ strict -- t if \"strict locking\" is in effect, otherwise nil
+ comment -- may be absent; typically something like \"# \" or \"; \"
+ expand -- may be absent; ???
+
+For `revisions', the car is REVISION (string), the cdr a sub-alist,
+with string values (unless otherwise specified) and keys:
+
+ date -- a time value (like that returned by `encode-time'); as a
+ special case, a year value less than 100 is augmented by 1900
+ author -- username
+ state -- typically \"Exp\" or \"Rel\"
+ branches -- list of revisions that begin branches from this revision
+ next -- on the trunk: the chronologically-preceding revision, or \"\";
+ on a branch: the chronologically-following revision, or \"\"
+ log -- change log entry
+ text -- for the head revision on the trunk, the body of the file;
+ other revisions have `:insn' instead
+ :insn -- for non-head revisions, a list of parsed instructions
+ in one of two forms, in both cases START meaning \"first
+ go to line START\":
+ - `(START k COUNT)' -- kill COUNT lines
+ - `(START i TEXT)' -- insert TEXT (a string)
+ The list is in descending order by START.
+
+The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension."
+ (setq buffer (get-buffer (or buffer (current-buffer))))
+ (set-buffer buffer)
+ ;; An RCS masterfile can be viewed as containing four regular (for the
+ ;; most part) sections: (a) the "headers", (b) the "rev headers", (c)
+ ;; the "description" and (d) the "rev bodies", in that order. In the
+ ;; returned alist (see docstring), elements from (b) and (d) are
+ ;; combined pairwise to form the "revisions", while those from (a) and
+ ;; (c) are simply combined to form the "headers".
+ ;;
+ ;; Loosely speaking, each section contains a series of alternating
+ ;; "tags" and "printed representations". In the (b) and (d), many
+ ;; such series can appear, and a revision number on a line by itself
+ ;; precedes the series of tags and printed representations associated
+ ;; with it.
+ ;;
+ ;; In (a) and (b), the printed representations (with the exception of
+ ;; the `comment' tag in the headers) terminate with a semicolon, which
+ ;; is NOT part of the "value" finally associated with the tag. All
+ ;; other printed representations are in "@@-format"; there is an "@",
+ ;; the middle part (to be translated into the value), another "@" and
+ ;; a newline. Each "@@" in the middle part indicates the position of
+ ;; a single "@" (and consequently the requirement of an additional
+ ;; initial step when translating to the value).
+ ;;
+ ;; Parser state includes vars that collect parts of the return value...
+ (let ((desc nil) (headers nil) (revs nil)
+ ;; ... as well as vars that support a single-pass, tag-assisted,
+ ;; minimal-data-copying scan. Basically -- skirting around the
+ ;; grouping by revision required in (b) and (d) -- we repeatedly
+ ;; and context-sensitively read a tag (that MUST be present),
+ ;; determine the bounds of the printed representation, translate
+ ;; it into a value, and push the tag plus value onto one of the
+ ;; collection vars. Finally, we return the parse tree
+ ;; incorporating the values of the collection vars (see "rv").
+ ;;
+ ;; A symbol or string to keep track of context (for error messages).
+ context
+ ;; A symbol, the current tag.
+ tok
+ ;; Region (begin and end buffer positions) of the printed
+ ;; representation for the current tag.
+ b e
+ ;; A list of buffer positions where "@@" can be found within the
+ ;; printed representation region. For each location, we push two
+ ;; elements onto the list, 1+ and 2+ the location, respectively,
+ ;; with the 2+ appearing at the head. In this way, the expression
+ ;; `(,e ,@@-holes ,b)
+ ;; describes regions that can be concatenated (in reverse order)
+ ;; to "de-@@-format" the printed representation as the first step
+ ;; to translating it into some value. See internal func `gather'.
+ @-holes)
+ (flet ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]'
+ (at (tag) (save-excursion (eq tag (read buffer))))
+ (to-eol () (buffer-substring-no-properties
+ (point) (progn (forward-line 1)
+ (1- (point)))))
+ (to-semi () (setq b (point)
+ e (progn (search-forward ";")
+ (1- (point)))))
+ (to-one@ () (setq @-holes nil
+ b (progn (search-forward "@") (point))
+ e (progn (while (and (search-forward "@")
+ (= ?@ (char-after))
+ (progn
+ (push (point) @-holes)
+ (forward-char 1)
+ (push (point) @-holes))))
+ (1- (point)))))
+ (tok+val (set-b+e name &optional proc)
+ (unless (eq name (setq tok (read buffer)))
+ (error "Missing `%s' while parsing %s" name context))
+ (sw)
+ (funcall set-b+e)
+ (cons tok (if proc
+ (funcall proc)
+ (buffer-substring-no-properties b e))))
+ (k-semi (name &optional proc) (tok+val 'to-semi name proc))
+ (gather () (let ((pairs `(,e ,@@-holes ,b))
+ acc)
+ (while pairs
+ (push (buffer-substring-no-properties
+ (cadr pairs) (car pairs))
+ acc)
+ (setq pairs (cddr pairs)))
+ (apply 'concat acc)))
+ (k-one@ (name &optional later) (tok+val 'to-one@ name
+ (if later
+ (lambda () t)
+ 'gather))))
+ (save-excursion
+ (goto-char (point-min))
+ ;; headers
+ (setq context 'headers)
+ (flet ((hpush (name &optional proc)
+ (push (k-semi name proc) headers)))
+ (hpush 'head)
+ (when (at 'branch)
+ (hpush 'branch))
+ (hpush 'access)
+ (hpush 'symbols
+ (lambda ()
+ (mapcar (lambda (together)
+ (let ((two (split-string together ":")))
+ (setcar two (intern (car two)))
+ (setcdr two (cadr two))
+ two))
+ (split-string
+ (buffer-substring-no-properties b e)))))
+ (hpush 'locks))
+ (push `(strict . ,(when (at 'strict)
+ (search-forward ";")
+ t))
+ headers)
+ (when (at 'comment)
+ (push (k-one@ 'comment) headers)
+ (search-forward ";"))
+ (when (at 'expand)
+ (push (k-one@ 'expand) headers)
+ (search-forward ";"))
+ (setq headers (nreverse headers))
+ ;; rev headers
+ (sw) (setq context 'rev-headers)
+ (while (looking-at "[0-9]")
+ (push `(,(to-eol)
+ ,(k-semi 'date
+ (lambda ()
+ (let ((ls (mapcar 'string-to-number
+ (split-string
+ (buffer-substring-no-properties
+ b e)
+ "\\."))))
+ ;; Hack the year -- verified to be the
+ ;; same algorithm used in RCS 5.7.
+ (when (< (car ls) 100)
+ (setcar ls (+ 1900 (car ls))))
+ (apply 'encode-time (nreverse ls)))))
+ ,@(mapcar 'k-semi '(author state))
+ ,(k-semi 'branches
+ (lambda ()
+ (split-string
+ (buffer-substring-no-properties b e))))
+ ,(k-semi 'next))
+ revs)
+ (sw))
+ (setq revs (nreverse revs))
+ ;; desc
+ (sw) (setq context 'desc
+ desc (k-one@ 'desc))
+ ;; rev bodies
+ (let (acc
+ ;; Element of `revs' that initially holds only header info.
+ ;; "Pairwise combination" occurs when we add body info.
+ rev
+ ;; Components of the editing commands (aside from the actual
+ ;; text) that comprise the `text' printed representations
+ ;; (not including the "head" revision).
+ cmd start act
+ ;; Ascending (reversed) `@-holes' which the internal func
+ ;; `incg' pops to effect incremental gathering.
+ asc
+ ;; Function to extract text (for the `a' command), either
+ ;; `incg' or `buffer-substring-no-properties'. (This is
+ ;; for speed; strictly speaking, it is sufficient to use
+ ;; only the former since it behaves identically to the
+ ;; latter in the absense of "@@".)
+ sub)
+ (flet ((incg (beg end) (let ((b beg) (e end) @-holes)
+ (while (and asc (< (car asc) e))
+ (push (pop asc) @-holes))
+ ;; Self-deprecate when work is done.
+ ;; Folding many dimensions into one.
+ ;; Thanks B.Mandelbrot, for complex sum.
+ ;; O beauteous math! --the Unvexed Bum
+ (unless asc
+ (setq sub 'buffer-substring-no-properties))
+ (gather))))
+ (while (and (sw)
+ (not (eobp))
+ (setq context (to-eol)
+ rev (or (assoc context revs)
+ (error "Rev `%s' has body but no head"
+ context))))
+ (push (k-one@ 'log) (cdr rev))
+ ;; For rev body `text' tags, delay translation slightly...
+ (push (k-one@ 'text t) (cdr rev))
+ ;; ... until we decide which tag and value is appropriate to
+ ;; collect. For the "head" revision, compute the value of the
+ ;; `text' printed representation by simple `gather'. For all
+ ;; other revisions, replace the `text' tag+value with `:insn'
+ ;; plus value, always scanning in-place.
+ (if (string= context (cdr (assq 'head headers)))
+ (setcdr (cadr rev) (gather))
+ (if @-holes
+ (setq asc (nreverse @-holes)
+ sub 'incg)
+ (setq sub 'buffer-substring-no-properties))
+ (goto-char b)
+ (setq acc nil)
+ (while (< (point) e)
+ (forward-char 1)
+ (setq cmd (char-before)
+ start (read (current-buffer))
+ act (read (current-buffer)))
+ (forward-char 1)
+ (push (case cmd
+ (?d
+ ;; `d' means "delete lines".
+ ;; For Emacs spirit, we use `k' for "kill".
+ `(,start k ,act))
+ (?a
+ ;; `a' means "append after this line" but
+ ;; internally we normalize it so that START
+ ;; specifies the actual line for insert, thus
+ ;; requiring less hair in the realization algs.
+ ;; For Emacs spirit, we use `i' for "insert".
+ `(,(1+ start) i
+ ,(funcall sub (point) (progn (forward-line act)
+ (point)))))
+ (t (error "Bad command `%c' in `text' for rev `%s'"
+ cmd context)))
+ acc))
+ (goto-char (1+ e))
+ (setcar (cdr rev) (cons :insn acc)))))))
+ ;; rv
+ `((headers ,desc ,@headers)
+ (revisions ,@revs)))))
+
+(provide 'vc-rcs)
+
+;; arch-tag: 759b4916-5b0d-431d-b647-b185b8c652cf
+;;; vc-rcs.el ends here
--- /dev/null
+;;; vc-sccs.el --- support for SCCS version-control
+
+;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Proper function of the SCCS diff commands requires the shellscript vcdiff
+;; to be installed somewhere on Emacs's path for executables.
+;;
+
+;;; Code:
+
+(eval-when-compile
+ (require 'vc))
+
+;;;
+;;; Customization options
+;;;
+
+;; ;; Maybe a better solution is to not use "get" but "sccs get".
+;; (defcustom vc-sccs-path
+;; (let ((path ()))
+;; (dolist (dir '("/usr/sccs" "/usr/lib/sccs" "/usr/libexec/sccs"))
+;; (if (file-directory-p dir)
+;; (push dir path)))
+;; path)
+;; "List of extra directories to search for SCCS commands."
+;; :type '(repeat directory)
+;; :group 'vc)
+
+(defcustom vc-sccs-register-switches nil
+ "Switches for registering a file in SCCS.
+A string or list of strings passed to the checkin program by
+\\[vc-register]. If nil, use the value of `vc-register-switches'.
+If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-sccs-diff-switches nil
+ "String or list of strings specifying switches for SCCS diff under VC.
+If nil, use the value of `vc-diff-switches'. If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "21.1"
+ :group 'vc)
+
+(defcustom vc-sccs-header (or (cdr (assoc 'SCCS vc-header-alist)) '("%W%"))
+ "Header keywords to be inserted by `vc-insert-headers'."
+ :type '(repeat string)
+ :group 'vc)
+
+;;;###autoload
+(defcustom vc-sccs-master-templates
+ (purecopy '("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir))
+ "Where to look for SCCS master files.
+For a description of possible values, see `vc-check-master-templates'."
+ :type '(choice (const :tag "Use standard SCCS file names"
+ ("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir))
+ (repeat :tag "User-specified"
+ (choice string
+ function)))
+ :version "21.1"
+ :group 'vc)
+
+\f
+;;;
+;;; Internal variables
+;;;
+
+(defconst vc-sccs-name-assoc-file "VC-names")
+
+\f
+;;; Properties of the backend
+
+(defun vc-sccs-revision-granularity () 'file)
+(defun vc-sccs-checkout-model (files) 'locking)
+
+;;;
+;;; State-querying functions
+;;;
+
+;; The autoload cookie below places vc-sccs-registered directly into
+;; loaddefs.el, so that vc-sccs.el does not need to be loaded for
+;; every file that is visited. The definition is repeated below
+;; so that Help and etags can find it.
+
+;;;###autoload (defun vc-sccs-registered(f) (vc-default-registered 'SCCS f))
+(defun vc-sccs-registered (f) (vc-default-registered 'SCCS f))
+
+(defun vc-sccs-state (file)
+ "SCCS-specific function to compute the version control state."
+ (if (not (vc-sccs-registered file))
+ 'unregistered
+ (with-temp-buffer
+ (if (vc-insert-file (vc-sccs-lock-file file))
+ (let* ((locks (vc-sccs-parse-locks))
+ (working-revision (vc-working-revision file))
+ (locking-user (cdr (assoc working-revision locks))))
+ (if (not locking-user)
+ (if (vc-workfile-unchanged-p file)
+ 'up-to-date
+ 'unlocked-changes)
+ (if (string= locking-user (vc-user-login-name file))
+ 'edited
+ locking-user)))
+ 'up-to-date))))
+
+(defun vc-sccs-state-heuristic (file)
+ "SCCS-specific state heuristic."
+ (if (not (vc-mistrust-permissions file))
+ ;; This implementation assumes that any file which is under version
+ ;; control and has -rw-r--r-- is locked by its owner. This is true
+ ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
+ ;; We have to be careful not to exclude files with execute bits on;
+ ;; scripts can be under version control too. Also, we must ignore the
+ ;; group-read and other-read bits, since paranoid users turn them off.
+ (let* ((attributes (file-attributes file 'string))
+ (owner-name (nth 2 attributes))
+ (permissions (nth 8 attributes)))
+ (if (string-match ".r-..-..-." permissions)
+ 'up-to-date
+ (if (string-match ".rw..-..-." permissions)
+ (if (file-ownership-preserved-p file)
+ 'edited
+ owner-name)
+ ;; Strange permissions.
+ ;; Fall through to real state computation.
+ (vc-sccs-state file))))
+ (vc-sccs-state file)))
+
+(defun vc-sccs-dir-status (dir update-function)
+ ;; FIXME: this function should be rewritten, using `vc-expand-dirs'
+ ;; is not TRTD because it returns files from multiple backends.
+ ;; It should also return 'unregistered files.
+
+ ;; Doing lots of individual VC-state calls is painful, but
+ ;; there is no better option in SCCS-land.
+ (let ((flist (vc-expand-dirs (list dir)))
+ (result nil))
+ (dolist (file flist)
+ (let ((state (vc-state file))
+ (frel (file-relative-name file)))
+ (when (and (eq (vc-backend file) 'SCCS)
+ (not (eq state 'up-to-date)))
+ (push (list frel state) result))))
+ (funcall update-function result)))
+
+(defun vc-sccs-working-revision (file)
+ "SCCS-specific version of `vc-working-revision'."
+ (with-temp-buffer
+ ;; The working revision is always the latest revision number.
+ ;; To find this number, search the entire delta table,
+ ;; rather than just the first entry, because the
+ ;; first entry might be a deleted ("R") revision.
+ (vc-insert-file (vc-name file) "^\001e\n\001[^s]")
+ (vc-parse-buffer "^\001d D \\([^ ]+\\)" 1)))
+
+(defun vc-sccs-workfile-unchanged-p (file)
+ "SCCS-specific implementation of `vc-workfile-unchanged-p'."
+ (zerop (apply 'vc-do-command "*vc*" 1 "vcdiff" (vc-name file)
+ (list "--brief" "-q"
+ (concat "-r" (vc-working-revision file))))))
+
+\f
+;;;
+;;; State-changing functions
+;;;
+
+(defun vc-sccs-do-command (buffer okstatus command file-or-list &rest flags)
+ ;; (let ((load-path (append vc-sccs-path load-path)))
+ ;; (apply 'vc-do-command buffer okstatus command file-or-list flags))
+ (apply 'vc-do-command (or buffer "*vc*") okstatus "sccs" file-or-list command flags))
+
+(defun vc-sccs-create-repo ()
+ "Create a new SCCS repository."
+ ;; SCCS is totally file-oriented, so all we have to do is make the directory
+ (make-directory "SCCS"))
+
+(defun vc-sccs-register (files &optional rev comment)
+ "Register FILES into the SCCS version-control system.
+REV is the optional revision number for the file. COMMENT can be used
+to provide an initial description of FILES.
+Passes either `vc-sccs-register-switches' or `vc-register-switches'
+to the SCCS command.
+
+Automatically retrieve a read-only version of the files with keywords
+expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
+ (dolist (file files)
+ (let* ((dirname (or (file-name-directory file) ""))
+ (basename (file-name-nondirectory file))
+ (project-file (vc-sccs-search-project-dir dirname basename)))
+ (let ((vc-name
+ (or project-file
+ (format (car vc-sccs-master-templates) dirname basename))))
+ (apply 'vc-sccs-do-command nil 0 "admin" vc-name
+ (and rev (not (string= rev "")) (concat "-r" rev))
+ "-fb"
+ (concat "-i" (file-relative-name file))
+ (and comment (concat "-y" comment))
+ (vc-switches 'SCCS 'register)))
+ (delete-file file)
+ (if vc-keep-workfiles
+ (vc-sccs-do-command nil 0 "get" (vc-name file))))))
+
+(defun vc-sccs-responsible-p (file)
+ "Return non-nil if SCCS thinks it would be responsible for registering FILE."
+ ;; TODO: check for all the patterns in vc-sccs-master-templates
+ (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file)))
+ (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "")
+ (file-name-nondirectory file)))))
+
+(defun vc-sccs-checkin (files rev comment &optional extra-args-ignored)
+ "SCCS-specific version of `vc-backend-checkin'."
+ (dolist (file (vc-expand-dirs files))
+ (apply 'vc-sccs-do-command nil 0 "delta" (vc-name file)
+ (if rev (concat "-r" rev))
+ (concat "-y" comment)
+ (vc-switches 'SCCS 'checkin))
+ (if vc-keep-workfiles
+ (vc-sccs-do-command nil 0 "get" (vc-name file)))))
+
+(defun vc-sccs-find-revision (file rev buffer)
+ (apply 'vc-sccs-do-command
+ buffer 0 "get" (vc-name file)
+ "-s" ;; suppress diagnostic output
+ "-p"
+ (and rev
+ (concat "-r"
+ (vc-sccs-lookup-triple file rev)))
+ (vc-switches 'SCCS 'checkout)))
+
+(defun vc-sccs-checkout (file &optional editable rev)
+ "Retrieve a copy of a saved revision of SCCS controlled FILE.
+If FILE is a directory, all version-controlled files beneath are checked out.
+EDITABLE non-nil means that the file should be writable and
+locked. REV is the revision to check out."
+ (if (file-directory-p file)
+ (mapc 'vc-sccs-checkout (vc-expand-dirs (list file)))
+ (let ((file-buffer (get-file-buffer file))
+ switches)
+ (message "Checking out %s..." file)
+ (save-excursion
+ ;; Change buffers to get local value of vc-checkout-switches.
+ (if file-buffer (set-buffer file-buffer))
+ (setq switches (vc-switches 'SCCS 'checkout))
+ ;; Save this buffer's default-directory
+ ;; and use save-excursion to make sure it is restored
+ ;; in the same buffer it was saved in.
+ (let ((default-directory default-directory))
+ (save-excursion
+ ;; Adjust the default-directory so that the check-out creates
+ ;; the file in the right place.
+ (setq default-directory (file-name-directory file))
+
+ (and rev (or (string= rev "")
+ (not (stringp rev)))
+ (setq rev nil))
+ (apply 'vc-sccs-do-command nil 0 "get" (vc-name file)
+ (if editable "-e")
+ (and rev (concat "-r" (vc-sccs-lookup-triple file rev)))
+ switches))))
+ (message "Checking out %s...done" file))))
+
+(defun vc-sccs-rollback (files)
+ "Roll back, undoing the most recent checkins of FILES. Directories
+are expanded to all version-controlled subfiles."
+ (setq files (vc-expand-dirs files))
+ (if (not files)
+ (error "SCCS backend doesn't support directory-level rollback"))
+ (dolist (file files)
+ (let ((discard (vc-working-revision file)))
+ (if (null (yes-or-no-p (format "Remove version %s from %s history? "
+ discard file)))
+ (error "Aborted"))
+ (message "Removing revision %s from %s..." discard file)
+ (vc-sccs-do-command nil 0 "rmdel"
+ (vc-name file) (concat "-r" discard))
+ (vc-sccs-do-command nil 0 "get" (vc-name file) nil))))
+
+(defun vc-sccs-revert (file &optional contents-done)
+ "Revert FILE to the version it was based on. If FILE is a directory,
+revert all subfiles."
+ (if (file-directory-p file)
+ (mapc 'vc-sccs-revert (vc-expand-dirs (list file)))
+ (vc-sccs-do-command nil 0 "unget" (vc-name file))
+ (vc-sccs-do-command nil 0 "get" (vc-name file))
+ ;; Checking out explicit revisions is not supported under SCCS, yet.
+ ;; We always "revert" to the latest revision; therefore
+ ;; vc-working-revision is cleared here so that it gets recomputed.
+ (vc-file-setprop file 'vc-working-revision nil)))
+
+(defun vc-sccs-steal-lock (file &optional rev)
+ "Steal the lock on the current workfile for FILE and revision REV."
+ (if (file-directory-p file)
+ (mapc 'vc-sccs-steal-lock (vc-expand-dirs (list file)))
+ (vc-sccs-do-command nil 0 "unget"
+ (vc-name file) "-n" (if rev (concat "-r" rev)))
+ (vc-sccs-do-command nil 0 "get"
+ (vc-name file) "-g" (if rev (concat "-r" rev)))))
+
+(defun vc-sccs-modify-change-comment (files rev comment)
+ "Modify (actually, append to) the change comments for FILES on a specified REV."
+ (dolist (file (vc-expand-dirs files))
+ (vc-sccs-do-command nil 0 "cdc" (vc-name file)
+ (concat "-y" comment) (concat "-r" rev))))
+
+\f
+;;;
+;;; History functions
+;;;
+
+(defun vc-sccs-print-log (files buffer &optional shortlog start-revision-ignored limit)
+ "Get change log associated with FILES."
+ (setq files (vc-expand-dirs files))
+ (vc-sccs-do-command buffer 0 "prs" (mapcar 'vc-name files))
+ (when limit 'limit-unsupported))
+
+(defun vc-sccs-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using SCCS between two filesets."
+ (setq files (vc-expand-dirs files))
+ (setq oldvers (vc-sccs-lookup-triple (car files) oldvers))
+ (setq newvers (vc-sccs-lookup-triple (car files) newvers))
+ (apply 'vc-do-command (or buffer "*vc-diff*")
+ 1 "vcdiff" (mapcar 'vc-name (vc-expand-dirs files))
+ (append (list "-q"
+ (and oldvers (concat "-r" oldvers))
+ (and newvers (concat "-r" newvers)))
+ (vc-switches 'SCCS 'diff))))
+
+\f
+;;;
+;;; Tag system. SCCS doesn't have tags, so we simulate them by maintaining
+;;; our own set of name-to-revision mappings.
+;;;
+
+(defun vc-sccs-create-tag (backend dir name branchp)
+ (when branchp
+ (error "SCCS backend %s does not support module branches" backend))
+ (let ((result (vc-tag-precondition dir)))
+ (if (stringp result)
+ (error "File %s is not up-to-date" result)
+ (vc-file-tree-walk
+ dir
+ (lambda (f)
+ (vc-sccs-add-triple name f (vc-working-revision f)))))))
+
+\f
+;;;
+;;; Miscellaneous
+;;;
+
+(defun vc-sccs-previous-revision (file rev)
+ (vc-call-backend 'RCS 'previous-revision file rev))
+
+(defun vc-sccs-next-revision (file rev)
+ (vc-call-backend 'RCS 'next-revision file rev))
+
+(defun vc-sccs-check-headers ()
+ "Check if the current file has any headers in it."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "%[A-Z]%" nil t)))
+
+(defun vc-sccs-rename-file (old new)
+ ;; Move the master file (using vc-rcs-master-templates).
+ (vc-rename-master (vc-name old) new vc-sccs-master-templates)
+ ;; Update the tag file.
+ (with-current-buffer
+ (find-file-noselect
+ (expand-file-name vc-sccs-name-assoc-file
+ (file-name-directory (vc-name old))))
+ (goto-char (point-min))
+ ;; (replace-regexp (concat ":" (regexp-quote old) "$") (concat ":" new))
+ (while (re-search-forward (concat ":" (regexp-quote old) "$") nil t)
+ (replace-match (concat ":" new) nil nil))
+ (basic-save-buffer)
+ (kill-buffer (current-buffer))))
+
+(defun vc-sccs-find-file-hook ()
+ ;; If the file is locked by some other user, make
+ ;; the buffer read-only. Like this, even root
+ ;; cannot modify a file that someone else has locked.
+ (and (stringp (vc-state buffer-file-name 'SCCS))
+ (setq buffer-read-only t)))
+
+\f
+;;;
+;;; Internal functions
+;;;
+
+;; This function is wrapped with `progn' so that the autoload cookie
+;; copies the whole function itself into loaddefs.el rather than just placing
+;; a (autoload 'vc-sccs-search-project-dir "vc-sccs") which would not
+;; help us avoid loading vc-sccs.
+;;;###autoload
+(progn (defun vc-sccs-search-project-dir (dirname basename)
+ "Return the name of a master file in the SCCS project directory.
+Does not check whether the file exists but returns nil if it does not
+find any project directory."
+ (let ((project-dir (getenv "PROJECTDIR")) dirs dir)
+ (when project-dir
+ (if (file-name-absolute-p project-dir)
+ (setq dirs '("SCCS" ""))
+ (setq dirs '("src/SCCS" "src" "source/SCCS" "source"))
+ (setq project-dir (expand-file-name (concat "~" project-dir))))
+ (while (and (not dir) dirs)
+ (setq dir (expand-file-name (car dirs) project-dir))
+ (unless (file-directory-p dir)
+ (setq dir nil)
+ (setq dirs (cdr dirs))))
+ (and dir (expand-file-name (concat "s." basename) dir))))))
+
+(defun vc-sccs-lock-file (file)
+ "Generate lock file name corresponding to FILE."
+ (let ((master (vc-name file)))
+ (and
+ master
+ (string-match "\\(.*/\\)\\(s\\.\\)\\(.*\\)" master)
+ (replace-match "p." t t master 2))))
+
+(defun vc-sccs-parse-locks ()
+ "Parse SCCS locks in current buffer.
+The result is a list of the form ((REVISION . USER) (REVISION . USER) ...)."
+ (let (master-locks)
+ (goto-char (point-min))
+ (while (re-search-forward "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?"
+ nil t)
+ (setq master-locks
+ (cons (cons (match-string 1) (match-string 2)) master-locks)))
+ ;; FIXME: is it really necessary to reverse ?
+ (nreverse master-locks)))
+
+(defun vc-sccs-add-triple (name file rev)
+ (with-current-buffer
+ (find-file-noselect
+ (expand-file-name vc-sccs-name-assoc-file
+ (file-name-directory (vc-name file))))
+ (goto-char (point-max))
+ (insert name "\t:\t" file "\t" rev "\n")
+ (basic-save-buffer)
+ (kill-buffer (current-buffer))))
+
+(defun vc-sccs-lookup-triple (file name)
+ "Return the numeric revision corresponding to a named tag of FILE.
+If NAME is nil or a revision number string it's just passed through."
+ (if (or (null name)
+ (let ((firstchar (aref name 0)))
+ (and (>= firstchar ?0) (<= firstchar ?9))))
+ name
+ (with-temp-buffer
+ (vc-insert-file
+ (expand-file-name vc-sccs-name-assoc-file
+ (file-name-directory (vc-name file))))
+ (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1))))
+
+(provide 'vc-sccs)
+
+;; arch-tag: d751dee3-d7b3-47e1-95e3-7ae98c052041
+;;; vc-sccs.el ends here
--- /dev/null
+;;; vc-svn.el --- non-resident support for Subversion version-control
+
+;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see vc.el for full credits)
+;; Maintainer: Stefan Monnier <monnier@gnu.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Sync'd with Subversion's vc-svn.el as of revision 5801. but this version
+;; has been extensively modified since to handle filesets.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'vc))
+
+;; Clear up the cache to force vc-call to check again and discover
+;; new functions when we reload this file.
+(put 'SVN 'vc-functions nil)
+
+;;;
+;;; Customization options
+;;;
+
+;; FIXME there is also svnadmin.
+(defcustom vc-svn-program "svn"
+ "Name of the SVN executable."
+ :type 'string
+ :group 'vc)
+
+(defcustom vc-svn-global-switches nil
+ "Global switches to pass to any SVN command."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :version "22.1"
+ :group 'vc)
+
+(defcustom vc-svn-register-switches nil
+ "Switches for registering a file into SVN.
+A string or list of strings passed to the checkin program by
+\\[vc-register]. If nil, use the value of `vc-register-switches'.
+If t, use no switches."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "22.1"
+ :group 'vc)
+
+(defcustom vc-svn-diff-switches
+ t ;`svn' doesn't support common args like -c or -b.
+ "String or list of strings specifying extra switches for svn diff under VC.
+If nil, use the value of `vc-diff-switches' (or `diff-switches'),
+together with \"-x --diff-cmd=diff\" (since svn diff does not
+support the default \"-c\" value of `diff-switches'). If you
+want to force an empty list of arguments, use t."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :version "22.1"
+ :group 'vc)
+
+(defcustom vc-svn-header (or (cdr (assoc 'SVN vc-header-alist)) '("\$Id\$"))
+ "Header keywords to be inserted by `vc-insert-headers'."
+ :version "22.1"
+ :type '(repeat string)
+ :group 'vc)
+
+;; We want to autoload it for use by the autoloaded version of
+;; vc-svn-registered, but we want the value to be compiled at startup, not
+;; at dump time.
+;; ;;;###autoload
+(defconst vc-svn-admin-directory
+ (cond ((and (memq system-type '(cygwin windows-nt ms-dos))
+ (getenv "SVN_ASP_DOT_NET_HACK"))
+ "_svn")
+ (t ".svn"))
+ "The name of the \".svn\" subdirectory or its equivalent.")
+
+;;; Properties of the backend
+
+(defun vc-svn-revision-granularity () 'repository)
+(defun vc-svn-checkout-model (files) 'implicit)
+
+;;;
+;;; State-querying functions
+;;;
+
+;;; vc-svn-admin-directory is generally not defined when the
+;;; autoloaded function is called.
+
+;;;###autoload (defun vc-svn-registered (f)
+;;;###autoload (let ((admin-dir (cond ((and (eq system-type 'windows-nt)
+;;;###autoload (getenv "SVN_ASP_DOT_NET_HACK"))
+;;;###autoload "_svn")
+;;;###autoload (t ".svn"))))
+;;;###autoload (when (file-readable-p (expand-file-name
+;;;###autoload (concat admin-dir "/entries")
+;;;###autoload (file-name-directory f)))
+;;;###autoload (load "vc-svn")
+;;;###autoload (vc-svn-registered f))))
+
+(defun vc-svn-registered (file)
+ "Check if FILE is SVN registered."
+ (when (file-readable-p (expand-file-name (concat vc-svn-admin-directory
+ "/entries")
+ (file-name-directory file)))
+ (with-temp-buffer
+ (cd (file-name-directory file))
+ (let* (process-file-side-effects
+ (status
+ (condition-case nil
+ ;; Ignore all errors.
+ (vc-svn-command t t file "status" "-v")
+ ;; Some problem happened. E.g. We can't find an `svn'
+ ;; executable. We used to only catch `file-error' but when
+ ;; the process is run on a remote host via Tramp, the error
+ ;; is only reported via the exit status which is turned into
+ ;; an `error' by vc-do-command.
+ (error nil))))
+ (when (eq 0 status)
+ (let ((parsed (vc-svn-parse-status file)))
+ (and parsed (not (memq parsed '(ignored unregistered))))))))))
+
+(defun vc-svn-state (file &optional localp)
+ "SVN-specific version of `vc-state'."
+ (let (process-file-side-effects)
+ (setq localp (or localp (vc-stay-local-p file 'SVN)))
+ (with-temp-buffer
+ (cd (file-name-directory file))
+ (vc-svn-command t 0 file "status" (if localp "-v" "-u"))
+ (vc-svn-parse-status file))))
+
+(defun vc-svn-state-heuristic (file)
+ "SVN-specific state heuristic."
+ (vc-svn-state file 'local))
+
+;; FIXME it would be better not to have the "remote" argument,
+;; but to distinguish the two output formats based on content.
+(defun vc-svn-after-dir-status (callback &optional remote)
+ (let ((state-map '((?A . added)
+ (?C . conflict)
+ (?I . ignored)
+ (?M . edited)
+ (?D . removed)
+ (?R . removed)
+ (?? . unregistered)
+ ;; This is what vc-svn-parse-status does.
+ (?~ . edited)))
+ (re (if remote "^\\(.\\)...... \\([ *]\\) +\\(?:[-0-9]+\\)? \\(.*\\)$"
+ ;; Subexp 2 is a dummy in this case, so the numbers match.
+ "^\\(.\\)....\\(.\\) \\(.*\\)$"))
+ result)
+ (goto-char (point-min))
+ (while (re-search-forward re nil t)
+ (let ((state (cdr (assq (aref (match-string 1) 0) state-map)))
+ (filename (match-string 3)))
+ (and remote (string-equal (match-string 2) "*")
+ ;; FIXME are there other possible combinations?
+ (cond ((eq state 'edited) (setq state 'needs-merge))
+ ((not state) (setq state 'needs-update))))
+ (when (and state (not (string= "." filename)))
+ (setq result (cons (list filename state) result)))))
+ (funcall callback result)))
+
+(defun vc-svn-dir-status (dir callback)
+ "Run 'svn status' for DIR and update BUFFER via CALLBACK.
+CALLBACK is called as (CALLBACK RESULT BUFFER), where
+RESULT is a list of conses (FILE . STATE) for directory DIR."
+ ;; FIXME should this rather be all the files in dir?
+ ;; FIXME: the vc-stay-local-p logic below is disabled, it ends up
+ ;; calling synchronously (vc-svn-registered DIR) => calling svn status -v DIR
+ ;; which is VERY SLOW for big trees and it makes emacs
+ ;; completely unresponsive during that time.
+ (let* ((local (and nil (vc-stay-local-p dir 'SVN)))
+ (remote (or t (not local) (eq local 'only-file))))
+ (vc-svn-command (current-buffer) 'async nil "status"
+ (if remote "-u"))
+ (vc-exec-after
+ `(vc-svn-after-dir-status (quote ,callback) ,remote))))
+
+(defun vc-svn-dir-status-files (dir files default-state callback)
+ (apply 'vc-svn-command (current-buffer) 'async nil "status" files)
+ (vc-exec-after
+ `(vc-svn-after-dir-status (quote ,callback))))
+
+(defun vc-svn-dir-extra-headers (dir)
+ "Generate extra status headers for a Subversion working copy."
+ (let (process-file-side-effects)
+ (vc-svn-command "*vc*" 0 nil "info"))
+ (let ((repo
+ (save-excursion
+ (and (progn
+ (set-buffer "*vc*")
+ (goto-char (point-min))
+ (re-search-forward "Repository Root: *\\(.*\\)" nil t))
+ (match-string 1)))))
+ (concat
+ (cond (repo
+ (concat
+ (propertize "Repository : " 'face 'font-lock-type-face)
+ (propertize repo 'face 'font-lock-variable-name-face)))
+ (t "")))))
+
+(defun vc-svn-working-revision (file)
+ "SVN-specific version of `vc-working-revision'."
+ ;; There is no need to consult RCS headers under SVN, because we
+ ;; get the workfile version for free when we recognize that a file
+ ;; is registered in SVN.
+ (vc-svn-registered file)
+ (vc-file-getprop file 'vc-working-revision))
+
+;; vc-svn-mode-line-string doesn't exist because the default implementation
+;; works just fine.
+
+(defun vc-svn-previous-revision (file rev)
+ (let ((newrev (1- (string-to-number rev))))
+ (when (< 0 newrev)
+ (number-to-string newrev))))
+
+(defun vc-svn-next-revision (file rev)
+ (let ((newrev (1+ (string-to-number rev))))
+ ;; The "working revision" is an uneasy conceptual fit under Subversion;
+ ;; we use it as the upper bound until a better idea comes along. If the
+ ;; workfile version W coincides with the tree's latest revision R, then
+ ;; this check prevents a "no such revision: R+1" error. Otherwise, it
+ ;; inhibits showing of W+1 through R, which could be considered anywhere
+ ;; from gracious to impolite.
+ (unless (< (string-to-number (vc-file-getprop file 'vc-working-revision))
+ newrev)
+ (number-to-string newrev))))
+
+
+;;;
+;;; State-changing functions
+;;;
+
+(defun vc-svn-create-repo ()
+ "Create a new SVN repository."
+ (vc-do-command "*vc*" 0 "svnadmin" '("create" "SVN"))
+ (vc-do-command "*vc*" 0 vc-svn-program '(".")
+ "checkout" (concat "file://" default-directory "SVN")))
+
+(defun vc-svn-register (files &optional rev comment)
+ "Register FILES into the SVN version-control system.
+The COMMENT argument is ignored This does an add but not a commit.
+Passes either `vc-svn-register-switches' or `vc-register-switches'
+to the SVN command."
+ (apply 'vc-svn-command nil 0 files "add" (vc-switches 'SVN 'register)))
+
+(defun vc-svn-responsible-p (file)
+ "Return non-nil if SVN thinks it is responsible for FILE."
+ (file-directory-p (expand-file-name vc-svn-admin-directory
+ (if (file-directory-p file)
+ file
+ (file-name-directory file)))))
+
+(defalias 'vc-svn-could-register 'vc-svn-responsible-p
+ "Return non-nil if FILE could be registered in SVN.
+This is only possible if SVN is responsible for FILE's directory.")
+
+(defun vc-svn-checkin (files rev comment &optional extra-args-ignored)
+ "SVN-specific version of `vc-backend-checkin'."
+ (if rev (error "Committing to a specific revision is unsupported in SVN"))
+ (let ((status (apply
+ 'vc-svn-command nil 1 files "ci"
+ (nconc (list "-m" comment) (vc-switches 'SVN 'checkin)))))
+ (set-buffer "*vc*")
+ (goto-char (point-min))
+ (unless (equal status 0)
+ ;; Check checkin problem.
+ (cond
+ ((search-forward "Transaction is out of date" nil t)
+ (mapc (lambda (file) (vc-file-setprop file 'vc-state 'needs-merge))
+ files)
+ (error (substitute-command-keys
+ (concat "Up-to-date check failed: "
+ "type \\[vc-next-action] to merge in changes"))))
+ (t
+ (pop-to-buffer (current-buffer))
+ (goto-char (point-min))
+ (shrink-window-if-larger-than-buffer)
+ (error "Check-in failed"))))
+ ;; Update file properties
+ ;; (vc-file-setprop
+ ;; file 'vc-working-revision
+ ;; (vc-parse-buffer "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" 2))
+ ))
+
+(defun vc-svn-find-revision (file rev buffer)
+ "SVN-specific retrieval of a specified version into a buffer."
+ (let (process-file-side-effects)
+ (apply 'vc-svn-command
+ buffer 0 file
+ "cat"
+ (and rev (not (string= rev ""))
+ (concat "-r" rev))
+ (vc-switches 'SVN 'checkout))))
+
+(defun vc-svn-checkout (file &optional editable rev)
+ (message "Checking out %s..." file)
+ (with-current-buffer (or (get-file-buffer file) (current-buffer))
+ (vc-svn-update file editable rev (vc-switches 'SVN 'checkout)))
+ (vc-mode-line file 'SVN)
+ (message "Checking out %s...done" file))
+
+(defun vc-svn-update (file editable rev switches)
+ (if (and (file-exists-p file) (not rev))
+ ;; If no revision was specified, there's nothing to do.
+ nil
+ ;; Check out a particular version (or recreate the file).
+ (vc-file-setprop file 'vc-working-revision nil)
+ (apply 'vc-svn-command nil 0 file
+ "--non-interactive" ; bug#4280
+ "update"
+ (cond
+ ((null rev) "-rBASE")
+ ((or (eq rev t) (equal rev "")) nil)
+ (t (concat "-r" rev)))
+ switches)))
+
+(defun vc-svn-delete-file (file)
+ (vc-svn-command nil 0 file "remove"))
+
+(defun vc-svn-rename-file (old new)
+ (vc-svn-command nil 0 new "move" (file-relative-name old)))
+
+(defun vc-svn-revert (file &optional contents-done)
+ "Revert FILE to the version it was based on."
+ (unless contents-done
+ (vc-svn-command nil 0 file "revert")))
+
+(defun vc-svn-merge (file first-version &optional second-version)
+ "Merge changes into current working copy of FILE.
+The changes are between FIRST-VERSION and SECOND-VERSION."
+ (vc-svn-command nil 0 file
+ "merge"
+ "-r" (if second-version
+ (concat first-version ":" second-version)
+ first-version))
+ (vc-file-setprop file 'vc-state 'edited)
+ (with-current-buffer (get-buffer "*vc*")
+ (goto-char (point-min))
+ (if (looking-at "C ")
+ 1 ; signal conflict
+ 0))) ; signal success
+
+(defun vc-svn-merge-news (file)
+ "Merge in any new changes made to FILE."
+ (message "Merging changes into %s..." file)
+ ;; (vc-file-setprop file 'vc-working-revision nil)
+ (vc-file-setprop file 'vc-checkout-time 0)
+ (vc-svn-command nil 0 file "update")
+ ;; Analyze the merge result reported by SVN, and set
+ ;; file properties accordingly.
+ (with-current-buffer (get-buffer "*vc*")
+ (goto-char (point-min))
+ ;; get new working revision
+ (if (re-search-forward
+ "^\\(Updated to\\|At\\) revision \\([0-9]+\\)" nil t)
+ (vc-file-setprop file 'vc-working-revision (match-string 2))
+ (vc-file-setprop file 'vc-working-revision nil))
+ ;; get file status
+ (goto-char (point-min))
+ (prog1
+ (if (looking-at "At revision")
+ 0 ;; there were no news; indicate success
+ (if (re-search-forward
+ ;; Newer SVN clients have 3 columns of chars (one for the
+ ;; file's contents, then second for its properties, and the
+ ;; third for lock-grabbing info), before the 2 spaces.
+ ;; We also used to match the filename in column 0 without any
+ ;; meta-info before it, but I believe this can never happen.
+ (concat "^\\(\\([ACGDU]\\)\\(.[B ]\\)? \\)"
+ (regexp-quote (file-name-nondirectory file)))
+ nil t)
+ (cond
+ ;; Merge successful, we are in sync with repository now
+ ((string= (match-string 2) "U")
+ (vc-file-setprop file 'vc-state 'up-to-date)
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file)))
+ 0);; indicate success to the caller
+ ;; Merge successful, but our own changes are still in the file
+ ((string= (match-string 2) "G")
+ (vc-file-setprop file 'vc-state 'edited)
+ 0);; indicate success to the caller
+ ;; Conflicts detected!
+ (t
+ (vc-file-setprop file 'vc-state 'edited)
+ 1);; signal the error to the caller
+ )
+ (pop-to-buffer "*vc*")
+ (error "Couldn't analyze svn update result")))
+ (message "Merging changes into %s...done" file))))
+
+(defun vc-svn-modify-change-comment (files rev comment)
+ "Modify the change comments for a specified REV.
+You must have ssh access to the repository host, and the directory Emacs
+uses locally for temp files must also be writable by you on that host.
+This is only supported if the repository access method is either file://
+or svn+ssh://."
+ (let (tempfile host remotefile directory fileurl-p)
+ (with-temp-buffer
+ (vc-do-command (current-buffer) 0 vc-svn-program nil "info")
+ (goto-char (point-min))
+ (unless (re-search-forward "Repository Root: \\(file://\\(/.*\\)\\)\\|\\(svn\\+ssh://\\([^/]+\\)\\(/.*\\)\\)" nil t)
+ (error "Repository information is unavailable"))
+ (if (match-string 1)
+ (progn
+ (setq fileurl-p t)
+ (setq directory (match-string 2)))
+ (setq host (match-string 4))
+ (setq directory (match-string 5))
+ (setq remotefile (concat host ":" tempfile))))
+ (with-temp-file (setq tempfile (make-temp-file user-mail-address))
+ (insert comment))
+ (if fileurl-p
+ ;; Repository Root is a local file.
+ (progn
+ (unless (vc-do-command
+ "*vc*" 0 "svnadmin" nil
+ "setlog" "--bypass-hooks" directory
+ "-r" rev (format "%s" tempfile))
+ (error "Log edit failed"))
+ (delete-file tempfile))
+
+ ;; Remote repository, using svn+ssh.
+ (unless (vc-do-command "*vc*" 0 "scp" nil "-q" tempfile remotefile)
+ (error "Copy of comment to %s failed" remotefile))
+ (unless (vc-do-command
+ "*vc*" 0 "ssh" nil "-q" host
+ (format "svnadmin setlog --bypass-hooks %s -r %s %s; rm %s"
+ directory rev tempfile tempfile))
+ (error "Log edit failed")))))
+
+;;;
+;;; History functions
+;;;
+
+(defvar log-view-per-file-logs)
+
+(define-derived-mode vc-svn-log-view-mode log-view-mode "SVN-Log-View"
+ (require 'add-log)
+ (set (make-local-variable 'log-view-per-file-logs) nil))
+
+(defun vc-svn-print-log (files buffer &optional shortlog start-revision limit)
+ "Get change log(s) associated with FILES."
+ (save-current-buffer
+ (vc-setup-buffer buffer)
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ (if files
+ (dolist (file files)
+ (insert "Working file: " file "\n")
+ (apply
+ 'vc-svn-command
+ buffer
+ 'async
+ ;; (if (and (= (length files) 1) (vc-stay-local-p file 'SVN)) 'async 0)
+ (list file)
+ "log"
+ (append
+ (list
+ (if start-revision
+ (format "-r%s" start-revision)
+ ;; By default Subversion only shows the log up to the
+ ;; working revision, whereas we also want the log of the
+ ;; subsequent commits. At least that's what the
+ ;; vc-cvs.el code does.
+ "-rHEAD:0"))
+ (when limit (list "--limit" (format "%s" limit))))))
+ ;; Dump log for the entire directory.
+ (apply 'vc-svn-command buffer 0 nil "log"
+ (append
+ (list
+ (if start-revision (format "-r%s" start-revision) "-rHEAD:0"))
+ (when limit (list "--limit" (format "%s" limit)))))))))
+
+(defun vc-svn-diff (files &optional oldvers newvers buffer)
+ "Get a difference report using SVN between two revisions of fileset FILES."
+ (and oldvers
+ (not newvers)
+ files
+ (catch 'no
+ (dolist (f files)
+ (or (equal oldvers (vc-working-revision f))
+ (throw 'no nil)))
+ t)
+ ;; Use nil rather than the current revision because svn handles
+ ;; it better (i.e. locally). Note that if _any_ of the files
+ ;; has a different revision, we fetch the lot, which is
+ ;; obviously sub-optimal.
+ (setq oldvers nil))
+ (let* ((switches
+ (if vc-svn-diff-switches
+ (vc-switches 'SVN 'diff)
+ (list "--diff-cmd=diff" "-x"
+ (mapconcat 'identity (vc-switches nil 'diff) " "))))
+ (async (and (not vc-disable-async-diff)
+ (vc-stay-local-p files 'SVN)
+ (or oldvers newvers)))) ; Svn diffs those locally.
+ (apply 'vc-svn-command buffer
+ (if async 'async 0)
+ files "diff"
+ (append
+ switches
+ (when oldvers
+ (list "-r" (if newvers (concat oldvers ":" newvers)
+ oldvers)))))
+ (if async 1 ; async diff => pessimistic assumption
+ ;; For some reason `svn diff' does not return a useful
+ ;; status w.r.t whether the diff was empty or not.
+ (buffer-size (get-buffer buffer)))))
+
+;;;
+;;; Tag system
+;;;
+
+(defun vc-svn-create-tag (dir name branchp)
+ "Assign to DIR's current revision a given NAME.
+If BRANCHP is non-nil, the name is created as a branch (and the current
+workspace is immediately moved to that new branch).
+NAME is assumed to be a URL."
+ (vc-svn-command nil 0 dir "copy" name)
+ (when branchp (vc-svn-retrieve-tag dir name nil)))
+
+(defun vc-svn-retrieve-tag (dir name update)
+ "Retrieve a tag at and below DIR.
+NAME is the name of the tag; if it is empty, do a `svn update'.
+If UPDATE is non-nil, then update (resynch) any affected buffers.
+NAME is assumed to be a URL."
+ (vc-svn-command nil 0 dir "switch" name)
+ ;; FIXME: parse the output and obey `update'.
+ )
+
+;;;
+;;; Miscellaneous
+;;;
+
+;; Subversion makes backups for us, so don't bother.
+;; (defun vc-svn-make-version-backups-p (file)
+;; "Return non-nil if version backups should be made for FILE."
+;; (vc-stay-local-p file 'SVN))
+
+(defun vc-svn-check-headers ()
+ "Check if the current file has any headers in it."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))
+
+
+;;;
+;;; Internal functions
+;;;
+
+(defun vc-svn-command (buffer okstatus file-or-list &rest flags)
+ "A wrapper around `vc-do-command' for use in vc-svn.el.
+The difference to vc-do-command is that this function always invokes `svn',
+and that it passes `vc-svn-global-switches' to it before FLAGS."
+ (apply 'vc-do-command (or buffer "*vc*") okstatus vc-svn-program file-or-list
+ (if (stringp vc-svn-global-switches)
+ (cons vc-svn-global-switches flags)
+ (append vc-svn-global-switches
+ flags))))
+
+(defun vc-svn-repository-hostname (dirname)
+ (with-temp-buffer
+ (let ((coding-system-for-read
+ (or file-name-coding-system
+ default-file-name-coding-system)))
+ (vc-insert-file (expand-file-name (concat vc-svn-admin-directory
+ "/entries")
+ dirname)))
+ (goto-char (point-min))
+ (when (re-search-forward
+ ;; Old `svn' used name="svn:this_dir", newer use just name="".
+ (concat "name=\"\\(?:svn:this_dir\\)?\"[\n\t ]*"
+ "\\(?:[-a-z]+=\"[^\"]*\"[\n\t ]*\\)*?"
+ "url=\"\\(?1:[^\"]+\\)\""
+ ;; Yet newer ones don't use XML any more.
+ "\\|^\ndir\n[0-9]+\n\\(?1:.*\\)") nil t)
+ ;; This is not a hostname but a URL. This may actually be considered
+ ;; as a feature since it allows vc-svn-stay-local to specify different
+ ;; behavior for different modules on the same server.
+ (match-string 1))))
+
+(defun vc-svn-resolve-when-done ()
+ "Call \"svn resolved\" if the conflict markers have been removed."
+ (save-excursion
+ (goto-char (point-min))
+ (unless (re-search-forward "^<<<<<<< " nil t)
+ (vc-svn-command nil 0 buffer-file-name "resolved")
+ ;; Remove the hook so that it is not called multiple times.
+ (remove-hook 'after-save-hook 'vc-svn-resolve-when-done t))))
+
+;; Inspired by vc-arch-find-file-hook.
+(defun vc-svn-find-file-hook ()
+ (when (eq ?C (vc-file-getprop buffer-file-name 'vc-svn-status))
+ ;; If the file is marked as "conflicted", then we should try and call
+ ;; "svn resolved" when applicable.
+ (if (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "^<<<<<<< " nil t))
+ ;; There are conflict markers.
+ (progn
+ (smerge-start-session)
+ (add-hook 'after-save-hook 'vc-svn-resolve-when-done nil t))
+ ;; There are no conflict markers. This is problematic: maybe it means
+ ;; the conflict has been resolved and we should immediately call "svn
+ ;; resolved", or it means that the file's type does not allow Svn to
+ ;; use conflict markers in which case we don't really know what to do.
+ ;; So let's just punt for now.
+ nil)
+ (message "There are unresolved conflicts in this file")))
+
+(defun vc-svn-parse-status (&optional filename)
+ "Parse output of \"svn status\" command in the current buffer.
+Set file properties accordingly. Unless FILENAME is non-nil, parse only
+information about FILENAME and return its status."
+ (let (file status)
+ (goto-char (point-min))
+ (while (re-search-forward
+ ;; Ignore the files with status X.
+ "^\\(?:\\?\\|[ ACDGIMR!~][ MC][ L][ +][ S]..\\([ *]\\) +\\([-0-9]+\\) +\\([0-9?]+\\) +\\([^ ]+\\)\\) +" nil t)
+ ;; If the username contains spaces, the output format is ambiguous,
+ ;; so don't trust the output's filename unless we have to.
+ (setq file (or filename
+ (expand-file-name
+ (buffer-substring (point) (line-end-position)))))
+ (setq status (char-after (line-beginning-position)))
+ (if (eq status ??)
+ (vc-file-setprop file 'vc-state 'unregistered)
+ ;; Use the last-modified revision, so that searching in vc-print-log
+ ;; output works.
+ (vc-file-setprop file 'vc-working-revision (match-string 3))
+ ;; Remember Svn's own status.
+ (vc-file-setprop file 'vc-svn-status status)
+ (vc-file-setprop
+ file 'vc-state
+ (cond
+ ((eq status ?\ )
+ (if (eq (char-after (match-beginning 1)) ?*)
+ 'needs-update
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file)))
+ 'up-to-date))
+ ((eq status ?A)
+ ;; If the file was actually copied, (match-string 2) is "-".
+ (vc-file-setprop file 'vc-working-revision "0")
+ (vc-file-setprop file 'vc-checkout-time 0)
+ 'added)
+ ((eq status ?C)
+ (vc-file-setprop file 'vc-state 'conflict))
+ ((eq status '?M)
+ (if (eq (char-after (match-beginning 1)) ?*)
+ 'needs-merge
+ 'edited))
+ ((eq status ?I)
+ (vc-file-setprop file 'vc-state 'ignored))
+ ((memq status '(?D ?R))
+ (vc-file-setprop file 'vc-state 'removed))
+ (t 'edited)))))
+ (when filename (vc-file-getprop filename 'vc-state))))
+
+(defun vc-svn-valid-symbolic-tag-name-p (tag)
+ "Return non-nil if TAG is a valid symbolic tag name."
+ ;; According to the SVN manual, a valid symbolic tag must start with
+ ;; an uppercase or lowercase letter and can contain uppercase and
+ ;; lowercase letters, digits, `-', and `_'.
+ (and (string-match "^[a-zA-Z]" tag)
+ (not (string-match "[^a-z0-9A-Z-_]" tag))))
+
+(defun vc-svn-valid-revision-number-p (tag)
+ "Return non-nil if TAG is a valid revision number."
+ (and (string-match "^[0-9]" tag)
+ (not (string-match "[^0-9]" tag))))
+
+;; Support for `svn annotate'
+
+(defun vc-svn-annotate-command (file buf &optional rev)
+ (vc-svn-command buf 'async file "annotate" (if rev (concat "-r" rev))))
+
+(defun vc-svn-annotate-time-of-rev (rev)
+ ;; Arbitrarily assume 10 commmits per day.
+ (/ (string-to-number rev) 10.0))
+
+(defvar vc-annotate-parent-rev)
+
+(defun vc-svn-annotate-current-time ()
+ (vc-svn-annotate-time-of-rev vc-annotate-parent-rev))
+
+(defconst vc-svn-annotate-re "[ \t]*\\([0-9]+\\)[ \t]+[^\t ]+ ")
+
+(defun vc-svn-annotate-time ()
+ (when (looking-at vc-svn-annotate-re)
+ (goto-char (match-end 0))
+ (vc-svn-annotate-time-of-rev (match-string 1))))
+
+(defun vc-svn-annotate-extract-revision-at-line ()
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at vc-svn-annotate-re) (match-string 1))))
+
+(defun vc-svn-revision-table (files)
+ (let ((vc-svn-revisions '()))
+ (with-current-buffer "*vc*"
+ (vc-svn-command nil 0 files "log" "-q")
+ (goto-char (point-min))
+ (forward-line)
+ (let ((start (point-min))
+ (loglines (buffer-substring-no-properties (point-min)
+ (point-max))))
+ (while (string-match "^r\\([0-9]+\\) " loglines)
+ (push (match-string 1 loglines) vc-svn-revisions)
+ (setq start (+ start (match-end 0)))
+ (setq loglines (buffer-substring-no-properties start (point-max)))))
+ vc-svn-revisions)))
+
+(provide 'vc-svn)
+
+;; arch-tag: 02f10c68-2b4d-453a-90fc-1eee6cfb268d
+;;; vc-svn.el ends here
--- /dev/null
+;;; vc.el --- drive a version-control system from within Emacs
+
+;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 2000,
+;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
+
+;; Author: FSF (see below for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Credits:
+
+;; VC was initially designed and implemented by Eric S. Raymond
+;; <esr@thyrsus.com> in 1992. Over the years, many other people have
+;; contributed substantial amounts of work to VC. These include:
+;;
+;; Per Cederqvist <ceder@lysator.liu.se>
+;; Paul Eggert <eggert@twinsun.com>
+;; Sebastian Kremer <sk@thp.uni-koeln.de>
+;; Martin Lorentzson <martinl@gnu.org>
+;; Dave Love <fx@gnu.org>
+;; Stefan Monnier <monnier@cs.yale.edu>
+;; Thien-Thi Nguyen <ttn@gnu.org>
+;; Dan Nicolaescu <dann@ics.uci.edu>
+;; J.D. Smith <jdsmith@alum.mit.edu>
+;; Andre Spiegel <spiegel@gnu.org>
+;; Richard Stallman <rms@gnu.org>
+;;
+;; In July 2007 ESR returned and redesigned the mode to cope better
+;; with modern version-control systems that do commits by fileset
+;; rather than per individual file.
+;;
+;; If you maintain a client of the mode or customize it in your .emacs,
+;; note that some backend functions which formerly took single file arguments
+;; now take a list of files. These include: register, checkin, print-log,
+;; rollback, and diff.
+
+;;; Commentary:
+
+;; This mode is fully documented in the Emacs user's manual.
+;;
+;; Supported version-control systems presently include CVS, RCS, GNU
+;; Arch, Subversion, Bzr, Git, Mercurial, Monotone and SCCS
+;; (or its free replacement, CSSC).
+;;
+;; If your site uses the ChangeLog convention supported by Emacs, the
+;; function `log-edit-comment-to-change-log' could prove a useful checkin hook,
+;; although you might prefer to use C-c C-a (i.e. `log-edit-insert-changelog')
+;; from the commit buffer instead or to set `log-edit-setup-invert'.
+;;
+;; When using SCCS, RCS, CVS: be careful not to do repo surgery, or
+;; operations like registrations and deletions and renames, outside VC
+;; while VC is running. The support for these systems was designed
+;; when disks were much slower, and the code maintains a lot of
+;; internal state in order to reduce expensive operations to a
+;; minimum. Thus, if you mess with the repo while VC's back is turned,
+;; VC may get seriously confused.
+;;
+;; When using Subversion or a later system, anything you do outside VC
+;; *through the VCS tools* should safely interlock with VC
+;; operations. Under these VC does little state caching, because local
+;; operations are assumed to be fast. The dividing line is
+;;
+;; ADDING SUPPORT FOR OTHER BACKENDS
+;;
+;; VC can use arbitrary version control systems as a backend. To add
+;; support for a new backend named SYS, write a library vc-sys.el that
+;; contains functions of the form `vc-sys-...' (note that SYS is in lower
+;; case for the function and library names). VC will use that library if
+;; you put the symbol SYS somewhere into the list of
+;; `vc-handled-backends'. Then, for example, if `vc-sys-registered'
+;; returns non-nil for a file, all SYS-specific versions of VC commands
+;; will be available for that file.
+;;
+;; VC keeps some per-file information in the form of properties (see
+;; vc-file-set/getprop in vc-hooks.el). The backend-specific functions
+;; do not generally need to be aware of these properties. For example,
+;; `vc-sys-working-revision' should compute the working revision and
+;; return it; it should not look it up in the property, and it needn't
+;; store it there either. However, if a backend-specific function does
+;; store a value in a property, that value takes precedence over any
+;; value that the generic code might want to set (check for uses of
+;; the macro `with-vc-properties' in vc.el).
+;;
+;; In the list of functions below, each identifier needs to be prepended
+;; with `vc-sys-'. Some of the functions are mandatory (marked with a
+;; `*'), others are optional (`-').
+;;
+;; BACKEND PROPERTIES
+;;
+;; * revision-granularity
+;;
+;; Takes no arguments. Returns either 'file or 'repository. Backends
+;; that return 'file have per-file revision numbering; backends
+;; that return 'repository have per-repository revision numbering,
+;; so a revision level implicitly identifies a changeset
+;;
+;; STATE-QUERYING FUNCTIONS
+;;
+;; * registered (file)
+;;
+;; Return non-nil if FILE is registered in this backend. Both this
+;; function as well as `state' should be careful to fail gracefully
+;; in the event that the backend executable is absent. It is
+;; preferable that this function's body is autoloaded, that way only
+;; calling vc-registered does not cause the backend to be loaded
+;; (all the vc-FOO-registered functions are called to try to find
+;; the controlling backend for FILE.
+;;
+;; * state (file)
+;;
+;; Return the current version control state of FILE. For a list of
+;; possible values, see `vc-state'. This function should do a full and
+;; reliable state computation; it is usually called immediately after
+;; C-x v v. If you want to use a faster heuristic when visiting a
+;; file, put that into `state-heuristic' below. Note that under most
+;; VCSes this won't be called at all, dir-status is used instead.
+;;
+;; - state-heuristic (file)
+;;
+;; If provided, this function is used to estimate the version control
+;; state of FILE at visiting time. It should be considerably faster
+;; than the implementation of `state'. For a list of possible values,
+;; see the doc string of `vc-state'.
+;;
+;; - dir-status (dir update-function)
+;;
+;; Produce RESULT: a list of lists of the form (FILE VC-STATE EXTRA)
+;; for the files in DIR.
+;; EXTRA can be used for backend specific information about FILE.
+;; If a command needs to be run to compute this list, it should be
+;; run asynchronously using (current-buffer) as the buffer for the
+;; command. When RESULT is computed, it should be passed back by
+;; doing: (funcall UPDATE-FUNCTION RESULT nil).
+;; If the backend uses a process filter, hence it produces partial results,
+;; they can be passed back by doing:
+;; (funcall UPDATE-FUNCTION RESULT t)
+;; and then do a (funcall UPDATE-FUNCTION RESULT nil)
+;; when all the results have been computed.
+;; To provide more backend specific functionality for `vc-dir'
+;; the following functions might be needed: `dir-extra-headers',
+;; `dir-printer', `extra-dir-menu' and `dir-status-files'.
+;;
+;; - dir-status-files (dir files default-state update-function)
+;;
+;; This function is identical to dir-status except that it should
+;; only report status for the specified FILES. Also it needs to
+;; report on all requested files, including up-to-date or ignored
+;; files. If not provided, the default is to consider that the files
+;; are in DEFAULT-STATE.
+;;
+;; - dir-extra-headers (dir)
+;;
+;; Return a string that will be added to the *vc-dir* buffer header.
+;;
+;; - dir-printer (fileinfo)
+;;
+;; Pretty print the `vc-dir-fileinfo' FILEINFO.
+;; If a backend needs to show more information than the default FILE
+;; and STATE in the vc-dir listing, it can store that extra
+;; information in `vc-dir-fileinfo->extra'. This function can be
+;; used to display that extra information in the *vc-dir* buffer.
+;;
+;; - status-fileinfo-extra (file)
+;;
+;; Compute `vc-dir-fileinfo->extra' for FILE.
+;;
+;; * working-revision (file)
+;;
+;; Return the working revision of FILE. This is the revision fetched
+;; by the last checkout or upate, not necessarily the same thing as the
+;; head or tip revision. Should return "0" for a file added but not yet
+;; committed.
+;;
+;; - latest-on-branch-p (file)
+;;
+;; Return non-nil if the working revision of FILE is the latest revision
+;; on its branch (many VCSes call this the 'tip' or 'head' revision).
+;; The default implementation always returns t, which means that
+;; working with non-current revisions is not supported by default.
+;;
+;; * checkout-model (files)
+;;
+;; Indicate whether FILES need to be "checked out" before they can be
+;; edited. See `vc-checkout-model' for a list of possible values.
+;;
+;; - workfile-unchanged-p (file)
+;;
+;; Return non-nil if FILE is unchanged from the working revision.
+;; This function should do a brief comparison of FILE's contents
+;; with those of the repository copy of the working revision. If
+;; the backend does not have such a brief-comparison feature, the
+;; default implementation of this function can be used, which
+;; delegates to a full vc-BACKEND-diff. (Note that vc-BACKEND-diff
+;; must not run asynchronously in this case, see variable
+;; `vc-disable-async-diff'.)
+;;
+;; - mode-line-string (file)
+;;
+;; If provided, this function should return the VC-specific mode
+;; line string for FILE. The returned string should have a
+;; `help-echo' property which is the text to be displayed as a
+;; tooltip when the mouse hovers over the VC entry on the mode-line.
+;; The default implementation deals well with all states that
+;; `vc-state' can return.
+;;
+;; STATE-CHANGING FUNCTIONS
+;;
+;; * create-repo (backend)
+;;
+;; Create an empty repository in the current directory and initialize
+;; it so VC mode can add files to it. For file-oriented systems, this
+;; need do no more than create a subdirectory with the right name.
+;;
+;; * register (files &optional rev comment)
+;;
+;; Register FILES in this backend. Optionally, an initial revision REV
+;; and an initial description of the file, COMMENT, may be specified,
+;; but it is not guaranteed that the backend will do anything with this.
+;; The implementation should pass the value of vc-register-switches
+;; to the backend command. (Note: in older versions of VC, this
+;; command took a single file argument and not a list.)
+;;
+;; - init-revision (file)
+;;
+;; The initial revision to use when registering FILE if one is not
+;; specified by the user. If not provided, the variable
+;; vc-default-init-revision is used instead.
+;;
+;; - responsible-p (file)
+;;
+;; Return non-nil if this backend considers itself "responsible" for
+;; FILE, which can also be a directory. This function is used to find
+;; out what backend to use for registration of new files and for things
+;; like change log generation. The default implementation always
+;; returns nil.
+;;
+;; - could-register (file)
+;;
+;; Return non-nil if FILE could be registered under this backend. The
+;; default implementation always returns t.
+;;
+;; - receive-file (file rev)
+;;
+;; Let this backend "receive" a file that is already registered under
+;; another backend. The default implementation simply calls `register'
+;; for FILE, but it can be overridden to do something more specific,
+;; e.g. keep revision numbers consistent or choose editing modes for
+;; FILE that resemble those of the other backend.
+;;
+;; - unregister (file)
+;;
+;; Unregister FILE from this backend. This is only needed if this
+;; backend may be used as a "more local" backend for temporary editing.
+;;
+;; * checkin (files rev comment)
+;;
+;; Commit changes in FILES to this backend. REV is a historical artifact
+;; and should be ignored. COMMENT is used as a check-in comment.
+;; The implementation should pass the value of vc-checkin-switches to
+;; the backend command.
+;;
+;; * find-revision (file rev buffer)
+;;
+;; Fetch revision REV of file FILE and put it into BUFFER.
+;; If REV is the empty string, fetch the head of the trunk.
+;; The implementation should pass the value of vc-checkout-switches
+;; to the backend command.
+;;
+;; * checkout (file &optional editable rev)
+;;
+;; Check out revision REV of FILE into the working area. If EDITABLE
+;; is non-nil, FILE should be writable by the user and if locking is
+;; used for FILE, a lock should also be set. If REV is non-nil, that
+;; is the revision to check out (default is the working revision).
+;; If REV is t, that means to check out the head of the current branch;
+;; if it is the empty string, check out the head of the trunk.
+;; The implementation should pass the value of vc-checkout-switches
+;; to the backend command.
+;;
+;; * revert (file &optional contents-done)
+;;
+;; Revert FILE back to the working revision. If optional
+;; arg CONTENTS-DONE is non-nil, then the contents of FILE have
+;; already been reverted from a version backup, and this function
+;; only needs to update the status of FILE within the backend.
+;; If FILE is in the `added' state it should be returned to the
+;; `unregistered' state.
+;;
+;; - rollback (files)
+;;
+;; Remove the tip revision of each of FILES from the repository. If
+;; this function is not provided, trying to cancel a revision is
+;; caught as an error. (Most backends don't provide it.) (Also
+;; note that older versions of this backend command were called
+;; 'cancel-version' and took a single file arg, not a list of
+;; files.)
+;;
+;; - merge (file rev1 rev2)
+;;
+;; Merge the changes between REV1 and REV2 into the current working file.
+;;
+;; - merge-news (file)
+;;
+;; Merge recent changes from the current branch into FILE.
+;;
+;; - steal-lock (file &optional revision)
+;;
+;; Steal any lock on the working revision of FILE, or on REVISION if
+;; that is provided. This function is only needed if locking is
+;; used for files under this backend, and if files can indeed be
+;; locked by other users.
+;;
+;; - modify-change-comment (files rev comment)
+;;
+;; Modify the change comments associated with the files at the
+;; given revision. This is optional, many backends do not support it.
+;;
+;; - mark-resolved (files)
+;;
+;; Mark conflicts as resolved. Some VC systems need to run a
+;; command to mark conflicts as resolved.
+;;
+;; HISTORY FUNCTIONS
+;;
+;; * print-log (files buffer &optional shortlog start-revision limit)
+;;
+;; Insert the revision log for FILES into BUFFER.
+;; If SHORTLOG is true insert a short version of the log.
+;; If LIMIT is true insert only insert LIMIT log entries. If the
+;; backend does not support limiting the number of entries to show
+;; it should return `limit-unsupported'.
+;; If START-REVISION is given, then show the log starting from the
+;; revision. At this point START-REVISION is only required to work
+;; in conjunction with LIMIT = 1.
+;;
+;; * log-outgoing (backend remote-location)
+;;
+;; Insert in BUFFER the revision log for the changes that will be
+;; sent when performing a push operation to REMOTE-LOCATION.
+;;
+;; * log-incoming (backend remote-location)
+;;
+;; Insert in BUFFER the revision log for the changes that will be
+;; received when performing a pull operation from REMOTE-LOCATION.
+;;
+;; - log-view-mode ()
+;;
+;; Mode to use for the output of print-log. This defaults to
+;; `log-view-mode' and is expected to be changed (if at all) to a derived
+;; mode of `log-view-mode'.
+;;
+;; - show-log-entry (revision)
+;;
+;; If provided, search the log entry for REVISION in the current buffer,
+;; and make sure it is displayed in the buffer's window. The default
+;; implementation of this function works for RCS-style logs.
+;;
+;; - comment-history (file)
+;;
+;; Return a string containing all log entries that were made for FILE.
+;; This is used for transferring a file from one backend to another,
+;; retaining comment information.
+;;
+;; - update-changelog (files)
+;;
+;; Using recent log entries, create ChangeLog entries for FILES, or for
+;; all files at or below the default-directory if FILES is nil. The
+;; default implementation runs rcs2log, which handles RCS- and
+;; CVS-style logs.
+;;
+;; * diff (files &optional rev1 rev2 buffer)
+;;
+;; Insert the diff for FILE into BUFFER, or the *vc-diff* buffer if
+;; BUFFER is nil. If REV1 and REV2 are non-nil, report differences
+;; from REV1 to REV2. If REV1 is nil, use the working revision (as
+;; found in the repository) as the older revision; if REV2 is nil,
+;; use the current working-copy contents as the newer revision. This
+;; function should pass the value of (vc-switches BACKEND 'diff) to
+;; the backend command. It should return a status of either 0 (no
+;; differences found), or 1 (either non-empty diff or the diff is
+;; run asynchronously).
+;;
+;; - revision-completion-table (files)
+;;
+;; Return a completion table for existing revisions of FILES.
+;; The default is to not use any completion table.
+;;
+;; - annotate-command (file buf &optional rev)
+;;
+;; If this function is provided, it should produce an annotated display
+;; of FILE in BUF, relative to revision REV. Annotation means each line
+;; of FILE displayed is prefixed with version information associated with
+;; its addition (deleted lines leave no history) and that the text of the
+;; file is fontified according to age.
+;;
+;; - annotate-time ()
+;;
+;; Only required if `annotate-command' is defined for the backend.
+;; Return the time of the next line of annotation at or after point,
+;; as a floating point fractional number of days. The helper
+;; function `vc-annotate-convert-time' may be useful for converting
+;; multi-part times as returned by `current-time' and `encode-time'
+;; to this format. Return nil if no more lines of annotation appear
+;; in the buffer. You can safely assume that point is placed at the
+;; beginning of each line, starting at `point-min'. The buffer that
+;; point is placed in is the Annotate output, as defined by the
+;; relevant backend. This function also affects how much of the line
+;; is fontified; where it leaves point is where fontification begins.
+;;
+;; - annotate-current-time ()
+;;
+;; Only required if `annotate-command' is defined for the backend,
+;; AND you'd like the current time considered to be anything besides
+;; (vc-annotate-convert-time (current-time)) -- i.e. the current
+;; time with hours, minutes, and seconds included. Probably safe to
+;; ignore. Return the current-time, in units of fractional days.
+;;
+;; - annotate-extract-revision-at-line ()
+;;
+;; Only required if `annotate-command' is defined for the backend.
+;; Invoked from a buffer in vc-annotate-mode, return the revision
+;; corresponding to the current line, or nil if there is no revision
+;; corresponding to the current line.
+;; If the backend supports annotating through copies and renames,
+;; and displays a file name and a revision, then return a cons
+;; (REVISION . FILENAME).
+;;
+;; TAG SYSTEM
+;;
+;; - create-tag (dir name branchp)
+;;
+;; Attach the tag NAME to the state of the working copy. This
+;; should make sure that files are up-to-date before proceeding with
+;; the action. DIR can also be a file and if BRANCHP is specified,
+;; NAME should be created as a branch and DIR should be checked out
+;; under this new branch. The default implementation does not
+;; support branches but does a sanity check, a tree traversal and
+;; assigns the tag to each file.
+;;
+;; - retrieve-tag (dir name update)
+;;
+;; Retrieve the version tagged by NAME of all registered files at or below DIR.
+;; If UPDATE is non-nil, then update buffers of any files in the
+;; tag that are currently visited. The default implementation
+;; does a sanity check whether there aren't any uncommitted changes at
+;; or below DIR, and then performs a tree walk, using the `checkout'
+;; function to retrieve the corresponding revisions.
+;;
+;; MISCELLANEOUS
+;;
+;; - make-version-backups-p (file)
+;;
+;; Return non-nil if unmodified repository revisions of FILE should be
+;; backed up locally. If this is done, VC can perform `diff' and
+;; `revert' operations itself, without calling the backend system. The
+;; default implementation always returns nil.
+;;
+;; - root (file)
+;; Return the root of the VC controlled hierarchy for file.
+;;
+;; - repository-hostname (dirname)
+;;
+;; Return the hostname that the backend will have to contact
+;; in order to operate on a file in DIRNAME. If the return value
+;; is nil, it means that the repository is local.
+;; This function is used in `vc-stay-local-p' which backends can use
+;; for their convenience.
+;;
+;; - previous-revision (file rev)
+;;
+;; Return the revision number that precedes REV for FILE, or nil if no such
+;; revision exists.
+;;
+;; - next-revision (file rev)
+;;
+;; Return the revision number that follows REV for FILE, or nil if no such
+;; revision exists.
+;;
+;; - log-edit-mode ()
+;;
+;; Turn on the mode used for editing the check in log. This
+;; defaults to `log-edit-mode'. If changed, it should use a mode
+;; derived from`log-edit-mode'.
+;;
+;; - check-headers ()
+;;
+;; Return non-nil if the current buffer contains any version headers.
+;;
+;; - clear-headers ()
+;;
+;; In the current buffer, reset all version headers to their unexpanded
+;; form. This function should be provided if the state-querying code
+;; for this backend uses the version headers to determine the state of
+;; a file. This function will then be called whenever VC changes the
+;; version control state in such a way that the headers would give
+;; wrong information.
+;;
+;; - delete-file (file)
+;;
+;; Delete FILE and mark it as deleted in the repository. If this
+;; function is not provided, the command `vc-delete-file' will
+;; signal an error.
+;;
+;; - rename-file (old new)
+;;
+;; Rename file OLD to NEW, both in the working area and in the
+;; repository. If this function is not provided, the renaming
+;; will be done by (vc-delete-file old) and (vc-register new).
+;;
+;; - find-file-hook ()
+;;
+;; Operation called in current buffer when opening a file. This can
+;; be used by the backend to setup some local variables it might need.
+;;
+;; - extra-menu ()
+;;
+;; Return a menu keymap, the items in the keymap will appear at the
+;; end of the Version Control menu. The goal is to allow backends
+;; to specify extra menu items that appear in the VC menu. This way
+;; you can provide menu entries for functionality that is specific
+;; to your backend and which does not map to any of the VC generic
+;; concepts.
+;;
+;; - extra-dir-menu ()
+;;
+;; Return a menu keymap, the items in the keymap will appear at the
+;; end of the VC Status menu. The goal is to allow backends to
+;; specify extra menu items that appear in the VC Status menu. This
+;; makes it possible to provide menu entries for functionality that
+;; is specific to a backend and which does not map to any of the VC
+;; generic concepts.
+;;
+;; - conflicted-files (dir)
+;;
+;; Return the list of files where conflict resolution is needed in
+;; the project that contains DIR.
+;; FIXME: what should it do with non-text conflicts?
+
+;;; Todo:
+
+;; - Get rid of the "master file" terminology.
+
+;; - Add key-binding for vc-delete-file.
+
+;;;; New Primitives:
+;;
+;; - deal with push/pull operations.
+;;
+;; - add a mechanism for editing the underlying VCS's list of files
+;; to be ignored, when that's possible.
+;;
+;;;; Primitives that need changing:
+;;
+;; - vc-update/vc-merge should deal with VC systems that don't
+;; update/merge on a file basis, but on a whole repository basis.
+;; vc-update and vc-merge assume the arguments are always files,
+;; they don't deal with directories. Make sure the *vc-dir* buffer
+;; is updated after these operations.
+;; At least bzr, git and hg should benefit from this.
+;;
+;;;; Improved branch and tag handling:
+;;
+;; - add a generic mechanism for remembering the current branch names,
+;; display the branch name in the mode-line. Replace
+;; vc-cvs-sticky-tag with that.
+;;
+;;;; Internal cleanups:
+;;
+;; - backends that care about vc-stay-local should try to take it into
+;; account for vc-dir. Is this likely to be useful??? YES!
+;;
+;; - vc-expand-dirs should take a backend parameter and only look for
+;; files managed by that backend.
+;;
+;; - Another important thing: merge all the status-like backend operations.
+;; We should remove dir-status, state, and dir-status-files, and
+;; replace them with just `status' which takes a fileset and a continuation
+;; (like dir-status) and returns a buffer in which the process(es) are run
+;; (or nil if it worked synchronously). Hopefully we can define the old
+;; 4 operations in term of this one.
+;;
+;;;; Other
+;;
+;; - when a file is in `conflict' state, turn on smerge-mode.
+;;
+;; - figure out what to do with conflicts that are not caused by the
+;; file contents, but by metadata or other causes. Example: File A
+;; gets renamed to B in one branch and to C in another and you merge
+;; the two branches. Or you locally add file FOO and then pull a
+;; change that also adds a new file FOO, ...
+;;
+;; - make it easier to write logs. Maybe C-x 4 a should add to the log
+;; buffer, if one is present, instead of adding to the ChangeLog.
+;;
+;; - When vc-next-action calls vc-checkin it could pre-fill the
+;; *VC-log* buffer with some obvious items: the list of files that
+;; were added, the list of files that were removed. If the diff is
+;; available, maybe it could even call something like
+;; `diff-add-change-log-entries-other-window' to create a detailed
+;; skeleton for the log...
+;;
+;; - most vc-dir backends need more work. They might need to
+;; provide custom headers, use the `extra' field and deal with all
+;; possible VC states.
+;;
+;; - add a function that calls vc-dir to `find-directory-functions'.
+;;
+;; - vc-diff, vc-annotate, etc. need to deal better with unregistered
+;; files. Now that unregistered and ignored files are shown in
+;; vc-dir, it is possible that these commands are called
+;; for unregistered/ignored files.
+;;
+;; - vc-next-action needs work in order to work with multiple
+;; backends: `vc-state' returns the state for the default backend,
+;; not for the backend in the current *vc-dir* buffer.
+;;
+;; - vc-dir-kill-dir-status-process should not be specific to dir-status,
+;; it should work for other async commands done through vc-do-command
+;; as well,
+;;
+;; - vc-dir toolbar needs more icons.
+;;
+;; - The backends should avoid using `vc-file-setprop' and `vc-file-getprop'.
+;;
+;;; Code:
+
+(require 'vc-hooks)
+(require 'vc-dispatcher)
+
+(eval-when-compile
+ (require 'cl)
+ (require 'dired))
+
+(unless (assoc 'vc-parent-buffer minor-mode-alist)
+ (setq minor-mode-alist
+ (cons '(vc-parent-buffer vc-parent-buffer-name)
+ minor-mode-alist)))
+
+;; General customization
+
+(defgroup vc nil
+ "Version-control system in Emacs."
+ :group 'tools)
+
+(defcustom vc-initial-comment nil
+ "If non-nil, prompt for initial comment when a file is registered."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-default-init-revision "1.1"
+ "A string used as the default revision number when a new file is registered.
+This can be overridden by giving a prefix argument to \\[vc-register]. This
+can also be overridden by a particular VC backend."
+ :type 'string
+ :group 'vc
+ :version "20.3")
+
+(defcustom vc-checkin-switches nil
+ "A string or list of strings specifying extra switches for checkin.
+These are passed to the checkin program by \\[vc-checkin]."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :group 'vc)
+
+(defcustom vc-checkout-switches nil
+ "A string or list of strings specifying extra switches for checkout.
+These are passed to the checkout program by \\[vc-checkout]."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :group 'vc)
+
+(defcustom vc-register-switches nil
+ "A string or list of strings; extra switches for registering a file.
+These are passed to the checkin program by \\[vc-register]."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :group 'vc)
+
+(defcustom vc-diff-switches nil
+ "A string or list of strings specifying switches for diff under VC.
+When running diff under a given BACKEND, VC uses the first
+non-nil value of `vc-BACKEND-diff-switches', `vc-diff-switches',
+and `diff-switches', in that order. Since nil means to check the
+next variable in the sequence, either of the first two may use
+the value t to mean no switches at all. `vc-diff-switches'
+should contain switches that are specific to version control, but
+not specific to any particular backend."
+ :type '(choice (const :tag "Unspecified" nil)
+ (const :tag "None" t)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :group 'vc
+ :version "21.1")
+
+(defcustom vc-diff-knows-L nil
+ "Indicates whether diff understands the -L option.
+The value is either `yes', `no', or nil. If it is nil, VC tries
+to use -L and sets this variable to remember whether it worked."
+ :type '(choice (const :tag "Work out" nil) (const yes) (const no))
+ :group 'vc)
+
+(defcustom vc-log-show-limit 2000
+ "Limit the number of items shown by the VC log commands.
+Zero means unlimited.
+Not all VC backends are able to support this feature."
+ :type 'integer
+ :group 'vc)
+
+(defcustom vc-allow-async-revert nil
+ "Specifies whether the diff during \\[vc-revert] may be asynchronous.
+Enabling this option means that you can confirm a revert operation even
+if the local changes in the file have not been found and displayed yet."
+ :type '(choice (const :tag "No" nil)
+ (const :tag "Yes" t))
+ :group 'vc
+ :version "22.1")
+
+;;;###autoload
+(defcustom vc-checkout-hook nil
+ "Normal hook (list of functions) run after checking out a file.
+See `run-hooks'."
+ :type 'hook
+ :group 'vc
+ :version "21.1")
+
+;;;###autoload
+(defcustom vc-checkin-hook nil
+ "Normal hook (list of functions) run after commit or file checkin.
+See also `log-edit-done-hook'."
+ :type 'hook
+ :options '(log-edit-comment-to-change-log)
+ :group 'vc)
+
+;;;###autoload
+(defcustom vc-before-checkin-hook nil
+ "Normal hook (list of functions) run before a commit or a file checkin.
+See `run-hooks'."
+ :type 'hook
+ :group 'vc)
+
+;; Header-insertion hair
+
+(defcustom vc-static-header-alist
+ '(("\\.c\\'" .
+ "\n#ifndef lint\nstatic char vcid[] = \"\%s\";\n#endif /* lint */\n"))
+ "Associate static header string templates with file types.
+A \%s in the template is replaced with the first string associated with
+the file's version control type in `vc-header-alist'."
+ :type '(repeat (cons :format "%v"
+ (regexp :tag "File Type")
+ (string :tag "Header String")))
+ :group 'vc)
+
+(defcustom vc-comment-alist
+ '((nroff-mode ".\\\"" ""))
+ "Special comment delimiters for generating VC headers.
+Add an entry in this list if you need to override the normal `comment-start'
+and `comment-end' variables. This will only be necessary if the mode language
+is sensitive to blank lines."
+ :type '(repeat (list :format "%v"
+ (symbol :tag "Mode")
+ (string :tag "Comment Start")
+ (string :tag "Comment End")))
+ :group 'vc)
+
+(defcustom vc-checkout-carefully (= (user-uid) 0)
+ "Non-nil means be extra-careful in checkout.
+Verify that the file really is not locked
+and that its contents match what the repository version says."
+ :type 'boolean
+ :group 'vc)
+(make-obsolete-variable 'vc-checkout-carefully
+ "the corresponding checks are always done now."
+ "21.1")
+
+\f
+;; Variables users don't need to see
+
+(defvar vc-disable-async-diff nil
+ "VC sets this to t locally to disable some async diff operations.
+Backends that offer asynchronous diffs should respect this variable
+in their implementation of vc-BACKEND-diff.")
+
+;; File property caching
+
+(defun vc-clear-context ()
+ "Clear all cached file properties."
+ (interactive)
+ (fillarray vc-file-prop-obarray 0))
+
+(defmacro with-vc-properties (files form settings)
+ "Execute FORM, then maybe set per-file properties for FILES.
+If any of FILES is actually a directory, then do the same for all
+buffers for files in that directory.
+SETTINGS is an association list of property/value pairs. After
+executing FORM, set those properties from SETTINGS that have not yet
+been updated to their corresponding values."
+ (declare (debug t))
+ `(let ((vc-touched-properties (list t))
+ (flist nil))
+ (dolist (file ,files)
+ (if (file-directory-p file)
+ (dolist (buffer (buffer-list))
+ (let ((fname (buffer-file-name buffer)))
+ (when (and fname (vc-string-prefix-p file fname))
+ (push fname flist))))
+ (push file flist)))
+ ,form
+ (dolist (file flist)
+ (dolist (setting ,settings)
+ (let ((property (car setting)))
+ (unless (memq property vc-touched-properties)
+ (put (intern file vc-file-prop-obarray)
+ property (cdr setting))))))))
+
+;;; Code for deducing what fileset and backend to assume
+
+(defun vc-backend-for-registration (file)
+ "Return a backend that can be used for registering FILE.
+
+If no backend declares itself responsible for FILE, then FILE
+must not be in a version controlled directory, so try to create a
+repository, prompting for the directory and the VC backend to
+use."
+ (catch 'found
+ ;; First try: find a responsible backend, it must be a backend
+ ;; under which FILE is not yet registered.
+ (dolist (backend vc-handled-backends)
+ (and (not (vc-call-backend backend 'registered file))
+ (vc-call-backend backend 'responsible-p file)
+ (throw 'found backend)))
+ ;; no responsible backend
+ (let* ((possible-backends
+ (let (pos)
+ (dolist (crt vc-handled-backends)
+ (when (vc-find-backend-function crt 'create-repo)
+ (push crt pos)))
+ pos))
+ (bk
+ (intern
+ ;; Read the VC backend from the user, only
+ ;; complete with the backends that have the
+ ;; 'create-repo method.
+ (completing-read
+ (format "%s is not in a version controlled directory.\nUse VC backend: " file)
+ (mapcar 'symbol-name possible-backends) nil t)))
+ (repo-dir
+ (let ((def-dir (file-name-directory file)))
+ ;; read the directory where to create the
+ ;; repository, make sure it's a parent of
+ ;; file.
+ (read-file-name
+ (format "create %s repository in: " bk)
+ default-directory def-dir t nil
+ (lambda (arg)
+ (message "arg %s" arg)
+ (and (file-directory-p arg)
+ (vc-string-prefix-p (expand-file-name arg) def-dir)))))))
+ (let ((default-directory repo-dir))
+ (vc-call-backend bk 'create-repo))
+ (throw 'found bk))))
+
+(defun vc-responsible-backend (file)
+ "Return the name of a backend system that is responsible for FILE.
+
+If FILE is already registered, return the
+backend of FILE. If FILE is not registered, then the
+first backend in `vc-handled-backends' that declares itself
+responsible for FILE is returned."
+ (or (and (not (file-directory-p file)) (vc-backend file))
+ (catch 'found
+ ;; First try: find a responsible backend. If this is for registration,
+ ;; it must be a backend under which FILE is not yet registered.
+ (dolist (backend vc-handled-backends)
+ (and (vc-call-backend backend 'responsible-p file)
+ (throw 'found backend))))
+ (error "No VC backend is responsible for %s" file)))
+
+(defun vc-expand-dirs (file-or-dir-list)
+ "Expands directories in a file list specification.
+Within directories, only files already under version control are noticed."
+ (let ((flattened '()))
+ (dolist (node file-or-dir-list)
+ (when (file-directory-p node)
+ (vc-file-tree-walk
+ node (lambda (f) (when (vc-backend f) (push f flattened)))))
+ (unless (file-directory-p node) (push node flattened)))
+ (nreverse flattened)))
+
+(defvar vc-dir-backend)
+
+(declare-function vc-dir-current-file "vc-dir" ())
+(declare-function vc-dir-deduce-fileset "vc-dir" (&optional state-model-only-files))
+
+(defun vc-deduce-fileset (&optional observer allow-unregistered
+ state-model-only-files)
+ "Deduce a set of files and a backend to which to apply an operation.
+
+Return (BACKEND FILESET FILESET-ONLY-FILES STATE CHECKOUT-MODEL).
+If we're in VC-dir mode, the fileset is the list of marked files.
+Otherwise, if we're looking at a buffer visiting a version-controlled file,
+the fileset is a singleton containing this file.
+If none of these conditions is met, but ALLOW_UNREGISTERED is on and the
+visited file is not registered, return a singleton fileset containing it.
+Otherwise, throw an error.
+
+STATE-MODEL-ONLY-FILES if non-nil, means that the caller needs
+the FILESET-ONLY-FILES STATE and MODEL info. Otherwise, that
+part may be skipped.
+BEWARE: this function may change the
+current buffer."
+ ;; FIXME: OBSERVER is unused. The name is not intuitive and is not
+ ;; documented. It's set to t when called from diff and print-log.
+ (let (backend)
+ (cond
+ ((derived-mode-p 'vc-dir-mode)
+ (vc-dir-deduce-fileset state-model-only-files))
+ ((derived-mode-p 'dired-mode)
+ (if observer
+ (vc-dired-deduce-fileset)
+ (error "State changing VC operations not supported in `dired-mode'")))
+ ((setq backend (vc-backend buffer-file-name))
+ (if state-model-only-files
+ (list backend (list buffer-file-name)
+ (list buffer-file-name)
+ (vc-state buffer-file-name)
+ (vc-checkout-model backend buffer-file-name))
+ (list backend (list buffer-file-name))))
+ ((and (buffer-live-p vc-parent-buffer)
+ ;; FIXME: Why this test? --Stef
+ (or (buffer-file-name vc-parent-buffer)
+ (with-current-buffer vc-parent-buffer
+ (derived-mode-p 'vc-dir-mode))))
+ (progn ;FIXME: Why not `with-current-buffer'? --Stef.
+ (set-buffer vc-parent-buffer)
+ (vc-deduce-fileset observer allow-unregistered state-model-only-files)))
+ ((not buffer-file-name)
+ (error "Buffer %s is not associated with a file" (buffer-name)))
+ ((and allow-unregistered (not (vc-registered buffer-file-name)))
+ (if state-model-only-files
+ (list (vc-backend-for-registration (buffer-file-name))
+ (list buffer-file-name)
+ (list buffer-file-name)
+ (when state-model-only-files 'unregistered)
+ nil)
+ (list (vc-backend-for-registration (buffer-file-name))
+ (list buffer-file-name))))
+ (t (error "No fileset is available here")))))
+
+(defun vc-dired-deduce-fileset ()
+ (let ((backend (vc-responsible-backend default-directory)))
+ (unless backend (error "Directory not under VC"))
+ (list backend
+ (dired-map-over-marks (dired-get-filename nil t) nil))))
+
+(defun vc-ensure-vc-buffer ()
+ "Make sure that the current buffer visits a version-controlled file."
+ (cond
+ ((derived-mode-p 'vc-dir-mode)
+ (set-buffer (find-file-noselect (vc-dir-current-file))))
+ (t
+ (while (and vc-parent-buffer
+ (buffer-live-p vc-parent-buffer)
+ ;; Avoid infinite looping when vc-parent-buffer and
+ ;; current buffer are the same buffer.
+ (not (eq vc-parent-buffer (current-buffer))))
+ (set-buffer vc-parent-buffer))
+ (if (not buffer-file-name)
+ (error "Buffer %s is not associated with a file" (buffer-name))
+ (unless (vc-backend buffer-file-name)
+ (error "File %s is not under version control" buffer-file-name))))))
+
+;;; Support for the C-x v v command.
+;; This is where all the single-file-oriented code from before the fileset
+;; rewrite lives.
+
+(defsubst vc-editable-p (file)
+ "Return non-nil if FILE can be edited."
+ (let ((backend (vc-backend file)))
+ (and backend
+ (or (eq (vc-checkout-model backend (list file)) 'implicit)
+ (memq (vc-state file) '(edited needs-merge conflict))))))
+
+(defun vc-compatible-state (p q)
+ "Controls which states can be in the same commit."
+ (or
+ (eq p q)
+ (and (member p '(edited added removed)) (member q '(edited added removed)))))
+
+;; Here's the major entry point.
+
+;;;###autoload
+(defun vc-next-action (verbose)
+ "Do the next logical version control operation on the current fileset.
+This requires that all files in the fileset be in the same state.
+
+For locking systems:
+ If every file is not already registered, this registers each for version
+control.
+ If every file is registered and not locked by anyone, this checks out
+a writable and locked file of each ready for editing.
+ If every file is checked out and locked by the calling user, this
+first checks to see if each file has changed since checkout. If not,
+it performs a revert on that file.
+ If every file has been changed, this pops up a buffer for entry
+of a log message; when the message has been entered, it checks in the
+resulting changes along with the log message as change commentary. If
+the variable `vc-keep-workfiles' is non-nil (which is its default), a
+read-only copy of each changed file is left in place afterwards.
+ If the affected file is registered and locked by someone else, you are
+given the option to steal the lock(s).
+
+For merging systems:
+ If every file is not already registered, this registers each one for version
+control. This does an add, but not a commit.
+ If every file is added but not committed, each one is committed.
+ If every working file is changed, but the corresponding repository file is
+unchanged, this pops up a buffer for entry of a log message; when the
+message has been entered, it checks in the resulting changes along
+with the logmessage as change commentary. A writable file is retained.
+ If the repository file is changed, you are asked if you want to
+merge in the changes into your working copy."
+ (interactive "P")
+ (let* ((vc-fileset (vc-deduce-fileset nil t 'state-model-only-files))
+ (backend (car vc-fileset))
+ (files (nth 1 vc-fileset))
+ (fileset-only-files (nth 2 vc-fileset))
+ ;; FIXME: We used to call `vc-recompute-state' here.
+ (state (nth 3 vc-fileset))
+ ;; The backend should check that the checkout-model is consistent
+ ;; among all the `files'.
+ (model (nth 4 vc-fileset)))
+
+ ;; Do the right thing
+ (cond
+ ((eq state 'missing)
+ (error "Fileset files are missing, so cannot be operated on"))
+ ((eq state 'ignored)
+ (error "Fileset files are ignored by the version-control system"))
+ ((or (null state) (eq state 'unregistered))
+ (vc-register nil vc-fileset))
+ ;; Files are up-to-date, or need a merge and user specified a revision
+ ((or (eq state 'up-to-date) (and verbose (eq state 'needs-update)))
+ (cond
+ (verbose
+ ;; go to a different revision
+ (let* ((revision
+ (read-string "Branch, revision, or backend to move to: "))
+ (revision-downcase (downcase revision)))
+ (if (member
+ revision-downcase
+ (mapcar (lambda (arg) (downcase (symbol-name arg)))
+ vc-handled-backends))
+ (let ((vsym (intern-soft revision-downcase)))
+ (dolist (file files) (vc-transfer-file file vsym)))
+ (dolist (file files)
+ (vc-checkout file (eq model 'implicit) revision)))))
+ ((not (eq model 'implicit))
+ ;; check the files out
+ (dolist (file files) (vc-checkout file t)))
+ (t
+ ;; do nothing
+ (message "Fileset is up-to-date"))))
+ ;; Files have local changes
+ ((vc-compatible-state state 'edited)
+ (let ((ready-for-commit files))
+ ;; If files are edited but read-only, give user a chance to correct
+ (dolist (file files)
+ (unless (file-writable-p file)
+ ;; Make the file+buffer read-write.
+ (unless (y-or-n-p (format "%s is edited but read-only; make it writable and continue?" file))
+ (error "Aborted"))
+ (set-file-modes file (logior (file-modes file) 128))
+ (let ((visited (get-file-buffer file)))
+ (when visited
+ (with-current-buffer visited
+ (toggle-read-only -1))))))
+ ;; Allow user to revert files with no changes
+ (save-excursion
+ (dolist (file files)
+ (let ((visited (get-file-buffer file)))
+ ;; For files with locking, if the file does not contain
+ ;; any changes, just let go of the lock, i.e. revert.
+ (when (and (not (eq model 'implicit))
+ (vc-workfile-unchanged-p file)
+ ;; If buffer is modified, that means the user just
+ ;; said no to saving it; in that case, don't revert,
+ ;; because the user might intend to save after
+ ;; finishing the log entry and committing.
+ (not (and visited (buffer-modified-p))))
+ (vc-revert-file file)
+ (setq ready-for-commit (delete file ready-for-commit))))))
+ ;; Remaining files need to be committed
+ (if (not ready-for-commit)
+ (message "No files remain to be committed")
+ (if (not verbose)
+ (vc-checkin ready-for-commit backend)
+ (let* ((revision (read-string "New revision or backend: "))
+ (revision-downcase (downcase revision)))
+ (if (member
+ revision-downcase
+ (mapcar (lambda (arg) (downcase (symbol-name arg)))
+ vc-handled-backends))
+ (let ((vsym (intern revision-downcase)))
+ (dolist (file files) (vc-transfer-file file vsym)))
+ (vc-checkin ready-for-commit backend revision)))))))
+ ;; locked by somebody else (locking VCSes only)
+ ((stringp state)
+ ;; In the old days, we computed the revision once and used it on
+ ;; the single file. Then, for the 2007-2008 fileset rewrite, we
+ ;; computed the revision once (incorrectly, using a free var) and
+ ;; used it on all files. To fix the free var bug, we can either
+ ;; use `(car files)' or do what we do here: distribute the
+ ;; revision computation among `files'. Although this may be
+ ;; tedious for those backends where a "revision" is a trans-file
+ ;; concept, it is nonetheless correct for both those and (more
+ ;; importantly) for those where "revision" is a per-file concept.
+ ;; If the intersection of the former group and "locking VCSes" is
+ ;; non-empty [I vaguely doubt it --ttn], we can reinstate the
+ ;; pre-computation approach of yore.
+ (dolist (file files)
+ (vc-steal-lock
+ file (if verbose
+ (read-string (format "%s revision to steal: " file))
+ (vc-working-revision file))
+ state)))
+ ;; conflict
+ ((eq state 'conflict)
+ ;; FIXME: Is it really the UI we want to provide?
+ ;; In my experience, the conflicted files should be marked as resolved
+ ;; one-by-one when saving the file after resolving the conflicts.
+ ;; I.e. stating explicitly that the conflicts are resolved is done
+ ;; very rarely.
+ (vc-mark-resolved backend files))
+ ;; needs-update
+ ((eq state 'needs-update)
+ (dolist (file files)
+ (if (yes-or-no-p (format
+ "%s is not up-to-date. Get latest revision? "
+ (file-name-nondirectory file)))
+ (vc-checkout file (eq model 'implicit) t)
+ (when (and (not (eq model 'implicit))
+ (yes-or-no-p "Lock this revision? "))
+ (vc-checkout file t)))))
+ ;; needs-merge
+ ((eq state 'needs-merge)
+ (dolist (file files)
+ (when (yes-or-no-p (format
+ "%s is not up-to-date. Merge in changes now? "
+ (file-name-nondirectory file)))
+ (vc-maybe-resolve-conflicts
+ file (vc-call-backend backend 'merge-news file)))))
+
+ ;; unlocked-changes
+ ((eq state 'unlocked-changes)
+ (dolist (file files)
+ (when (not (equal buffer-file-name file))
+ (find-file-other-window file))
+ (if (save-window-excursion
+ (vc-diff-internal nil
+ (cons (car vc-fileset) (cons (cadr vc-fileset) (list file)))
+ (vc-working-revision file) nil)
+ (goto-char (point-min))
+ (let ((inhibit-read-only t))
+ (insert
+ (format "Changes to %s since last lock:\n\n" file)))
+ (not (beep))
+ (yes-or-no-p (concat "File has unlocked changes. "
+ "Claim lock retaining changes? ")))
+ (progn (vc-call-backend backend 'steal-lock file)
+ (clear-visited-file-modtime)
+ ;; Must clear any headers here because they wouldn't
+ ;; show that the file is locked now.
+ (vc-clear-headers file)
+ (write-file buffer-file-name)
+ (vc-mode-line file backend))
+ (if (not (yes-or-no-p
+ "Revert to checked-in revision, instead? "))
+ (error "Checkout aborted")
+ (vc-revert-buffer-internal t t)
+ (vc-checkout file t)))))
+ ;; Unknown fileset state
+ (t
+ (error "Fileset is in an unknown state %s" state)))))
+
+(defun vc-create-repo (backend)
+ "Create an empty repository in the current directory."
+ (interactive
+ (list
+ (intern
+ (upcase
+ (completing-read
+ "Create repository for: "
+ (mapcar (lambda (b) (list (downcase (symbol-name b)))) vc-handled-backends)
+ nil t)))))
+ (vc-call-backend backend 'create-repo))
+
+(declare-function vc-dir-move-to-goal-column "vc-dir" ())
+
+;;;###autoload
+(defun vc-register (&optional set-revision vc-fileset comment)
+ "Register into a version control system.
+If VC-FILESET is given, register the files in that fileset.
+Otherwise register the current file.
+With prefix argument SET-REVISION, allow user to specify initial revision
+level. If COMMENT is present, use that as an initial comment.
+
+The version control system to use is found by cycling through the list
+`vc-handled-backends'. The first backend in that list which declares
+itself responsible for the file (usually because other files in that
+directory are already registered under that backend) will be used to
+register the file. If no backend declares itself responsible, the
+first backend that could register the file is used."
+ (interactive "P")
+ (let* ((fileset-arg (or vc-fileset (vc-deduce-fileset nil t)))
+ (backend (car fileset-arg))
+ (files (nth 1 fileset-arg)))
+ ;; We used to operate on `only-files', but VC wants to provide the
+ ;; possibility to register directories rather than files only, since
+ ;; many VCS allow that as well.
+ (dolist (fname files)
+ (let ((bname (get-file-buffer fname)))
+ (unless fname (setq fname buffer-file-name))
+ (when (vc-backend fname)
+ (if (vc-registered fname)
+ (error "This file is already registered")
+ (unless (y-or-n-p "Previous master file has vanished. Make a new one? ")
+ (error "Aborted"))))
+ ;; Watch out for new buffers of size 0: the corresponding file
+ ;; does not exist yet, even though buffer-modified-p is nil.
+ (when bname
+ (with-current-buffer bname
+ (when (and (not (buffer-modified-p))
+ (zerop (buffer-size))
+ (not (file-exists-p buffer-file-name)))
+ (set-buffer-modified-p t))
+ (vc-buffer-sync)))))
+ (message "Registering %s... " files)
+ (mapc 'vc-file-clearprops files)
+ (vc-call-backend backend 'register files
+ (if set-revision
+ (read-string (format "Initial revision level for %s: " files))
+ (vc-call-backend backend 'init-revision))
+ comment)
+ (mapc
+ (lambda (file)
+ (vc-file-setprop file 'vc-backend backend)
+ ;; FIXME: This is wrong: it should set `backup-inhibited' in all
+ ;; the buffers visiting files affected by this `vc-register', not
+ ;; in the current-buffer.
+ ;; (unless vc-make-backup-files
+ ;; (make-local-variable 'backup-inhibited)
+ ;; (setq backup-inhibited t))
+
+ (vc-resynch-buffer file vc-keep-workfiles t))
+ files)
+ (when (derived-mode-p 'vc-dir-mode)
+ (vc-dir-move-to-goal-column))
+ (message "Registering %s... done" files)))
+
+(defun vc-register-with (backend)
+ "Register the current file with a specified back end."
+ (interactive "SBackend: ")
+ (when (not (member backend vc-handled-backends))
+ (error "Unknown back end"))
+ (let ((vc-handled-backends (list backend)))
+ (call-interactively 'vc-register)))
+
+(defun vc-checkout (file &optional writable rev)
+ "Retrieve a copy of the revision REV of FILE.
+If WRITABLE is non-nil, make sure the retrieved file is writable.
+REV defaults to the latest revision.
+
+After check-out, runs the normal hook `vc-checkout-hook'."
+ (and writable
+ (not rev)
+ (vc-call make-version-backups-p file)
+ (vc-up-to-date-p file)
+ (vc-make-version-backup file))
+ (let ((backend (vc-backend file)))
+ (with-vc-properties (list file)
+ (condition-case err
+ (vc-call-backend backend 'checkout file writable rev)
+ (file-error
+ ;; Maybe the backend is not installed ;-(
+ (when writable
+ (let ((buf (get-file-buffer file)))
+ (when buf (with-current-buffer buf (toggle-read-only -1)))))
+ (signal (car err) (cdr err))))
+ `((vc-state . ,(if (or (eq (vc-checkout-model backend (list file)) 'implicit)
+ (not writable))
+ (if (vc-call-backend backend 'latest-on-branch-p file)
+ 'up-to-date
+ 'needs-update)
+ 'edited))
+ (vc-checkout-time . ,(nth 5 (file-attributes file))))))
+ (vc-resynch-buffer file t t)
+ (run-hooks 'vc-checkout-hook))
+
+(defun vc-mark-resolved (backend files)
+ (prog1 (with-vc-properties
+ files
+ (vc-call-backend backend 'mark-resolved files)
+ ;; FIXME: Is this TRTD? Might not be.
+ `((vc-state . edited)))
+ (message
+ (substitute-command-keys
+ "Conflicts have been resolved in %s. \
+Type \\[vc-next-action] to check in changes.")
+ (if (> (length files) 1)
+ (format "%d files" (length files))
+ "this file"))))
+
+(defun vc-steal-lock (file rev owner)
+ "Steal the lock on FILE."
+ (let (file-description)
+ (if rev
+ (setq file-description (format "%s:%s" file rev))
+ (setq file-description file))
+ (when (not (yes-or-no-p (format "Steal the lock on %s from %s? "
+ file-description owner)))
+ (error "Steal canceled"))
+ (message "Stealing lock on %s..." file)
+ (with-vc-properties
+ (list file)
+ (vc-call steal-lock file rev)
+ `((vc-state . edited)))
+ (vc-resynch-buffer file t t)
+ (message "Stealing lock on %s...done" file)
+ ;; Write mail after actually stealing, because if the stealing
+ ;; goes wrong, we don't want to send any mail.
+ (compose-mail owner (format "Stolen lock on %s" file-description))
+ (setq default-directory (expand-file-name "~/"))
+ (goto-char (point-max))
+ (insert
+ (format "I stole the lock on %s, " file-description)
+ (current-time-string)
+ ".\n")
+ (message "Please explain why you stole the lock. Type C-c C-c when done.")))
+
+(defun vc-checkin (files backend &optional rev comment initial-contents)
+ "Check in FILES.
+The optional argument REV may be a string specifying the new revision
+level (strongly deprecated). COMMENT is a comment
+string; if omitted, a buffer is popped up to accept a comment. If
+INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial contents
+of the log entry buffer.
+
+If `vc-keep-workfiles' is nil, FILE is deleted afterwards, provided
+that the version control system supports this mode of operation.
+
+Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'."
+ (when vc-before-checkin-hook
+ (run-hooks 'vc-before-checkin-hook))
+ (lexical-let
+ ((backend backend))
+ (vc-start-logentry
+ files comment initial-contents
+ "Enter a change comment."
+ "*VC-log*"
+ (lambda ()
+ (vc-call-backend backend 'log-edit-mode))
+ (lexical-let ((rev rev))
+ (lambda (files comment)
+ (message "Checking in %s..." (vc-delistify files))
+ ;; "This log message intentionally left almost blank".
+ ;; RCS 5.7 gripes about white-space-only comments too.
+ (or (and comment (string-match "[^\t\n ]" comment))
+ (setq comment "*** empty log message ***"))
+ (with-vc-properties
+ files
+ ;; We used to change buffers to get local value of
+ ;; vc-checkin-switches, but 'the' local buffer is
+ ;; not a well-defined concept for filesets.
+ (progn
+ (vc-call-backend backend 'checkin files rev comment)
+ (mapc 'vc-delete-automatic-version-backups files))
+ `((vc-state . up-to-date)
+ (vc-checkout-time . ,(nth 5 (file-attributes file)))
+ (vc-working-revision . nil)))
+ (message "Checking in %s...done" (vc-delistify files))))
+ 'vc-checkin-hook)))
+
+;;; Additional entry points for examining version histories
+
+;; (defun vc-default-diff-tree (backend dir rev1 rev2)
+;; "List differences for all registered files at and below DIR.
+;; The meaning of REV1 and REV2 is the same as for `vc-revision-diff'."
+;; ;; This implementation does an explicit tree walk, and calls
+;; ;; vc-BACKEND-diff directly for each file. An optimization
+;; ;; would be to use `vc-diff-internal', so that diffs can be local,
+;; ;; and to call it only for files that are actually changed.
+;; ;; However, this is expensive for some backends, and so it is left
+;; ;; to backend-specific implementations.
+;; (setq default-directory dir)
+;; (vc-file-tree-walk
+;; default-directory
+;; (lambda (f)
+;; (vc-exec-after
+;; `(let ((coding-system-for-read (vc-coding-system-for-diff ',f)))
+;; (message "Looking at %s" ',f)
+;; (vc-call-backend ',(vc-backend f)
+;; 'diff (list ',f) ',rev1 ',rev2))))))
+
+(defun vc-coding-system-for-diff (file)
+ "Return the coding system for reading diff output for FILE."
+ (or coding-system-for-read
+ ;; if we already have this file open,
+ ;; use the buffer's coding system
+ (let ((buf (find-buffer-visiting file)))
+ (when buf (with-current-buffer buf
+ buffer-file-coding-system)))
+ ;; otherwise, try to find one based on the file name
+ (car (find-operation-coding-system 'insert-file-contents file))
+ ;; and a final fallback
+ 'undecided))
+
+(defun vc-switches (backend op)
+ "Return a list of vc-BACKEND switches for operation OP.
+BACKEND is a symbol such as `CVS', which will be downcased.
+OP is a symbol such as `diff'.
+
+In decreasing order of preference, return the value of:
+vc-BACKEND-OP-switches (e.g. `vc-cvs-diff-switches');
+vc-OP-switches (e.g. `vc-diff-switches'); or, in the case of
+diff only, `diff-switches'.
+
+If the chosen value is not a string or a list, return nil.
+This is so that you may set, e.g. `vc-svn-diff-switches' to t in order
+to override the value of `vc-diff-switches' and `diff-switches'."
+ (let ((switches
+ (or (when backend
+ (let ((sym (vc-make-backend-sym
+ backend (intern (concat (symbol-name op)
+ "-switches")))))
+ (when (boundp sym) (symbol-value sym))))
+ (let ((sym (intern (format "vc-%s-switches" (symbol-name op)))))
+ (when (boundp sym) (symbol-value sym)))
+ (cond
+ ((eq op 'diff) diff-switches)))))
+ (if (stringp switches) (list switches)
+ ;; If not a list, return nil.
+ ;; This is so we can set vc-diff-switches to t to override
+ ;; any switches in diff-switches.
+ (when (listp switches) switches))))
+
+;; Old def for compatibility with Emacs-21.[123].
+(defmacro vc-diff-switches-list (backend) `(vc-switches ',backend 'diff))
+(make-obsolete 'vc-diff-switches-list 'vc-switches "22.1")
+
+(defun vc-diff-finish (buffer messages)
+ ;; The empty sync output case has already been handled, so the only
+ ;; possibility of an empty output is for an async process.
+ (when (buffer-live-p buffer)
+ (let ((window (get-buffer-window buffer t))
+ (emptyp (zerop (buffer-size buffer))))
+ (with-current-buffer buffer
+ (and messages emptyp
+ (let ((inhibit-read-only t))
+ (insert (cdr messages) ".\n")
+ (message "%s" (cdr messages))))
+ (goto-char (point-min))
+ (when window
+ (shrink-window-if-larger-than-buffer window)))
+ (when (and messages (not emptyp))
+ (message "%sdone" (car messages))))))
+
+(defvar vc-diff-added-files nil
+ "If non-nil, diff added files by comparing them to /dev/null.")
+
+(defun vc-diff-internal (async vc-fileset rev1 rev2 &optional verbose)
+ "Report diffs between two revisions of a fileset.
+Diff output goes to the *vc-diff* buffer. The function
+returns t if the buffer had changes, nil otherwise."
+ (let* ((files (cadr vc-fileset))
+ (messages (cons (format "Finding changes in %s..."
+ (vc-delistify files))
+ (format "No changes between %s and %s"
+ (or rev1 "working revision")
+ (or rev2 "workfile"))))
+ ;; Set coding system based on the first file. It's a kluge,
+ ;; but the only way to set it for each file included would
+ ;; be to call the back end separately for each file.
+ (coding-system-for-read
+ (if files (vc-coding-system-for-diff (car files)) 'undecided)))
+ (vc-setup-buffer "*vc-diff*")
+ (message "%s" (car messages))
+ ;; Many backends don't handle well the case of a file that has been
+ ;; added but not yet committed to the repo (notably CVS and Subversion).
+ ;; Do that work here so the backends don't have to futz with it. --ESR
+ ;;
+ ;; Actually most backends (including CVS) have options to control the
+ ;; behavior since which one is better depends on the user and on the
+ ;; situation). Worse yet: this code does not handle the case where
+ ;; `file' is a directory which contains added files.
+ ;; I made it conditional on vc-diff-added-files but it should probably
+ ;; just be removed (or copied/moved to specific backends). --Stef.
+ (when vc-diff-added-files
+ (let ((filtered '())
+ process-file-side-effects)
+ (dolist (file files)
+ (if (or (file-directory-p file)
+ (not (string= (vc-working-revision file) "0")))
+ (push file filtered)
+ ;; This file is added but not yet committed;
+ ;; there is no repository version to diff against.
+ (if (or rev1 rev2)
+ (error "No revisions of %s exist" file)
+ ;; We regard this as "changed".
+ ;; Diff it against /dev/null.
+ (apply 'vc-do-command "*vc-diff*"
+ 1 "diff" file
+ (append (vc-switches nil 'diff) '("/dev/null"))))))
+ (setq files (nreverse filtered))))
+ (let ((vc-disable-async-diff (not async)))
+ (vc-call-backend (car vc-fileset) 'diff files rev1 rev2 "*vc-diff*"))
+ (set-buffer "*vc-diff*")
+ (if (and (zerop (buffer-size))
+ (not (get-buffer-process (current-buffer))))
+ ;; Treat this case specially so as not to pop the buffer.
+ (progn
+ (message "%s" (cdr messages))
+ nil)
+ (diff-mode)
+ ;; Make the *vc-diff* buffer read only, the diff-mode key
+ ;; bindings are nicer for read only buffers. pcl-cvs does the
+ ;; same thing.
+ (setq buffer-read-only t)
+ (vc-exec-after `(vc-diff-finish ,(current-buffer) ',(when verbose
+ messages)))
+ ;; Display the buffer, but at the end because it can change point.
+ (pop-to-buffer (current-buffer))
+ ;; In the async case, we return t even if there are no differences
+ ;; because we don't know that yet.
+ t)))
+
+(defun vc-read-revision (prompt &optional files backend default initial-input)
+ (cond
+ ((null files)
+ (let ((vc-fileset (vc-deduce-fileset t))) ;FIXME: why t? --Stef
+ (setq files (cadr vc-fileset))
+ (setq backend (car vc-fileset))))
+ ((null backend) (setq backend (vc-backend (car files)))))
+ (let ((completion-table
+ (vc-call-backend backend 'revision-completion-table files)))
+ (if completion-table
+ (completing-read prompt completion-table
+ nil nil initial-input nil default)
+ (read-string prompt initial-input nil default))))
+
+;;;###autoload
+(defun vc-version-diff (files rev1 rev2)
+ "Report diffs between revisions of the fileset in the repository history."
+ (interactive
+ (let* ((vc-fileset (vc-deduce-fileset t)) ;FIXME: why t? --Stef
+ (files (cadr vc-fileset))
+ (backend (car vc-fileset))
+ (first (car files))
+ (rev1-default nil)
+ (rev2-default nil))
+ (cond
+ ;; someday we may be able to do revision completion on non-singleton
+ ;; filesets, but not yet.
+ ((/= (length files) 1)
+ nil)
+ ;; if it's a directory, don't supply any revision default
+ ((file-directory-p first)
+ nil)
+ ;; if the file is not up-to-date, use working revision as older revision
+ ((not (vc-up-to-date-p first))
+ (setq rev1-default (vc-working-revision first)))
+ ;; if the file is not locked, use last and previous revisions as defaults
+ (t
+ (setq rev1-default (vc-call-backend backend 'previous-revision first
+ (vc-working-revision first)))
+ (when (string= rev1-default "") (setq rev1-default nil))
+ (setq rev2-default (vc-working-revision first))))
+ ;; construct argument list
+ (let* ((rev1-prompt (if rev1-default
+ (concat "Older revision (default "
+ rev1-default "): ")
+ "Older revision: "))
+ (rev2-prompt (concat "Newer revision (default "
+ (or rev2-default "current source") "): "))
+ (rev1 (vc-read-revision rev1-prompt files backend rev1-default))
+ (rev2 (vc-read-revision rev2-prompt files backend rev2-default)))
+ (when (string= rev1 "") (setq rev1 nil))
+ (when (string= rev2 "") (setq rev2 nil))
+ (list files rev1 rev2))))
+ ;; All that was just so we could do argument completion!
+ (when (and (not rev1) rev2)
+ (error "Not a valid revision range"))
+ ;; Yes, it's painful to call (vc-deduce-fileset) again. Alas, the
+ ;; placement rules for (interactive) don't actually leave us a choice.
+ (vc-diff-internal t (vc-deduce-fileset t) rev1 rev2
+ (called-interactively-p 'interactive)))
+
+;;;###autoload
+(defun vc-diff (historic &optional not-urgent)
+ "Display diffs between file revisions.
+Normally this compares the currently selected fileset with their
+working revisions. With a prefix argument HISTORIC, it reads two revision
+designators specifying which revisions to compare.
+
+The optional argument NOT-URGENT non-nil means it is ok to say no to
+saving the buffer."
+ (interactive (list current-prefix-arg t))
+ (if historic
+ (call-interactively 'vc-version-diff)
+ (when buffer-file-name (vc-buffer-sync not-urgent))
+ (vc-diff-internal t (vc-deduce-fileset t) nil nil
+ (called-interactively-p 'interactive))))
+
+;;;###autoload
+(defun vc-root-diff (historic &optional not-urgent)
+ "Display diffs between VC-controlled whole tree revisions.
+Normally, this compares the tree corresponding to the current
+fileset with the working revision.
+With a prefix argument HISTORIC, prompt for two revision
+designators specifying which revisions to compare.
+
+The optional argument NOT-URGENT non-nil means it is ok to say no to
+saving the buffer."
+ (interactive (list current-prefix-arg t))
+ (if historic
+ ;; FIXME: this does not work right, `vc-version-diff' ends up
+ ;; calling `vc-deduce-fileset' to find the files to diff, and
+ ;; that's not what we want here, we want the diff for the VC root dir.
+ (call-interactively 'vc-version-diff)
+ (when buffer-file-name (vc-buffer-sync not-urgent))
+ (let ((backend
+ (cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
+ ((derived-mode-p 'dired-mode) (vc-responsible-backend default-directory))
+ (vc-mode (vc-backend buffer-file-name))))
+ rootdir working-revision)
+ (unless backend
+ (error "Buffer is not version controlled"))
+ (setq rootdir (vc-call-backend backend 'root default-directory))
+ (setq working-revision (vc-working-revision rootdir))
+ ;; VC diff for the root directory produces output that is
+ ;; relative to it. Bind default-directory to the root directory
+ ;; here, this way the *vc-diff* buffer is setup correctly, so
+ ;; relative file names work.
+ (let ((default-directory rootdir))
+ (vc-diff-internal
+ t (list backend (list rootdir) working-revision) nil nil
+ (called-interactively-p 'interactive))))))
+
+;;;###autoload
+(defun vc-revision-other-window (rev)
+ "Visit revision REV of the current file in another window.
+If the current file is named `F', the revision is named `F.~REV~'.
+If `F.~REV~' already exists, use it instead of checking it out again."
+ (interactive
+ (save-current-buffer
+ (vc-ensure-vc-buffer)
+ (list
+ (vc-read-revision "Revision to visit (default is working revision): "
+ (list buffer-file-name)))))
+ (vc-ensure-vc-buffer)
+ (let* ((file buffer-file-name)
+ (revision (if (string-equal rev "")
+ (vc-working-revision file)
+ rev)))
+ (switch-to-buffer-other-window (vc-find-revision file revision))))
+
+(defun vc-find-revision (file revision)
+ "Read REVISION of FILE into a buffer and return the buffer."
+ (let ((automatic-backup (vc-version-backup-file-name file revision))
+ (filebuf (or (get-file-buffer file) (current-buffer)))
+ (filename (vc-version-backup-file-name file revision 'manual)))
+ (unless (file-exists-p filename)
+ (if (file-exists-p automatic-backup)
+ (rename-file automatic-backup filename nil)
+ (message "Checking out %s..." filename)
+ (with-current-buffer filebuf
+ (let ((failed t))
+ (unwind-protect
+ (let ((coding-system-for-read 'no-conversion)
+ (coding-system-for-write 'no-conversion))
+ (with-temp-file filename
+ (let ((outbuf (current-buffer)))
+ ;; Change buffer to get local value of
+ ;; vc-checkout-switches.
+ (with-current-buffer filebuf
+ (vc-call find-revision file revision outbuf))))
+ (setq failed nil))
+ (when (and failed (file-exists-p filename))
+ (delete-file filename))))
+ (vc-mode-line file))
+ (message "Checking out %s...done" filename)))
+ (let ((result-buf (find-file-noselect filename)))
+ (with-current-buffer result-buf
+ ;; Set the parent buffer so that things like
+ ;; C-x v g, C-x v l, ... etc work.
+ (set (make-local-variable 'vc-parent-buffer) filebuf))
+ result-buf)))
+
+;; Header-insertion code
+
+;;;###autoload
+(defun vc-insert-headers ()
+ "Insert headers into a file for use with a version control system.
+Headers desired are inserted at point, and are pulled from
+the variable `vc-BACKEND-header'."
+ (interactive)
+ (vc-ensure-vc-buffer)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (when (or (not (vc-check-headers))
+ (y-or-n-p "Version headers already exist. Insert another set? "))
+ (let* ((delims (cdr (assq major-mode vc-comment-alist)))
+ (comment-start-vc (or (car delims) comment-start "#"))
+ (comment-end-vc (or (car (cdr delims)) comment-end ""))
+ (hdsym (vc-make-backend-sym (vc-backend buffer-file-name)
+ 'header))
+ (hdstrings (and (boundp hdsym) (symbol-value hdsym))))
+ (dolist (s hdstrings)
+ (insert comment-start-vc "\t" s "\t"
+ comment-end-vc "\n"))
+ (when vc-static-header-alist
+ (dolist (f vc-static-header-alist)
+ (when (string-match (car f) buffer-file-name)
+ (insert (format (cdr f) (car hdstrings)))))))))))
+
+(defun vc-clear-headers (&optional file)
+ "Clear all version headers in the current buffer (or FILE).
+The headers are reset to their non-expanded form."
+ (let* ((filename (or file buffer-file-name))
+ (visited (find-buffer-visiting filename))
+ (backend (vc-backend filename)))
+ (when (vc-find-backend-function backend 'clear-headers)
+ (if visited
+ (let ((context (vc-buffer-context)))
+ ;; save-excursion may be able to relocate point and mark
+ ;; properly. If it fails, vc-restore-buffer-context
+ ;; will give it a second try.
+ (save-excursion
+ (vc-call-backend backend 'clear-headers))
+ (vc-restore-buffer-context context))
+ (set-buffer (find-file-noselect filename))
+ (vc-call-backend backend 'clear-headers)
+ (kill-buffer filename)))))
+
+(defun vc-modify-change-comment (files rev oldcomment)
+ "Edit the comment associated with the given files and revision."
+ ;; Less of a kluge than it looks like; log-view mode only passes
+ ;; this function a singleton list. Arguments left in this form in
+ ;; case the more general operation ever becomes meaningful.
+ (let ((backend (vc-responsible-backend (car files))))
+ (vc-start-logentry
+ files oldcomment t
+ "Enter a replacement change comment."
+ "*VC-log*"
+ (lambda () (vc-call-backend backend 'log-edit-mode))
+ (lexical-let ((rev rev))
+ (lambda (files comment)
+ (vc-call-backend backend
+ 'modify-change-comment files rev comment))))))
+
+;;;###autoload
+(defun vc-merge ()
+ "Merge changes between two revisions into the current buffer's file.
+This asks for two revisions to merge from in the minibuffer. If the
+first revision is a branch number, then merge all changes from that
+branch. If the first revision is empty, merge news, i.e. recent changes
+from the current branch.
+
+See Info node `Merging'."
+ (interactive)
+ (vc-ensure-vc-buffer)
+ (vc-buffer-sync)
+ (let* ((file buffer-file-name)
+ (backend (vc-backend file))
+ (state (vc-state file))
+ first-revision second-revision status)
+ (cond
+ ((stringp state) ;; Locking VCses only
+ (error "File is locked by %s" state))
+ ((not (vc-editable-p file))
+ (if (y-or-n-p
+ "File must be checked out for merging. Check out now? ")
+ (vc-checkout file t)
+ (error "Merge aborted"))))
+ (setq first-revision
+ (vc-read-revision
+ (concat "Branch or revision to merge from "
+ "(default news on current branch): ")
+ (list file)
+ backend))
+ (if (string= first-revision "")
+ (setq status (vc-call-backend backend 'merge-news file))
+ (if (not (vc-find-backend-function backend 'merge))
+ (error "Sorry, merging is not implemented for %s" backend)
+ (if (not (vc-branch-p first-revision))
+ (setq second-revision
+ (vc-read-revision
+ "Second revision: "
+ (list file) backend nil
+ ;; FIXME: This is CVS/RCS/SCCS specific.
+ (concat (vc-branch-part first-revision) ".")))
+ ;; We want to merge an entire branch. Set revisions
+ ;; accordingly, so that vc-BACKEND-merge understands us.
+ (setq second-revision first-revision)
+ ;; first-revision must be the starting point of the branch
+ (setq first-revision (vc-branch-part first-revision)))
+ (setq status (vc-call-backend backend 'merge file
+ first-revision second-revision))))
+ (vc-maybe-resolve-conflicts file status "WORKFILE" "MERGE SOURCE")))
+
+(defun vc-maybe-resolve-conflicts (file status &optional name-A name-B)
+ (vc-resynch-buffer file t (not (buffer-modified-p)))
+ (if (zerop status) (message "Merge successful")
+ (smerge-mode 1)
+ (message "File contains conflicts.")))
+
+;;;###autoload
+(defalias 'vc-resolve-conflicts 'smerge-ediff)
+
+;; TODO: This is OK but maybe we could integrate it better.
+;; E.g. it could be run semi-automatically (via a prompt?) when saving a file
+;; that was conflicted (i.e. upon mark-resolved).
+;; FIXME: should we add an "other-window" version? Or maybe we should
+;; hook it inside find-file so it automatically works for
+;; find-file-other-window as well. E.g. find-file could use a new
+;; `default-next-file' variable for its default file (M-n), and
+;; we could then set it upon mark-resolve, so C-x C-s C-x C-f M-n would
+;; automatically offer the next conflicted file.
+(defun vc-find-conflicted-file ()
+ "Visit the next conflicted file in the current project."
+ (interactive)
+ (let* ((backend (or (if buffer-file-name (vc-backend buffer-file-name))
+ (vc-responsible-backend default-directory)
+ (error "No VC backend")))
+ (files (vc-call-backend backend
+ 'conflicted-files default-directory)))
+ ;; Don't try and visit the current file.
+ (if (equal (car files) buffer-file-name) (pop files))
+ (if (null files)
+ (message "No more conflicted files")
+ (find-file (pop files))
+ (message "%s more conflicted files after this one"
+ (if files (length files) "No")))))
+
+;; Named-configuration entry points
+
+(defun vc-tag-precondition (dir)
+ "Scan the tree below DIR, looking for files not up-to-date.
+If any file is not up-to-date, return the name of the first such file.
+\(This means, neither tag creation nor retrieval is allowed.\)
+If one or more of the files are currently visited, return `visited'.
+Otherwise, return nil."
+ (let ((status nil))
+ (catch 'vc-locked-example
+ (vc-file-tree-walk
+ dir
+ (lambda (f)
+ (if (not (vc-up-to-date-p f)) (throw 'vc-locked-example f)
+ (when (get-file-buffer f) (setq status 'visited)))))
+ status)))
+
+;;;###autoload
+(defun vc-create-tag (dir name branchp)
+ "Descending recursively from DIR, make a tag called NAME.
+For each registered file, the working revision becomes part of
+the named configuration. If the prefix argument BRANCHP is
+given, the tag is made as a new branch and the files are
+checked out in that new branch."
+ (interactive
+ (let ((granularity
+ (vc-call-backend (vc-responsible-backend default-directory)
+ 'revision-granularity)))
+ (list
+ (if (eq granularity 'repository)
+ ;; For VC's that do not work at file level, it's pointless
+ ;; to ask for a directory, branches are created at repository level.
+ default-directory
+ (read-file-name "Directory: " default-directory default-directory t))
+ (read-string (if current-prefix-arg "New branch name: " "New tag name: "))
+ current-prefix-arg)))
+ (message "Making %s... " (if branchp "branch" "tag"))
+ (when (file-directory-p dir) (setq dir (file-name-as-directory dir)))
+ (vc-call-backend (vc-responsible-backend dir)
+ 'create-tag dir name branchp)
+ (vc-resynch-buffer dir t t t)
+ (message "Making %s... done" (if branchp "branch" "tag")))
+
+;;;###autoload
+(defun vc-retrieve-tag (dir name)
+ "Descending recursively from DIR, retrieve the tag called NAME.
+If NAME is empty, it refers to the latest revisions.
+If locking is used for the files in DIR, then there must not be any
+locked files at or below DIR (but if NAME is empty, locked files are
+allowed and simply skipped)."
+ (interactive
+ (let ((granularity
+ (vc-call-backend (vc-responsible-backend default-directory)
+ 'revision-granularity)))
+ (list
+ (if (eq granularity 'repository)
+ ;; For VC's that do not work at file level, it's pointless
+ ;; to ask for a directory, branches are created at repository level.
+ default-directory
+ (read-file-name "Directory: " default-directory default-directory t))
+ (read-string "Tag name to retrieve (default latest revisions): "))))
+ (let ((update (yes-or-no-p "Update any affected buffers? "))
+ (msg (if (or (not name) (string= name ""))
+ (format "Updating %s... " (abbreviate-file-name dir))
+ (format "Retrieving tag into %s... "
+ (abbreviate-file-name dir)))))
+ (message "%s" msg)
+ (vc-call-backend (vc-responsible-backend dir)
+ 'retrieve-tag dir name update)
+ (vc-resynch-buffer dir t t t)
+ (message "%s" (concat msg "done"))))
+
+
+;; Miscellaneous other entry points
+
+;; FIXME: this should be a defcustom
+;; FIXME: maybe add another choice:
+;; `root-directory' (or somesuch), which would mean show a short log
+;; for the root directory.
+(defvar vc-log-short-style '(directory)
+ "Whether or not to show a short log.
+If it contains `directory' then if the fileset contains a directory show a short log.
+If it contains `file' then show short logs for files.
+Not all VC backends support short logs!")
+
+(defvar log-view-vc-backend)
+(defvar log-view-vc-fileset)
+
+(defun vc-print-log-setup-buttons (working-revision is-start-revision limit pl-return)
+ (when (and limit (not (eq 'limit-unsupported pl-return))
+ (not is-start-revision))
+ (goto-char (point-max))
+ (lexical-let ((working-revision working-revision)
+ (limit limit))
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (vc-print-log-internal
+ log-view-vc-backend log-view-vc-fileset
+ working-revision nil (* 2 limit)))
+ :help-echo "Show the log again, and double the number of log entries shown"
+ "Show 2X entries")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (vc-print-log-internal
+ log-view-vc-backend log-view-vc-fileset
+ working-revision nil nil))
+ :help-echo "Show the log again, showing all entries"
+ "Show unlimited entries"))
+ (widget-setup)))
+
+(defun vc-print-log-internal (backend files working-revision
+ &optional is-start-revision limit)
+ ;; Don't switch to the output buffer before running the command,
+ ;; so that any buffer-local settings in the vc-controlled
+ ;; buffer can be accessed by the command.
+ (let ((dir-present nil)
+ (vc-short-log nil)
+ (buffer-name "*vc-change-log*")
+ type
+ pl-return)
+ (dolist (file files)
+ (when (file-directory-p file)
+ (setq dir-present t)))
+ (setq vc-short-log
+ (not (null (if dir-present
+ (memq 'directory vc-log-short-style)
+ (memq 'file vc-log-short-style)))))
+ (setq type (if vc-short-log 'short 'long))
+ (lexical-let
+ ((working-revision working-revision)
+ (limit limit)
+ (shortlog vc-short-log)
+ (is-start-revision is-start-revision))
+ (vc-log-internal-common
+ backend buffer-name files type
+ (lambda (bk buf type-arg files-arg)
+ (vc-call-backend bk 'print-log files-arg buf
+ shortlog (when is-start-revision working-revision) limit))
+ (lambda (bk files-arg ret)
+ (vc-print-log-setup-buttons working-revision
+ is-start-revision limit ret))
+ (lambda (bk)
+ (vc-call-backend bk 'show-log-entry working-revision))))))
+
+(defvar vc-log-view-type nil
+ "Set this to differentiate the different types of logs.")
+(put 'vc-log-view-type 'permanent-local t)
+
+(defun vc-log-internal-common (backend
+ buffer-name
+ files
+ type
+ backend-func
+ setup-buttons-func
+ goto-location-func)
+ (let (retval)
+ (with-current-buffer (get-buffer-create buffer-name)
+ (set (make-local-variable 'vc-log-view-type) type))
+ (setq retval (funcall backend-func backend buffer-name type files))
+ (pop-to-buffer buffer-name)
+ (let ((inhibit-read-only t))
+ ;; log-view-mode used to be called with inhibit-read-only bound
+ ;; to t, so let's keep doing it, just in case.
+ (vc-call-backend backend 'log-view-mode)
+ (set (make-local-variable 'log-view-vc-backend) backend)
+ (set (make-local-variable 'log-view-vc-fileset) files))
+ (vc-exec-after
+ `(let ((inhibit-read-only t))
+ (funcall ',setup-buttons-func ',backend ',files ',retval)
+ (shrink-window-if-larger-than-buffer)
+ (funcall ',goto-location-func ',backend)
+ (setq vc-sentinel-movepoint (point))
+ (set-buffer-modified-p nil)))))
+
+(defun vc-incoming-outgoing-internal (backend remote-location buffer-name type)
+ (vc-log-internal-common
+ backend buffer-name nil type
+ (lexical-let
+ ((remote-location remote-location))
+ (lambda (bk buf type-arg files)
+ (vc-call-backend bk type-arg buf remote-location)))
+ (lambda (bk files-arg ret))
+ (lambda (bk)
+ (goto-char (point-min)))))
+
+;;;###autoload
+(defun vc-print-log (&optional working-revision limit)
+ "List the change log of the current fileset in a window.
+If WORKING-REVISION is non-nil, leave point at that revision.
+If LIMIT is non-nil, it should be a number specifying the maximum
+number of revisions to show; the default is `vc-log-show-limit'.
+
+When called interactively with a prefix argument, prompt for
+WORKING-REVISION and LIMIT."
+ (interactive
+ (cond
+ (current-prefix-arg
+ (let ((rev (read-from-minibuffer "Log from revision (default: last revision): " nil
+ nil nil nil))
+ (lim (string-to-number
+ (read-from-minibuffer
+ "Limit display (unlimited: 0): "
+ (format "%s" vc-log-show-limit)
+ nil nil nil))))
+ (when (string= rev "") (setq rev nil))
+ (when (<= lim 0) (setq lim nil))
+ (list rev lim)))
+ (t
+ (list nil (when (> vc-log-show-limit 0) vc-log-show-limit)))))
+ (let* ((vc-fileset (vc-deduce-fileset t)) ;FIXME: Why t? --Stef
+ (backend (car vc-fileset))
+ (files (cadr vc-fileset))
+ (working-revision (or working-revision (vc-working-revision (car files)))))
+ (vc-print-log-internal backend files working-revision nil limit)))
+
+;;;###autoload
+(defun vc-print-root-log (&optional limit)
+ "List the change log for the current VC controlled tree in a window.
+If LIMIT is non-nil, it should be a number specifying the maximum
+number of revisions to show; the default is `vc-log-show-limit'.
+When called interactively with a prefix argument, prompt for LIMIT."
+ (interactive
+ (cond
+ (current-prefix-arg
+ (let ((lim (string-to-number
+ (read-from-minibuffer
+ "Limit display (unlimited: 0): "
+ (format "%s" vc-log-show-limit)
+ nil nil nil))))
+ (when (<= lim 0) (setq lim nil))
+ (list lim)))
+ (t
+ (list (when (> vc-log-show-limit 0) vc-log-show-limit)))))
+ (let ((backend
+ (cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
+ ((derived-mode-p 'dired-mode) (vc-responsible-backend default-directory))
+ (vc-mode (vc-backend buffer-file-name))))
+ rootdir working-revision)
+ (unless backend
+ (error "Buffer is not version controlled"))
+ (setq rootdir (vc-call-backend backend 'root default-directory))
+ (setq working-revision (vc-working-revision rootdir))
+ (vc-print-log-internal backend (list rootdir) working-revision nil limit)))
+
+;;;###autoload
+(defun vc-log-incoming (&optional remote-location)
+ "Show a log of changes that will be received with a pull operation from REMOTE-LOCATION."
+ (interactive "sRemote location (empty for default): ")
+ (let ((backend
+ (cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
+ ((derived-mode-p 'dired-mode) (vc-responsible-backend default-directory))
+ (vc-mode (vc-backend buffer-file-name))))
+ rootdir working-revision)
+ (unless backend
+ (error "Buffer is not version controlled"))
+ (vc-incoming-outgoing-internal backend remote-location "*vc-incoming*" 'log-incoming)))
+
+;;;###autoload
+(defun vc-log-outgoing (&optional remote-location)
+ "Show a log of changes that will be sent with a push operation to REMOTE-LOCATION."
+ (interactive "sRemote location (empty for default): ")
+ (let ((backend
+ (cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
+ ((derived-mode-p 'dired-mode) (vc-responsible-backend default-directory))
+ (vc-mode (vc-backend buffer-file-name))))
+ rootdir working-revision)
+ (unless backend
+ (error "Buffer is not version controlled"))
+ (vc-incoming-outgoing-internal backend remote-location "*vc-outgoing*" 'log-outgoing)))
+
+;;;###autoload
+(defun vc-revert ()
+ "Revert working copies of the selected fileset to their repository contents.
+This asks for confirmation if the buffer contents are not identical
+to the working revision (except for keyword expansion)."
+ (interactive)
+ (let* ((vc-fileset (vc-deduce-fileset))
+ (files (cadr vc-fileset)))
+ ;; If any of the files is visited by the current buffer, make
+ ;; sure buffer is saved. If the user says `no', abort since
+ ;; we cannot show the changes and ask for confirmation to
+ ;; discard them.
+ (when (or (not files) (memq (buffer-file-name) files))
+ (vc-buffer-sync nil))
+ (dolist (file files)
+ (let ((buf (get-file-buffer file)))
+ (when (and buf (buffer-modified-p buf))
+ (error "Please kill or save all modified buffers before reverting")))
+ (when (vc-up-to-date-p file)
+ (unless (yes-or-no-p (format "%s seems up-to-date. Revert anyway? " file))
+ (error "Revert canceled"))))
+ (when (vc-diff-internal vc-allow-async-revert vc-fileset nil nil)
+ (unless (yes-or-no-p
+ (format "Discard changes in %s? "
+ (let ((str (vc-delistify files))
+ (nfiles (length files)))
+ (if (< (length str) 50)
+ str
+ (format "%d file%s" nfiles
+ (if (= nfiles 1) "" "s"))))))
+ (error "Revert canceled"))
+ (delete-windows-on "*vc-diff*")
+ (kill-buffer "*vc-diff*"))
+ (dolist (file files)
+ (message "Reverting %s..." (vc-delistify files))
+ (vc-revert-file file)
+ (message "Reverting %s...done" (vc-delistify files)))))
+
+;;;###autoload
+(defun vc-rollback ()
+ "Roll back (remove) the most recent changeset committed to the repository.
+This may be either a file-level or a repository-level operation,
+depending on the underlying version-control system."
+ (interactive)
+ (let* ((vc-fileset (vc-deduce-fileset))
+ (backend (car vc-fileset))
+ (files (cadr vc-fileset))
+ (granularity (vc-call-backend backend 'revision-granularity)))
+ (unless (vc-find-backend-function backend 'rollback)
+ (error "Rollback is not supported in %s" backend))
+ (when (and (not (eq granularity 'repository)) (/= (length files) 1))
+ (error "Rollback requires a singleton fileset or repository versioning"))
+ ;; FIXME: latest-on-branch-p should take the fileset.
+ (when (not (vc-call-backend backend 'latest-on-branch-p (car files)))
+ (error "Rollback is only possible at the tip revision"))
+ ;; If any of the files is visited by the current buffer, make
+ ;; sure buffer is saved. If the user says `no', abort since
+ ;; we cannot show the changes and ask for confirmation to
+ ;; discard them.
+ (when (or (not files) (memq (buffer-file-name) files))
+ (vc-buffer-sync nil))
+ (dolist (file files)
+ (when (buffer-modified-p (get-file-buffer file))
+ (error "Please kill or save all modified buffers before rollback"))
+ (when (not (vc-up-to-date-p file))
+ (error "Please revert all modified workfiles before rollback")))
+ ;; Accumulate changes associated with the fileset
+ (vc-setup-buffer "*vc-diff*")
+ (not-modified)
+ (message "Finding changes...")
+ (let* ((tip (vc-working-revision (car files)))
+ ;; FIXME: `previous-revision' should take the fileset.
+ (previous (vc-call-backend backend 'previous-revision
+ (car files) tip)))
+ (vc-diff-internal nil vc-fileset previous tip))
+ ;; Display changes
+ (unless (yes-or-no-p "Discard these revisions? ")
+ (error "Rollback canceled"))
+ (delete-windows-on "*vc-diff*")
+ (kill-buffer"*vc-diff*")
+ ;; Do the actual reversions
+ (message "Rolling back %s..." (vc-delistify files))
+ (with-vc-properties
+ files
+ (vc-call-backend backend 'rollback files)
+ `((vc-state . ,'up-to-date)
+ (vc-checkout-time . , (nth 5 (file-attributes file)))
+ (vc-working-revision . nil)))
+ (dolist (f files) (vc-resynch-buffer f t t))
+ (message "Rolling back %s...done" (vc-delistify files))))
+
+;;;###autoload
+(define-obsolete-function-alias 'vc-revert-buffer 'vc-revert "23.1")
+
+;;;###autoload
+(defun vc-update ()
+ "Update the current fileset's files to their tip revisions.
+For each one that contains no changes, and is not locked, then this simply
+replaces the work file with the latest revision on its branch. If the file
+contains changes, and the backend supports merging news, then any recent
+changes from the current branch are merged into the working file."
+ (interactive)
+ (let* ((vc-fileset (vc-deduce-fileset))
+ (backend (car vc-fileset))
+ (files (cadr vc-fileset)))
+ (save-some-buffers ; save buffers visiting files
+ nil (lambda ()
+ (and (buffer-modified-p)
+ (let ((file (buffer-file-name)))
+ (and file (member file files))))))
+ (dolist (file files)
+ (if (vc-up-to-date-p file)
+ (vc-checkout file nil t)
+ (if (eq (vc-checkout-model backend (list file)) 'locking)
+ (if (eq (vc-state file) 'edited)
+ (error "%s"
+ (substitute-command-keys
+ "File is locked--type \\[vc-revert] to discard changes"))
+ (error "Unexpected file state (%s) -- type %s"
+ (vc-state file)
+ (substitute-command-keys
+ "\\[vc-next-action] to correct")))
+ (vc-maybe-resolve-conflicts
+ file (vc-call-backend backend 'merge-news file)))))))
+
+(defun vc-version-backup-file (file &optional rev)
+ "Return name of backup file for revision REV of FILE.
+If version backups should be used for FILE, and there exists
+such a backup for REV or the working revision of file, return
+its name; otherwise return nil."
+ (when (vc-call make-version-backups-p file)
+ (let ((backup-file (vc-version-backup-file-name file rev)))
+ (if (file-exists-p backup-file)
+ backup-file
+ ;; there is no automatic backup, but maybe the user made one manually
+ (setq backup-file (vc-version-backup-file-name file rev 'manual))
+ (when (file-exists-p backup-file)
+ backup-file)))))
+
+(defun vc-revert-file (file)
+ "Revert FILE back to the repository working revision it was based on."
+ (with-vc-properties
+ (list file)
+ (let ((backup-file (vc-version-backup-file file)))
+ (when backup-file
+ (copy-file backup-file file 'ok-if-already-exists 'keep-date)
+ (vc-delete-automatic-version-backups file))
+ (vc-call revert file backup-file))
+ `((vc-state . up-to-date)
+ (vc-checkout-time . ,(nth 5 (file-attributes file)))))
+ (vc-resynch-buffer file t t))
+
+;;;###autoload
+(defun vc-switch-backend (file backend)
+ "Make BACKEND the current version control system for FILE.
+FILE must already be registered in BACKEND. The change is not
+permanent, only for the current session. This function only changes
+VC's perspective on FILE, it does not register or unregister it.
+By default, this command cycles through the registered backends.
+To get a prompt, use a prefix argument."
+ (interactive
+ (list
+ (or buffer-file-name
+ (error "There is no version-controlled file in this buffer"))
+ (let ((crt-bk (vc-backend buffer-file-name))
+ (backends nil))
+ (unless crt-bk
+ (error "File %s is not under version control" buffer-file-name))
+ ;; Find the registered backends.
+ (dolist (crt vc-handled-backends)
+ (when (and (vc-call-backend crt 'registered buffer-file-name)
+ (not (eq crt-bk crt)))
+ (push crt backends)))
+ ;; Find the next backend.
+ (let ((def (car backends))
+ (others backends))
+ (cond
+ ((null others) (error "No other backend to switch to"))
+ (current-prefix-arg
+ (intern
+ (upcase
+ (completing-read
+ (format "Switch to backend [%s]: " def)
+ (mapcar (lambda (b) (list (downcase (symbol-name b)))) backends)
+ nil t nil nil (downcase (symbol-name def))))))
+ (t def))))))
+ (unless (eq backend (vc-backend file))
+ (vc-file-clearprops file)
+ (vc-file-setprop file 'vc-backend backend)
+ ;; Force recomputation of the state
+ (unless (vc-call-backend backend 'registered file)
+ (vc-file-clearprops file)
+ (error "%s is not registered in %s" file backend))
+ (vc-mode-line file)))
+
+;;;###autoload
+(defun vc-transfer-file (file new-backend)
+ "Transfer FILE to another version control system NEW-BACKEND.
+If NEW-BACKEND has a higher precedence than FILE's current backend
+\(i.e. it comes earlier in `vc-handled-backends'), then register FILE in
+NEW-BACKEND, using the revision number from the current backend as the
+base level. If NEW-BACKEND has a lower precedence than the current
+backend, then commit all changes that were made under the current
+backend to NEW-BACKEND, and unregister FILE from the current backend.
+\(If FILE is not yet registered under NEW-BACKEND, register it.)"
+ (let* ((old-backend (vc-backend file))
+ (edited (memq (vc-state file) '(edited needs-merge)))
+ (registered (vc-call-backend new-backend 'registered file))
+ (move
+ (and registered ; Never move if not registered in new-backend yet.
+ ;; move if new-backend comes later in vc-handled-backends
+ (or (memq new-backend (memq old-backend vc-handled-backends))
+ (y-or-n-p "Final transfer? "))))
+ (comment nil))
+ (when (eq old-backend new-backend)
+ (error "%s is the current backend of %s" new-backend file))
+ (if registered
+ (set-file-modes file (logior (file-modes file) 128))
+ ;; `registered' might have switched under us.
+ (vc-switch-backend file old-backend)
+ (let* ((rev (vc-working-revision file))
+ (modified-file (and edited (make-temp-file file)))
+ (unmodified-file (and modified-file (vc-version-backup-file file))))
+ ;; Go back to the base unmodified file.
+ (unwind-protect
+ (progn
+ (when modified-file
+ (copy-file file modified-file 'ok-if-already-exists)
+ ;; If we have a local copy of the unmodified file, handle that
+ ;; here and not in vc-revert-file because we don't want to
+ ;; delete that copy -- it is still useful for OLD-BACKEND.
+ (if unmodified-file
+ (copy-file unmodified-file file
+ 'ok-if-already-exists 'keep-date)
+ (when (y-or-n-p "Get base revision from repository? ")
+ (vc-revert-file file))))
+ (vc-call-backend new-backend 'receive-file file rev))
+ (when modified-file
+ (vc-switch-backend file new-backend)
+ (unless (eq (vc-checkout-model new-backend (list file)) 'implicit)
+ (vc-checkout file t nil))
+ (rename-file modified-file file 'ok-if-already-exists)
+ (vc-file-setprop file 'vc-checkout-time nil)))))
+ (when move
+ (vc-switch-backend file old-backend)
+ (setq comment (vc-call-backend old-backend 'comment-history file))
+ (vc-call-backend old-backend 'unregister file))
+ (vc-switch-backend file new-backend)
+ (when (or move edited)
+ (vc-file-setprop file 'vc-state 'edited)
+ (vc-mode-line file new-backend)
+ (vc-checkin file new-backend nil comment (stringp comment)))))
+
+(defun vc-rename-master (oldmaster newfile templates)
+ "Rename OLDMASTER to be the master file for NEWFILE based on TEMPLATES."
+ (let* ((dir (file-name-directory (expand-file-name oldmaster)))
+ (newdir (or (file-name-directory newfile) ""))
+ (newbase (file-name-nondirectory newfile))
+ (masters
+ ;; List of potential master files for `newfile'
+ (mapcar
+ (lambda (s) (vc-possible-master s newdir newbase))
+ templates)))
+ (when (or (file-symlink-p oldmaster)
+ (file-symlink-p (file-name-directory oldmaster)))
+ (error "This is unsafe in the presence of symbolic links"))
+ (rename-file
+ oldmaster
+ (catch 'found
+ ;; If possible, keep the master file in the same directory.
+ (dolist (f masters)
+ (when (and f (string= (file-name-directory (expand-file-name f)) dir))
+ (throw 'found f)))
+ ;; If not, just use the first possible place.
+ (dolist (f masters)
+ (and f (or (not (setq dir (file-name-directory f)))
+ (file-directory-p dir))
+ (throw 'found f)))
+ (error "New file lacks a version control directory")))))
+
+;;;###autoload
+(defun vc-delete-file (file)
+ "Delete file and mark it as such in the version control system."
+ (interactive "fVC delete file: ")
+ (setq file (expand-file-name file))
+ (let ((buf (get-file-buffer file))
+ (backend (vc-backend file)))
+ (unless backend
+ (error "File %s is not under version control"
+ (file-name-nondirectory file)))
+ (unless (vc-find-backend-function backend 'delete-file)
+ (error "Deleting files under %s is not supported in VC" backend))
+ (when (and buf (buffer-modified-p buf))
+ (error "Please save or undo your changes before deleting %s" file))
+ (let ((state (vc-state file)))
+ (when (eq state 'edited)
+ (error "Please commit or undo your changes before deleting %s" file))
+ (when (eq state 'conflict)
+ (error "Please resolve the conflicts before deleting %s" file)))
+ (unless (y-or-n-p (format "Really want to delete %s? "
+ (file-name-nondirectory file)))
+ (error "Abort!"))
+ (unless (or (file-directory-p file) (null make-backup-files)
+ (not (file-exists-p file)))
+ (with-current-buffer (or buf (find-file-noselect file))
+ (let ((backup-inhibited nil))
+ (backup-buffer))))
+ ;; Bind `default-directory' so that the command that the backend
+ ;; runs to remove the file is invoked in the correct context.
+ (let ((default-directory (file-name-directory file)))
+ (vc-call-backend backend 'delete-file file))
+ ;; If the backend hasn't deleted the file itself, let's do it for him.
+ (when (file-exists-p file) (delete-file file))
+ ;; Forget what VC knew about the file.
+ (vc-file-clearprops file)
+ ;; Make sure the buffer is deleted and the *vc-dir* buffers are
+ ;; updated after this.
+ (vc-resynch-buffer file nil t)))
+
+;;;###autoload
+(defun vc-rename-file (old new)
+ "Rename file OLD to NEW in both work area and repository."
+ (interactive "fVC rename file: \nFRename to: ")
+ ;; in CL I would have said (setq new (merge-pathnames new old))
+ (let ((old-base (file-name-nondirectory old)))
+ (when (and (not (string= "" old-base))
+ (string= "" (file-name-nondirectory new)))
+ (setq new (concat new old-base))))
+ (let ((oldbuf (get-file-buffer old)))
+ (when (and oldbuf (buffer-modified-p oldbuf))
+ (error "Please save files before moving them"))
+ (when (get-file-buffer new)
+ (error "Already editing new file name"))
+ (when (file-exists-p new)
+ (error "New file already exists"))
+ (let ((state (vc-state old)))
+ (unless (memq state '(up-to-date edited))
+ (error "Please %s files before moving them"
+ (if (stringp state) "check in" "update"))))
+ (vc-call rename-file old new)
+ (vc-file-clearprops old)
+ ;; Move the actual file (unless the backend did it already)
+ (when (file-exists-p old) (rename-file old new))
+ ;; ?? Renaming a file might change its contents due to keyword expansion.
+ ;; We should really check out a new copy if the old copy was precisely equal
+ ;; to some checked-in revision. However, testing for this is tricky....
+ (when oldbuf
+ (with-current-buffer oldbuf
+ (let ((buffer-read-only buffer-read-only))
+ (set-visited-file-name new))
+ (vc-mode-line new (vc-backend new))
+ (set-buffer-modified-p nil)))))
+
+;;;###autoload
+(defun vc-update-change-log (&rest args)
+ "Find change log file and add entries from recent version control logs.
+Normally, find log entries for all registered files in the default
+directory.
+
+With prefix arg of \\[universal-argument], only find log entries for the current buffer's file.
+
+With any numeric prefix arg, find log entries for all currently visited
+files that are under version control. This puts all the entries in the
+log for the default directory, which may not be appropriate.
+
+From a program, any ARGS are assumed to be filenames for which
+log entries should be gathered."
+ (interactive
+ (cond ((consp current-prefix-arg) ;C-u
+ (list buffer-file-name))
+ (current-prefix-arg ;Numeric argument.
+ (let ((files nil)
+ (buffers (buffer-list))
+ file)
+ (while buffers
+ (setq file (buffer-file-name (car buffers)))
+ (and file (vc-backend file)
+ (setq files (cons file files)))
+ (setq buffers (cdr buffers)))
+ files))
+ (t
+ ;; Don't supply any filenames to backend; this means
+ ;; it should find all relevant files relative to
+ ;; the default-directory.
+ nil)))
+ (vc-call-backend (vc-responsible-backend default-directory)
+ 'update-changelog args))
+
+;; functions that operate on RCS revision numbers. This code should
+;; also be moved into the backends. It stays for now, however, since
+;; it is used in code below.
+(defun vc-branch-p (rev)
+ "Return t if REV is a branch revision."
+ (not (eq nil (string-match "\\`[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*\\'" rev))))
+
+;;;###autoload
+(defun vc-branch-part (rev)
+ "Return the branch part of a revision number REV."
+ (let ((index (string-match "\\.[0-9]+\\'" rev)))
+ (when index
+ (substring rev 0 index))))
+
+(define-obsolete-function-alias
+ 'vc-default-previous-version 'vc-default-previous-revision "23.1")
+
+(defun vc-default-responsible-p (backend file)
+ "Indicate whether BACKEND is reponsible for FILE.
+The default is to return nil always."
+ nil)
+
+(defun vc-default-could-register (backend file)
+ "Return non-nil if BACKEND could be used to register FILE.
+The default implementation returns t for all files."
+ t)
+
+(defun vc-default-latest-on-branch-p (backend file)
+ "Return non-nil if FILE is the latest on its branch.
+This default implementation always returns non-nil, which means that
+editing non-current revisions is not supported by default."
+ t)
+
+(defun vc-default-init-revision (backend) vc-default-init-revision)
+
+(defun vc-default-find-revision (backend file rev buffer)
+ "Provide the new `find-revision' op based on the old `checkout' op.
+This is only for compatibility with old backends. They should be updated
+to provide the `find-revision' operation instead."
+ (let ((tmpfile (make-temp-file (expand-file-name file))))
+ (unwind-protect
+ (progn
+ (vc-call-backend backend 'checkout file nil rev tmpfile)
+ (with-current-buffer buffer
+ (insert-file-contents-literally tmpfile)))
+ (delete-file tmpfile))))
+
+(defun vc-default-rename-file (backend old new)
+ (condition-case nil
+ (add-name-to-file old new)
+ (error (rename-file old new)))
+ (vc-delete-file old)
+ (with-current-buffer (find-file-noselect new)
+ (vc-register)))
+
+(defalias 'vc-default-check-headers 'ignore)
+
+(declare-function log-edit-mode "log-edit" ())
+
+(defun vc-default-log-edit-mode (backend) (log-edit-mode))
+
+(defun vc-default-log-view-mode (backend) (log-view-mode))
+
+(defun vc-default-show-log-entry (backend rev)
+ (with-no-warnings
+ (log-view-goto-rev rev)))
+
+(defun vc-default-comment-history (backend file)
+ "Return a string with all log entries stored in BACKEND for FILE."
+ (when (vc-find-backend-function backend 'print-log)
+ (with-current-buffer "*vc*"
+ (vc-call-backend backend 'print-log (list file))
+ (buffer-string))))
+
+(defun vc-default-receive-file (backend file rev)
+ "Let BACKEND receive FILE from another version control system."
+ (vc-call-backend backend 'register (list file) rev ""))
+
+(defun vc-default-retrieve-tag (backend dir name update)
+ (if (string= name "")
+ (progn
+ (vc-file-tree-walk
+ dir
+ (lambda (f) (and
+ (vc-up-to-date-p f)
+ (vc-error-occurred
+ (vc-call-backend backend 'checkout f nil "")
+ (when update (vc-resynch-buffer f t t)))))))
+ (let ((result (vc-tag-precondition dir)))
+ (if (stringp result)
+ (error "File %s is locked" result)
+ (setq update (and (eq result 'visited) update))
+ (vc-file-tree-walk
+ dir
+ (lambda (f) (vc-error-occurred
+ (vc-call-backend backend 'checkout f nil name)
+ (when update (vc-resynch-buffer f t t)))))))))
+
+(defun vc-default-revert (backend file contents-done)
+ (unless contents-done
+ (let ((rev (vc-working-revision file))
+ (file-buffer (or (get-file-buffer file) (current-buffer))))
+ (message "Checking out %s..." file)
+ (let ((failed t)
+ (backup-name (car (find-backup-file-name file))))
+ (when backup-name
+ (copy-file file backup-name 'ok-if-already-exists 'keep-date)
+ (unless (file-writable-p file)
+ (set-file-modes file (logior (file-modes file) 128))))
+ (unwind-protect
+ (let ((coding-system-for-read 'no-conversion)
+ (coding-system-for-write 'no-conversion))
+ (with-temp-file file
+ (let ((outbuf (current-buffer)))
+ ;; Change buffer to get local value of vc-checkout-switches.
+ (with-current-buffer file-buffer
+ (let ((default-directory (file-name-directory file)))
+ (vc-call-backend backend 'find-revision
+ file rev outbuf)))))
+ (setq failed nil))
+ (when backup-name
+ (if failed
+ (rename-file backup-name file 'ok-if-already-exists)
+ (and (not vc-make-backup-files) (delete-file backup-name))))))
+ (message "Checking out %s...done" file))))
+
+(defalias 'vc-default-revision-completion-table 'ignore)
+(defalias 'vc-default-mark-resolved 'ignore)
+
+(defun vc-default-dir-status-files (backend dir files default-state update-function)
+ (funcall update-function
+ (mapcar (lambda (file) (list file default-state)) files)))
+
+(defun vc-check-headers ()
+ "Check if the current file has any headers in it."
+ (interactive)
+ (vc-call-backend (vc-backend buffer-file-name) 'check-headers))
+
+\f
+
+;; These things should probably be generally available
+
+(defun vc-string-prefix-p (prefix string)
+ (let ((lpref (length prefix)))
+ (and (>= (length string) lpref)
+ (eq t (compare-strings prefix nil nil string nil lpref)))))
+
+(defun vc-file-tree-walk (dirname func &rest args)
+ "Walk recursively through DIRNAME.
+Invoke FUNC f ARGS on each VC-managed file f underneath it."
+ (vc-file-tree-walk-internal (expand-file-name dirname) func args)
+ (message "Traversing directory %s...done" dirname))
+
+(defun vc-file-tree-walk-internal (file func args)
+ (if (not (file-directory-p file))
+ (when (vc-backend file) (apply func file args))
+ (message "Traversing directory %s..." (abbreviate-file-name file))
+ (let ((dir (file-name-as-directory file)))
+ (mapcar
+ (lambda (f) (or
+ (string-equal f ".")
+ (string-equal f "..")
+ (member f vc-directory-exclusion-list)
+ (let ((dirf (expand-file-name f dir)))
+ (or
+ (file-symlink-p dirf) ;; Avoid possible loops.
+ (vc-file-tree-walk-internal dirf func args)))))
+ (directory-files dir)))))
+
+(provide 'vc)
+
+;; arch-tag: ca82c1de-3091-4e26-af92-460abc6213a6
+;;; vc.el ends here
projects / emacs.git / commitdiff