# HG changeset patch # User Katsumi Yamaoka # Date 1276338254 0 # Node ID 1d9fd74dc4acb1e0fd18f19dec66bb38ad40ef7a # Parent cc0ad61fb2a48eb04cd7dacfbd1c2e84e8bb5894# Parent c4552014bea2ef4f755283d58b885fa65d79a55d Merge from mainline. diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac ChangeLog --- a/ChangeLog Fri Jun 11 12:14:41 2010 +0000 +++ b/ChangeLog Sat Jun 12 10:24:14 2010 +0000 @@ -1,3 +1,7 @@ +2010-06-12 Glenn Morris + + * Makefile.in (install-arch-indep): Delete any old info .gz files first. + 2010-06-11 Glenn Morris * configure.in (--without-compress-info): New option. diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac Makefile.in --- a/Makefile.in Fri Jun 11 12:14:41 2010 +0000 +++ b/Makefile.in Sat Jun 12 10:24:14 2010 +0000 @@ -583,6 +583,7 @@ ${INSTALL_DATA} $$f $(DESTDIR)${infodir}/$$f; \ chmod a+r $(DESTDIR)${infodir}/$$f; \ if [ -n "${GZIP_INFO}" ] && [ -n "${GZIP_PROG}" ]; then \ + rm -f $(DESTDIR)${infodir}/$$f.gz; \ ${GZIP_PROG} -9n $(DESTDIR)${infodir}/$$f; \ else true; fi; \ done; \ @@ -606,6 +607,7 @@ ${INSTALL_DATA} ${mansrcdir}/$${page} $(DESTDIR)${man1dir}/$${page}; \ chmod a+r $(DESTDIR)${man1dir}/$${page}; \ if [ -n "${GZIP_INFO}" ] && [ -n "${GZIP_PROG}" ]; then \ + rm -f $(DESTDIR)${man1dir}/$${page}.gz; \ ${GZIP_PROG} -9n $(DESTDIR)${man1dir}/$${page}; \ else true; fi ); \ done diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lib-src/ChangeLog --- a/lib-src/ChangeLog Fri Jun 11 12:14:41 2010 +0000 +++ b/lib-src/ChangeLog Sat Jun 12 10:24:14 2010 +0000 @@ -1,3 +1,8 @@ +2010-06-11 Juanma Barranquero + + * makefile.w32-in (lisp2): Fix references to vc/vc-hooks.elc + and vc/ediff-hook.elc. + 2010-06-06 Dan Nicolaescu * ntlib.h: Remove code dealing with BSTRING. diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lib-src/makefile.w32-in --- a/lib-src/makefile.w32-in Fri Jun 11 12:14:41 2010 +0000 +++ b/lib-src/makefile.w32-in Sat Jun 12 10:24:14 2010 +0000 @@ -279,8 +279,8 @@ $(lispsource)textmodes/text-mode.elc \ $(lispsource)emacs-lisp/timer.elc \ $(lispsource)jka-cmpr-hook.elc \ - $(lispsource)vc-hooks.elc \ - $(lispsource)ediff-hook.elc \ + $(lispsource)vc/vc-hooks.elc \ + $(lispsource)vc/ediff-hook.elc \ $(lispsource)epa-hook.elc \ $(TOOLTIP_SUPPORT) \ $(WINNT_SUPPORT) \ diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ChangeLog --- a/lisp/ChangeLog Fri Jun 11 12:14:41 2010 +0000 +++ b/lisp/ChangeLog Sat Jun 12 10:24:14 2010 +0000 @@ -1,3 +1,58 @@ +2010-06-12 Michael Albinus + + * net/tramp.el (tramp-remote-process-environment): Protect version + string by apostroph. + (tramp-shell-prompt-pattern): Do not use a shy group in case of + XEmacs. + (tramp-file-name-for-operation): Add `call-process-region'. + (tramp-set-process-query-on-exit-flag): Fix wrong parentheses. + + * net/tramp-compat.el (top): Do not autoload + `tramp-handle-file-remote-p'. Load tramp-util.el and tramp-vc.el + only when `start-file-process' is not bound. + (tramp-advice-file-expand-wildcards): Do not use + `tramp-handle-file-remote-p'. + (tramp-compat-make-temp-file): Handle the case, that + `make-temp-file' has no third argument EXTENSION. + +2010-06-11 Juanma Barranquero + + * makefile.w32-in (WINS_BASIC): Include new directory vc. + + * loadup.el ("vc-hooks", "ediff-hook"): Load from lisp/vc/. + +2010-06-11 Juri Linkov + + * finder.el (finder-known-keywords): Add keyword "vc" + for version control. + + * add-log.el, cvs-status.el, diff.el, diff-mode.el, ediff.el, + * emerge.el, log-edit.el, log-view.el, pcvs.el, smerge-mode.el, + * vc-annotate.el, vc-bzr.el, vc-dir.el, vc-dispatcher.el, vc-git.el, + * vc-hg.el, vc-mtn.el, vc.el: Add keyword "vc". + +2010-06-11 Juri Linkov + + 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 + + * comint.el (comint-password-prompt-regexp): Fix 2010-04-10 change + (Bug#6367). + +2010-06-11 Stephen Eglen + + * shell.el: Bind `shell-resync-dirs' to M-RET. + 2010-06-10 Michael Albinus * notifications.el: Move file from lisp/net, because it is @@ -7,7 +62,7 @@ * net/notifications.el (notifications-on-action-signal) (notifications-on-closed-signal): Pass notification id as first - argument to the callback functions. Add docstrings. + argument to the callback functions. Add docstrings. (notifications-notify): Fix docstring. 2010-06-10 Glenn Morris diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/add-log.el --- a/lisp/add-log.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1365 +0,0 @@ -;;; 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 . - -;;; 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))) - -(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 "]")))))) - -(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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/comint.el --- a/lisp/comint.el Fri Jun 11 12:14:41 2010 +0000 +++ b/lisp/comint.el Sat Jun 12 10:24:14 2010 +0000 @@ -340,7 +340,7 @@ ;; Something called "perforce" uses "Enter password:". (defcustom comint-password-prompt-regexp (concat - "^\\(" + "\\(" (regexp-opt '("Enter" "Enter same" "Old" "old" "New" "new" "'s" "login" "Kerberos" "CVS" "UNIX" " SMB" "LDAP" "[sudo]" "Repeat" "Bad")) diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/cvs-status.el --- a/lisp/cvs-status.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,540 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/diff-mode.el --- a/lisp/diff-mode.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1935 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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 () -;; 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 ' to try and fuzzily discover the source location -;; of a hunk. Show then the changes between and and make it -;; possible to apply them to , , or . -;; 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]") - "^[ <>!+-]")))) - (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)) - ;; .rej patches implicitly apply to - (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 ]*" - (mapconcat 'regexp-quote (split-string text) "[ \t\n ]+") - "[ \t\n ]*\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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/diff.el --- a/lisp/diff.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,205 +0,0 @@ -;;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff-diff.el --- a/lisp/ediff-diff.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1536 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff-help.el --- a/lisp/ediff-help.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,321 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff-hook.el --- a/lisp/ediff-hook.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,263 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff-init.el --- a/lisp/ediff-init.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1821 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff-merg.el --- a/lisp/ediff-merg.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,397 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff-mult.el --- a/lisp/ediff-mult.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2476 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff-ptch.el --- a/lisp/ediff-ptch.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,844 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff-util.el --- a/lisp/ediff-util.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4291 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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)) - - -;;; 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)) - - - -;;; 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)) - )) - - -;;; 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 - ))) - - -;;; 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))) - ))) - - - -;;; 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))) - - - - -;;; 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 -(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)) - - - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff-vers.el --- a/lisp/ediff-vers.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,239 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff-wind.el --- a/lisp/ediff-wind.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1313 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 . \) \(left . \)\)" - :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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/ediff.el --- a/lisp/ediff.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1565 +0,0 @@ -;;; 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 -;; Created: February 2, 1994 -;; Keywords: comparing, merging, patching, tools, unix - -;; Yoni Rabkin 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 . - -;;; 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 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) - - - - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/emerge.el --- a/lisp/emerge.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3209 +0,0 @@ -;;; 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 -;; 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-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-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-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-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))))) - -;; 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 /## - (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 - ;; ~/#&&# - (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 ~/#%%# - (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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/finder.el --- a/lisp/finder.el Fri Jun 11 12:14:41 2010 +0000 +++ b/lisp/finder.el Sat Jun 12 10:24:14 2010 +0000 @@ -76,6 +76,7 @@ (tex . "supporting code for the TeX formatter") (tools . "programming tools") (unix . "front-ends/assistants for, or emulators of, UNIX-like features") + (vc . "version control") (wp . "word processing") )) diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/loadup.el --- a/lisp/loadup.el Fri Jun 11 12:14:41 2010 +0000 +++ b/lisp/loadup.el Sat Jun 12 10:24:14 2010 +0000 @@ -243,8 +243,8 @@ (progn ; floating pt. functions if we have float support. (load "emacs-lisp/float-sup"))) -(load "vc-hooks") -(load "ediff-hook") +(load "vc/vc-hooks") +(load "vc/ediff-hook") (if (fboundp 'x-show-tip) (load "tooltip")) ;If you want additional libraries to be preloaded and their diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/log-edit.el --- a/lisp/log-edit.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,835 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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) - - -;; 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. -\\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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/log-view.el --- a/lisp/log-view.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,545 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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 -;; * 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 -;; * 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 -;; date: Wed Dec 26 12:18:58 2007 -0500 -;; summary: Explain keywords. Add markup fixes. -;; -;; changeset: 10:20abc7ab09c3 -;; user: Eric S. Raymond -;; date: Wed Dec 26 11:37:28 2007 -0500 -;; summary: Typo fixes. -;; -;; changeset: 9:ada9f4da88aa -;; user: Eric S. Raymond -;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/makefile.w32-in --- a/lisp/makefile.w32-in Fri Jun 11 12:14:41 2010 +0000 +++ b/lisp/makefile.w32-in Sat Jun 12 10:24:14 2010 +0000 @@ -114,7 +114,8 @@ play \ progmodes \ textmodes \ - url + url \ + vc # Directories with lisp files to compile, and to extract data from # (customs, autoloads, etc.) diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/net/tramp-compat.el --- a/lisp/net/tramp-compat.el Fri Jun 11 12:14:41 2010 +0000 +++ b/lisp/net/tramp-compat.el Sat Jun 12 10:24:14 2010 +0000 @@ -44,33 +44,31 @@ (autoload 'tramp-tramp-file-p "tramp") (autoload 'tramp-file-name-handler "tramp") - (autoload 'tramp-handle-file-remote-p "tramp") + + ;; We check whether `start-file-process' is bound. + (unless (fboundp 'start-file-process) - ;; tramp-util offers integration into other (X)Emacs packages like - ;; compile.el, gud.el etc. Not necessary in Emacs 23. - (eval-after-load "tramp" - ;; We check whether `start-file-process' is an alias. - '(when (or (not (fboundp 'start-file-process)) - (symbolp (symbol-function 'start-file-process))) - (require 'tramp-util) - (add-hook 'tramp-unload-hook - '(lambda () - (when (featurep 'tramp-util) - (unload-feature 'tramp-util 'force)))))) - - ;; Make sure that we get integration with the VC package. When it - ;; is loaded, we need to pull in the integration module. Not - ;; necessary in Emacs 23. - (eval-after-load "vc" + ;; tramp-util offers integration into other (X)Emacs packages like + ;; compile.el, gud.el etc. Not necessary in Emacs 23. (eval-after-load "tramp" - ;; We check whether `start-file-process' is an alias. - '(when (or (not (fboundp 'start-file-process)) - (symbolp (symbol-function 'start-file-process))) - (require 'tramp-vc) + '(progn + (require 'tramp-util) (add-hook 'tramp-unload-hook '(lambda () - (when (featurep 'tramp-vc) - (unload-feature 'tramp-vc 'force))))))) + (when (featurep 'tramp-util) + (unload-feature 'tramp-util 'force)))))) + + ;; Make sure that we get integration with the VC package. When it + ;; is loaded, we need to pull in the integration module. Not + ;; necessary in Emacs 23. + (eval-after-load "vc" + (eval-after-load "tramp" + '(progn + (require 'tramp-vc) + (add-hook 'tramp-unload-hook + '(lambda () + (when (featurep 'tramp-vc) + (unload-feature 'tramp-vc 'force)))))))) ;; Avoid byte-compiler warnings if the byte-compiler supports this. ;; Currently, XEmacs supports this. @@ -176,7 +174,8 @@ (if (and (tramp-tramp-file-p name) (not (string-match - "[[*?]" (tramp-handle-file-remote-p name 'localname)))) + "[[*?]" (tramp-compat-funcall + 'file-remote-p name 'localname)))) (setq ad-return-value (list name)) ;; Otherwise, just run the original function. ad-do-it))) @@ -236,22 +235,23 @@ (tramp-compat-temporary-file-directory))) (extension (file-name-extension filename t)) result) - (if (fboundp 'make-temp-file) + (condition-case nil (setq result (tramp-compat-funcall 'make-temp-file prefix dir-flag extension)) - ;; We use our own implementation, taken from files.el. - (while - (condition-case () - (progn - (setq result (concat (make-temp-name prefix) extension)) - (if dir-flag - (make-directory result) - (write-region "" nil result nil 'silent)) - 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)) + (error + ;; We use our own implementation, taken from files.el. + (while + (condition-case () + (progn + (setq result (concat (make-temp-name prefix) extension)) + (if dir-flag + (make-directory result) + (write-region "" nil result nil 'silent)) + 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))) result)) ;; `most-positive-fixnum' does not exist in XEmacs. diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/net/tramp.el --- a/lisp/net/tramp.el Fri Jun 11 12:14:41 2010 +0000 +++ b/lisp/net/tramp.el Sat Jun 12 10:24:14 2010 +0000 @@ -1065,7 +1065,7 @@ `("HISTFILE=$HOME/.tramp_history" "HISTSIZE=1" "LC_ALL=C" ,(format "TERM=%s" tramp-terminal-type) "EMACS=t" ;; Deprecated. - ,(format "INSIDE_EMACS=%s,tramp:%s" emacs-version tramp-version) + ,(format "INSIDE_EMACS='%s,tramp:%s'" emacs-version tramp-version) "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "autocorrect=" "correct=") @@ -1091,8 +1091,10 @@ (defcustom tramp-shell-prompt-pattern ;; Allow a prompt to start right after a ^M since it indeed would be - ;; displayed at the beginning of the line (and Zsh uses it). - "\\(?:^\\|\r\\)[^#$%>\n]*#?[#$%>] *\\(\e\\[[0-9;]*[a-zA-Z] *\\)*" + ;; displayed at the beginning of the line (and Zsh uses it). This + ;; regexp works only for GNU Emacs. + (concat (if (featurep 'xemacs) "" "\\(?:^\\|\r\\)") + "[^#$%>\n]*#?[#$%>] *\\(\e\\[[0-9;]*[a-zA-Z] *\\)*") "Regexp to match prompts from remote shell. Normally, Tramp expects you to configure `shell-prompt-pattern' correctly, but sometimes it happens that you are connecting to a @@ -5513,7 +5515,8 @@ ;; XEmacs only. 'dired-print-file 'dired-shell-call-process ;; nowhere yet. - 'executable-find 'start-process 'call-process)) + 'executable-find 'start-process + 'call-process 'call-process-region)) default-directory) ;; Unknown file primitive. (t (error "unknown file I/O primitive: %s" operation)))) @@ -8758,7 +8761,7 @@ exiting if process is running." (if (fboundp 'set-process-query-on-exit-flag) (tramp-compat-funcall 'set-process-query-on-exit-flag process flag) - (tramp-compat-funcall 'process-kill-without-query) process flag)) + (tramp-compat-funcall 'process-kill-without-query process flag))) ;; ------------------------------------------------------------ @@ -8914,7 +8917,7 @@ ;; rsync). ;; * Keep a second connection open for out-of-band methods like scp or ;; rsync. -;; * Support ptys in `tramp-handle-start-file-process'. (Bug#4604) +;; * Support ptys in `tramp-handle-start-file-process'. (Bug#4604, Bug#6360) ;; * IMHO, it's a drawback that currently Tramp doesn't support ;; Unicode in Dired file names by default. Is it possible to ;; improve Tramp to set LC_ALL to "C" only for commands where Tramp diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/pcvs-defs.el --- a/lisp/pcvs-defs.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,528 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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.") - - -;;;; -;;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/pcvs-info.el --- a/lisp/pcvs-info.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,489 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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))) - - -;; 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)))) - - -;;;; -;;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/pcvs-parse.el --- a/lisp/pcvs-parse.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,538 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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))))) - - -(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)))) - -;;;; 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 ' - (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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/pcvs-util.el --- a/lisp/pcvs-util.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,371 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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 ) 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/pcvs.el --- a/lisp/pcvs.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2443 +0,0 @@ -;;; 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 . - -;;; 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 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) - - -;;;; -;;;; 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) - - -;;;; -;;;; 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) "") - ;; 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) "")) - ;; 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+" 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))))))) - - - -;;;; -;;;; 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))) - -;;;; -;;;; 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))))))))) - - -;;;; -;;;; 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- 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- 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"))))) - - -;;;; -;;;; 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))) - - -(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)))))))) - - -(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) - - -(provide 'pcvs) - -;; arch-tag: 8e3a7494-0453-4389-9ab3-a557ce9fab61 -;;; pcvs.el ends here diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/shell.el --- a/lisp/shell.el Fri Jun 11 12:14:41 2010 +0000 +++ b/lisp/shell.el Sat Jun 12 10:24:14 2010 +0000 @@ -340,6 +340,7 @@ (define-key shell-mode-map "\C-c\C-f" 'shell-forward-command) (define-key shell-mode-map "\C-c\C-b" 'shell-backward-command) (define-key shell-mode-map "\t" 'comint-dynamic-complete) + (define-key shell-mode-map (kbd "M-RET") 'shell-resync-dirs) (define-key shell-mode-map "\M-?" 'comint-dynamic-list-filename-completions) (define-key shell-mode-map [menu-bar completion] diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/smerge-mode.el --- a/lisp/smerge-mode.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1231 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-annotate.el --- a/lisp/vc-annotate.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,676 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-arch.el --- a/lisp/vc-arch.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,641 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-bzr.el --- a/lisp/vc-bzr.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1057 +0,0 @@ -;;; 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 -;; Riccardo Murri -;; 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 . - -;;; Commentary: - -;; See concerning bzr. See -;; 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:: - ;; | : - ;; | - ;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-cvs.el --- a/lisp/vc-cvs.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1213 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-dav.el --- a/lisp/vc-dav.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,189 +0,0 @@ -;;; 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 -;; Maintainer: Bill Perry -;; 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 . - - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-dir.el --- a/lisp/vc-dir.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1256 +0,0 @@ -;;; vc-dir.el --- Directory status display under VC - -;; Copyright (C) 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. - -;; Author: Dan Nicolaescu -;; 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 . - -;;; 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 -;; Stefan Monnier -;; Tom Tromey - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-dispatcher.el --- a/lisp/vc-dispatcher.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,695 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-git.el --- a/lisp/vc-git.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1031 +0,0 @@ -;;; 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 -;; 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 . - -;;; 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 - ("^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 \\\\[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 -- " 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))) - - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-hg.el --- a/lisp/vc-hg.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,630 +0,0 @@ -;;; 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 . - -;;; 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) - - -;;; 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 - ("^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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-hooks.el --- a/lisp/vc-hooks.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1055 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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)) - - -;; 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)) - -(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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-mtn.el --- a/lisp/vc-mtn.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,344 +0,0 @@ -;;; vc-mtn.el --- VC backend for Monotone - -;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Stefan Monnier -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-rcs.el --- a/lisp/vc-rcs.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1470 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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) - - -;;; 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))) - - -;;; -;;; 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)))) - - -;;; -;;; 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)) - - -;;; -;;; 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 ":"))))))) - - -;;; -;;; 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))) - - -;;; -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-sccs.el --- a/lisp/vc-sccs.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,485 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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) - - -;;; -;;; Internal variables -;;; - -(defconst vc-sccs-name-assoc-file "VC-names") - - -;;; 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)))))) - - -;;; -;;; 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)))) - - -;;; -;;; 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)))) - - -;;; -;;; 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))))))) - - -;;; -;;; 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))) - - -;;; -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc-svn.el --- a/lisp/vc-svn.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,747 +0,0 @@ -;;; 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 - -;; 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 . - -;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc.el --- a/lisp/vc.el Fri Jun 11 12:14:41 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2702 +0,0 @@ -;;; 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 -;; 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 . - -;;; Credits: - -;; VC was initially designed and implemented by Eric S. Raymond -;; in 1992. Over the years, many other people have -;; contributed substantial amounts of work to VC. These include: -;; -;; Per Cederqvist -;; Paul Eggert -;; Sebastian Kremer -;; Martin Lorentzson -;; Dave Love -;; Stefan Monnier -;; Thien-Thi Nguyen -;; Dan Nicolaescu -;; J.D. Smith -;; Andre Spiegel -;; Richard Stallman -;; -;; 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") - - -;; 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)) - - - -;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/add-log.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/add-log.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1365 @@ +;;; 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: vc 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 . + +;;; 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))) + +(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 "]")))))) + +(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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/cvs-status.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/cvs-status.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,540 @@ +;;; 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 +;; Keywords: pcl-cvs cvs status tree vc 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/diff-mode.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/diff-mode.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1935 @@ +;;; 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 +;; Keywords: convenience patch diff vc + +;; 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 . + +;;; 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 () +;; 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 ' to try and fuzzily discover the source location +;; of a hunk. Show then the changes between and and make it +;; possible to apply them to , , or . +;; 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]") + "^[ <>!+-]")))) + (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)) + ;; .rej patches implicitly apply to + (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 ]*" + (mapconcat 'regexp-quote (split-string text) "[ \t\n ]+") + "[ \t\n ]*\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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/diff.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/diff.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,205 @@ +;;; 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, vc, 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff-diff.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff-diff.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1536 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff-help.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff-help.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,321 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff-hook.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff-hook.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,263 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff-init.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff-init.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1821 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff-merg.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff-merg.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,397 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff-mult.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff-mult.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,2476 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff-ptch.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff-ptch.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,844 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff-util.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff-util.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,4291 @@ +;;; 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 + +;; 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 . + +;;; 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)) + + +;;; 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)) + + + +;;; 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)) + )) + + +;;; 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 + ))) + + +;;; 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))) + ))) + + + +;;; 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))) + + + + +;;; 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 +(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)) + + + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff-vers.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff-vers.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,239 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff-wind.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff-wind.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1313 @@ +;;; 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 + +;; 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 . + +;;; 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 . \) \(left . \)\)" + :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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/ediff.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/ediff.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1565 @@ +;;; 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 +;; Created: February 2, 1994 +;; Keywords: comparing, merging, patching, vc, tools, unix + +;; Yoni Rabkin 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 . + +;;; 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 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) + + + + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/emerge.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/emerge.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,3209 @@ +;;; 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 +;; Keywords: unix, vc, 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-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-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-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-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))))) + +;; 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 /## + (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 + ;; ~/#&&# + (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 ~/#%%# + (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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/log-edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/log-edit.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,835 @@ +;;; 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 +;; Keywords: pcl-cvs cvs commit log vc + +;; 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 . + +;;; 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) + + +;; 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. +\\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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/log-view.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/log-view.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,545 @@ +;;; 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 +;; Keywords: rcs, sccs, cvs, log, vc, 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 . + +;;; 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 +;; * 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 +;; * 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 +;; date: Wed Dec 26 12:18:58 2007 -0500 +;; summary: Explain keywords. Add markup fixes. +;; +;; changeset: 10:20abc7ab09c3 +;; user: Eric S. Raymond +;; date: Wed Dec 26 11:37:28 2007 -0500 +;; summary: Typo fixes. +;; +;; changeset: 9:ada9f4da88aa +;; user: Eric S. Raymond +;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/pcvs-defs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/pcvs-defs.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,528 @@ +;;; 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 +;; 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 . + +;;; 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.") + + +;;;; +;;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/pcvs-info.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/pcvs-info.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,489 @@ +;;; 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 +;; 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 . + +;;; 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))) + + +;; 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)))) + + +;;;; +;;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/pcvs-parse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/pcvs-parse.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,538 @@ +;;; 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 +;; 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 . + +;;; 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))))) + + +(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)))) + +;;;; 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 ' + (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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/pcvs-util.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/pcvs-util.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,371 @@ +;;; 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 +;; 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 . + +;;; 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 ) 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/pcvs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/pcvs.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,2443 @@ +;;; 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, vc, 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 . + +;;; 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 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) + + +;;;; +;;;; 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) + + +;;;; +;;;; 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) "") + ;; 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) "")) + ;; 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+" 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))))))) + + + +;;;; +;;;; 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))) + +;;;; +;;;; 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))))))))) + + +;;;; +;;;; 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- 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- 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"))))) + + +;;;; +;;;; 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))) + + +(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)))))))) + + +(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) + + +(provide 'pcvs) + +;; arch-tag: 8e3a7494-0453-4389-9ab3-a557ce9fab61 +;;; pcvs.el ends here diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/smerge-mode.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/smerge-mode.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1231 @@ +;;; 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 +;; Keywords: vc, 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-annotate.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-annotate.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,676 @@ +;;; 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 +;; Maintainer: FSF +;; Keywords: vc 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-arch.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-arch.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,641 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-bzr.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-bzr.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1057 @@ +;;; 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 +;; Riccardo Murri +;; Keywords: vc 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 . + +;;; Commentary: + +;; See concerning bzr. See +;; 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:: + ;; | : + ;; | + ;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-cvs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-cvs.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1213 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-dav.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-dav.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,189 @@ +;;; 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 +;; Maintainer: Bill Perry +;; 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 . + + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-dir.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-dir.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1256 @@ +;;; vc-dir.el --- Directory status display under VC + +;; Copyright (C) 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Dan Nicolaescu +;; Keywords: vc 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 . + +;;; 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 +;; Stefan Monnier +;; Tom Tromey + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-dispatcher.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-dispatcher.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,695 @@ +;;; 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 +;; Keywords: vc 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-git.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-git.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1031 @@ +;;; 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 +;; Keywords: vc 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 . + +;;; 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 + ("^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 \\\\[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 -- " 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))) + + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-hg.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-hg.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,630 @@ +;;; 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: vc 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 . + +;;; 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) + + +;;; 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 + ("^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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-hooks.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-hooks.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1055 @@ +;;; 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 + +;; 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 . + +;;; 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)) + + +;; 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)) + +(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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-mtn.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-mtn.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,344 @@ +;;; vc-mtn.el --- VC backend for Monotone + +;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: vc + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-rcs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-rcs.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,1470 @@ +;;; 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 + +;; 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 . + +;;; 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) + + +;;; 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))) + + +;;; +;;; 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)))) + + +;;; +;;; 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)) + + +;;; +;;; 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 ":"))))))) + + +;;; +;;; 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))) + + +;;; +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-sccs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-sccs.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,485 @@ +;;; 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 + +;; 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 . + +;;; 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) + + +;;; +;;; Internal variables +;;; + +(defconst vc-sccs-name-assoc-file "VC-names") + + +;;; 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)))))) + + +;;; +;;; 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)))) + + +;;; +;;; 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)))) + + +;;; +;;; 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))))))) + + +;;; +;;; 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))) + + +;;; +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc-svn.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc-svn.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,747 @@ +;;; 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 + +;; 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 . + +;;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac lisp/vc/vc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vc/vc.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,2702 @@ +;;; 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 +;; Keywords: vc 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 . + +;;; Credits: + +;; VC was initially designed and implemented by Eric S. Raymond +;; in 1992. Over the years, many other people have +;; contributed substantial amounts of work to VC. These include: +;; +;; Per Cederqvist +;; Paul Eggert +;; Sebastian Kremer +;; Martin Lorentzson +;; Dave Love +;; Stefan Monnier +;; Thien-Thi Nguyen +;; Dan Nicolaescu +;; J.D. Smith +;; Andre Spiegel +;; Richard Stallman +;; +;; 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") + + +;; 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)) + + + +;; 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 diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac test/ChangeLog --- a/test/ChangeLog Fri Jun 11 12:14:41 2010 +0000 +++ b/test/ChangeLog Sat Jun 12 10:24:14 2010 +0000 @@ -1,3 +1,7 @@ +2010-06-11 Chong Yidong + + * comint-testsuite.el: New file. + 2010-06-02 Stefan Monnier * indent: New dir. diff -r cc0ad61fb2a4 -r 1d9fd74dc4ac test/comint-testsuite.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/comint-testsuite.el Sat Jun 12 10:24:14 2010 +0000 @@ -0,0 +1,59 @@ +;;; bytecomp-testsuite.el + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; 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 . + +;;; Commentary: + +;; Tests for comint and related modes. + +;;; Code: + +(require 'comint) + +(defun comint-testsuite-run () + (interactive) + (with-output-to-temp-buffer "*comint test*" + (comint-testsuite--test-comint-password-prompt-regexp))) + +(defun comint-testsuite--test-comint-password-prompt-regexp () + (interactive) + (let ((password-strings + '("foo@example.net's password: " ;ssh + "Password for foo@example.org: " ; knit + "Kerberos password for devnull/root GNU.ORG: " ; ksu + "Enter passphrase: " ; ssh-add + "Enter passphrase (empty for no passphrase): " ; ssh-keygen + "Enter same passphrase again: " ; ssh-keygen + "Passphrase for key root@GNU.ORG: " ; plink + "[sudo] password for user:" ; Ubuntu sudo + "Password (again):" + "Enter password:")) + fail) + (dolist (str password-strings) + (unless (string-match comint-password-prompt-regexp str) + (setq fail t) + (princ (format " ERROR: comint-password-prompt-regexp did not match %s\n" + str)))) + (if fail + (princ "FAILED: comint-password-prompt-regexp test\n") + (princ "PASSED: comint-password-prompt-regexp test\n")))) + +(provide 'comint-testsuite) + +;;; comint-testsuite.el ends here +